home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #16 / NN_1992_16.iso / spool / comp / lang / lisp / mcl / 1055 < prev    next >
Encoding:
Text File  |  1992-07-22  |  3.3 KB  |  91 lines
  1. Path: sparky!uunet!europa.asd.contel.com!darwin.sura.net!mips!apple!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: Getting slot accessors for defclass reconstruction
  5. Message-ID: <9207221435.AA14957@cambridge.apple.com>
  6. Date: 22 Jul 92 16:19:46 GMT
  7. Sender: info-mcl-request@cambridge.apple.com
  8. Lines: 77
  9. Approved: comp.lang.lisp.mcl@Cambridge.Apple.C0M
  10. Full-Name: Bill St. Clair
  11. Original-To: cornell@freya.cs.umass.edu
  12. Original-Cc: info-mcl
  13.  
  14. I forgot to require "LISPEQU" to get the definitions for %SLOTD-TYPE,
  15. %SLOTD-INITFORM, and %SLOTD-INITARGS. The code should be:
  16.  
  17. --------------------------------------------------------------------
  18.  
  19. ; slot-definition-accessors.lisp
  20. ;
  21. ; More of the AMOP slot definition accessors for MCL 2.0
  22.  
  23. (in-package :ccl)
  24.  
  25. (export '(slot-definition-initargs slot-definition-initform
  26.           slot-definition-initfunction slot-definition-type
  27.           slot-readers slot-writers
  28.           accessor-method-slot-definition))
  29.  
  30. (eval-when (:compile-toplevel :execute)
  31.   (require "LISPEQU"))
  32.  
  33. (defun maybe-slot-definition-p (thing)
  34.   (let ((sd thing))
  35.     (and (consp sd)
  36.          (consp (setq sd (cdr (the cons sd))))
  37.          (consp (cdr (the cons sd))))))
  38.  
  39. (defun ensure-slotd (thing)
  40.   (if (maybe-slot-definition-p thing)
  41.     thing
  42.     (require-type thing '(satisfies maybe-slot-definition-p))))
  43.  
  44. (defmethod slot-definition-initargs ((slotd list))
  45.   (%slotd-initargs (ensure-slotd slotd)))
  46.  
  47. (defmethod slot-definition-initform ((slotd list))
  48.   (let ((fun-or-form-list (%slotd-initform (ensure-slotd slotd))))
  49.     (if (listp fun-or-form-list)
  50.       (car fun-or-form-list)
  51.       `(funcall ,fun-or-form-list))))
  52.  
  53. (defmethod slot-definition-initfunction ((slotd list))
  54.   (let ((fun-or-form-list (%slotd-initform (ensure-slotd slotd))))
  55.     (cond ((null fun-or-form-list) nil)
  56.           ((listp fun-or-form-list) 
  57.            (let ((value (car fun-or-form-list)))
  58.              #'(lambda () value)))
  59.           (t fun-or-form-list))))
  60.  
  61. (defmethod slot-definition-type ((slotd list))
  62.   (or (%slotd-type (ensure-slotd slotd)) t))
  63.  
  64. ; The AMOP defines functions called SLOT-DEFINITION-READERS
  65. ; and SLOT-DEFINITION-WRITERS, which take a slot definition
  66. ; object as their single argument. MCL does not store the
  67. ; class in a slot definition object, so it can't work that way.
  68. (defun slot-readers (class slot-name)
  69.   (let ((res nil))
  70.     (dolist (accessor (%class-get class 'accessor-methods))
  71.       (if (and (eq slot-name (method-slot-name accessor))
  72.                (typep accessor 'standard-reader-method))
  73.         (push (method-name accessor) res)))
  74.     res))
  75.  
  76. (defun slot-writers (class slot-name)
  77.   (let ((res nil))
  78.     (dolist (accessor (%class-get class 'accessor-methods))
  79.       (if (and (eq slot-name (method-slot-name accessor))
  80.                (typep accessor 'standard-writer-method))
  81.         (push (method-name accessor) res)))
  82.     res))        
  83.  
  84. (defmethod accessor-method-slot-definition ((method standard-accessor-method))
  85.   (let* ((name (method-slot-name method))
  86.          (class (car (method-specializers method))))
  87.     (or (assq name (class-direct-instance-slots class))
  88.         (assq name (class-direct-class-slots class))
  89.         (error "Can't find slot definition for slot named ~s of ~s"
  90.                name class))))
  91.