home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / unix / volume10 / comobj.lisp / part03 / high.l < prev   
Encoding:
Text File  |  1987-07-30  |  9.4 KB  |  288 lines
  1. ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
  5. ;;;
  6. ;;; Use and copying of this software and preparation of derivative works
  7. ;;; based upon this software are permitted.  Any distribution of this
  8. ;;; software or derivative works must comply with all applicable United
  9. ;;; States export control laws.
  10. ;;; 
  11. ;;; This software is made available AS IS, and Xerox Corporation makes no
  12. ;;; warranty about the software, its performance or its conformity to any
  13. ;;; specification.
  14. ;;; 
  15. ;;; Any person obtaining a copy of this software is requested to send their
  16. ;;; name and post office or electronic mail address to:
  17. ;;;   CommonLoops Coordinator
  18. ;;;   Xerox Artifical Intelligence Systems
  19. ;;;   2400 Hanover St.
  20. ;;;   Palo Alto, CA 94303
  21. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  22. ;;;
  23. ;;; Suggestions, comments and requests for improvements are also welcome.
  24. ;;; *************************************************************************
  25. ;;;
  26. ;;; Non-Bootstrap stuff
  27. ;;;
  28.  
  29. (in-package 'pcl :nicknames '(portable-commonloops))
  30.  
  31.  
  32. (ndefstruct (obsolete-class (:class class)
  33.                             (:include (class))))
  34.  
  35.  
  36. (defmeth get-slot-using-class ((class obsolete-class)
  37.                    object slot-name
  38.                    dont-call-slot-missing-p
  39.                    default)
  40.   (change-class object
  41.         (cadr (get-slot class 'class-precedence-list)))
  42.   (get-slot-using-class
  43.     (class-of object) object slot-name dont-call-slot-missing-p default))
  44.  
  45.  
  46.   ;;   
  47. ;;;;;; 
  48.   ;;   
  49.  
  50.  
  51. (defmeth describe-class (class-or-class-name
  52.               &optional (stream *standard-output*))
  53.   (flet ((pretty-class (class) (or (class-name class) class)))
  54.     (if (symbolp class-or-class-name)
  55.     (describe-class (class-named class-or-class-name) stream)
  56.     (let ((class class-or-class-name))
  57.       (format stream
  58.           "~&The class ~S is an instance of class ~S."
  59.           class
  60.           (class-of class))
  61.       (format stream "~&Name:~23T~S~%~
  62.                 Class-Precedence-List:~23T~S~%~
  63.                             Local-Supers:~23T~S~%~
  64.                             Direct-Subclasses:~23T~S"
  65.           (class-name class)
  66.           (mapcar #'pretty-class (class-class-precedence-list class))
  67.           (mapcar #'pretty-class (class-local-supers class))
  68.           (mapcar #'pretty-class (class-direct-subclasses class)))
  69.       class))))
  70.  
  71. (defun describe-instance (object &optional (stream t))
  72.   (let* ((class (class-of object))
  73.          (instance-slots (class-instance-slots class))
  74.          (non-instance-slots (class-non-instance-slots class))
  75.          (dynamic-slots (iwmc-class-dynamic-slots object))
  76.      (max-slot-name-length 0))
  77.     (macrolet ((adjust-slot-name-length (name)
  78.          `(setq max-slot-name-length
  79.             (max max-slot-name-length
  80.                  (length (the string (symbol-name ,name))))))
  81.            (describe-slot (name value &optional (allocation () alloc-p))
  82.          (if alloc-p
  83.              `(format stream
  84.                   "~% ~A ~S ~VT  ~S"
  85.                   ,name ,allocation (+ max-slot-name-length 7)
  86.                   ,value)
  87.              `(format stream
  88.                   "~% ~A~VT  ~S"
  89.                   ,name max-slot-name-length ,value))))
  90.       ;; Figure out a good width for the slot-name column.
  91.       (iterate ((slotd in instance-slots))
  92.     (adjust-slot-name-length (slotd-name slotd)))      
  93.       (iterate ((slotd in non-instance-slots))
  94.     (adjust-slot-name-length (slotd-name slotd)))
  95.       (iterate ((name in dynamic-slots by cddr))
  96.     (adjust-slot-name-length name))
  97.       (setq max-slot-name-length  (min (+ max-slot-name-length 3) 30))
  98.       (format stream "~%~S is an instance of class ~S:" object class)
  99.       (format stream "~% The following slots are allocated in the instance ~
  100.                          (:INSTANCE allocation):")
  101.       (iterate ((slotd in instance-slots))
  102.     (let ((name (slotd-name slotd)))
  103.       (describe-slot name (get-slot object name))))
  104.       (when (or dynamic-slots
  105.         (iterate ((slotd in non-instance-slots))
  106.           (when (neq (slotd-allocation slotd) :dynamic) (return t))))
  107.     (format stream
  108.         "~%The following slots have special allocations as shown:")
  109.     (iterate ((slotd in non-instance-slots))
  110.       (unless (eq (slotd-allocation slotd) :dynamic)
  111.         (describe-slot (slotd-name slotd)
  112.                (get-slot object (slotd-name slotd))
  113.                (slotd-allocation slotd))))
  114.     (iterate ((name in dynamic-slots by cddr)
  115.           (val in (cdr dynamic-slots) by cddr))
  116.       (describe-slot name val :dynamic)))))
  117.   object)
  118.  
  119.  
  120.   ;;   
  121. ;;;;;; 
  122.   ;;   
  123.  
  124. (ndefstruct (structure-metaclass (:class class)
  125.                  (:include class)
  126.                  (:constructor nil)))
  127.  
  128. (defmeth expand-defstruct ((class structure-metaclass)
  129.                name-and-options doc slot-descriptions)
  130.   (ignore class doc)
  131.   (let ((class-argument (iterate ((option in (cdr name-and-options)))
  132.                  (when (and (listp option)
  133.                         (eq (car option) ':class))
  134.                    (return option)))))
  135.     `(defstruct ,(remove class-argument name-and-options)
  136.        . ,slot-descriptions)))
  137.  
  138.  
  139.   ;;   
  140. ;;;;;; 
  141.   ;;   
  142.  
  143. (eval-when (compile load eval)
  144. (ndefstruct (built-in (:class class)
  145.               (:include (class))))
  146.  
  147. (ndefstruct (built-in-with-fast-type-predicate (:class class)
  148.                            (:include (built-in))))
  149.  
  150. (defmacro define-built-in-class (name includes &optional fast-type-predicate)
  151.   `(ndefstruct (,name (:class ,(if fast-type-predicate
  152.                    'built-in-with-fast-type-predicate
  153.                    'built-in))
  154.               (:include ,includes))
  155.      (fast-type-predicate ',fast-type-predicate)  ;;;
  156.  
  157.      ))
  158.  
  159. (defmeth parse-defstruct-options ((class built-in) name options)
  160.   (let ((ds-options (call-next-method)))
  161.     (or (ds-options-includes ds-options)
  162.     (setf (ds-options-includes ds-options) (list 'object)))
  163.     ds-options))
  164.  
  165. (defmeth expand-defstruct-make-definitions ((class built-in)
  166.                         name ds-options slotds)
  167.   (ignore class name ds-options slotds)
  168.   ())
  169.  
  170. (defmeth make-instance ((class built-in))
  171.   (ignore class)
  172.   (error
  173.     "Attempt to make an instance of the built-in class ~S.~%~
  174.      Currently it is not possible to make instance of built-in classes with~
  175.      make.~%~
  176.      A design for this exists, because of metaclasses it is easy to do,~%~
  177.      it just has to be done."
  178.     class))
  179.  
  180. (defmeth compatible-meta-class-change-p
  181.      ((from built-in)
  182.       (to built-in-with-fast-type-predicate))
  183.   (ignore from to)
  184.   t)
  185.  
  186. (defmeth check-super-metaclass-compatibility ((built-in built-in)
  187.                            (new-super class))
  188.   (or (eq new-super (class-named 't))
  189.       (error "~S cannot have ~S as a super.~%~
  190.               The only meta-class CLASS class that a built-in class can~%~
  191.               have as a super is the class T."
  192.          built-in new-super)))
  193.  
  194.  
  195.  
  196. (defmeth check-super-metaclass-compatibility
  197.      ((class built-in)
  198.       (new-local-super built-in))
  199.   (ignore class new-local-super)
  200.   t)
  201.  
  202. ;(defmeth check-super-metaclass-compatibility
  203. ;     ((class built-in-with-fast-type-predicate)
  204. ;      (new-local-super built-in))
  205. ;  (ignore class new-local-super)
  206. ;  t)
  207.  
  208. (defmeth compute-class-precedence-list ((class built-in))
  209.   ;; Compute the class-precedence list just like we do for CLASS except that
  210.   ;; a built-in class cannot inherit COMMON from another built-in class.  But
  211.   ;; it does inherit the things that it would have inherited had it inherited
  212.   ;; common.
  213.   (let ((val (call-next-method))
  214.     (common-class nil))
  215.     (if (not (memq (setq common-class (class-named 'common t))
  216.            (class-local-supers class)))
  217.     (remove common-class val)
  218.     val)))
  219.  
  220.  
  221. )
  222.  
  223.   ;;   
  224. ;;;;;; The built in types 
  225.   ;;   
  226.  
  227. (define-built-in-class common (t))
  228.  
  229. (define-built-in-class pathname (common) pathnamep)
  230.  
  231. (define-built-in-class stream (common) streamp)
  232.  
  233. (define-built-in-class sequence (t))
  234. (define-built-in-class list (sequence) listp)
  235. (define-built-in-class cons (list common) consp)
  236. (define-built-in-class symbol (common) symbolp)
  237. (define-built-in-class null (list symbol) null)
  238.  
  239. (define-built-in-class keyword (symbol common) keywordp)
  240.  
  241. (define-built-in-class array (common) arrayp)
  242. (define-built-in-class vector (sequence array) vectorp)
  243. (define-built-in-class simple-array (array))
  244.  
  245. (define-built-in-class string (vector common) stringp)
  246. (define-built-in-class bit-vector (vector) bit-vector-p)
  247. ;(vector t) should go here
  248.  
  249. (define-built-in-class simple-string (string simple-array) simple-string-p)
  250. (define-built-in-class simple-bit-vector (bit-vector simple-array)
  251.                      simple-bit-vector-p)
  252. (define-built-in-class simple-vector (vector simple-array) simple-vector-p)
  253.  
  254. (define-built-in-class function (t))
  255.  
  256. (define-built-in-class character (t) characterp)
  257. (define-built-in-class string-char (character) string-char-p)
  258. (define-built-in-class standard-char (string-char common) standard-char-p)
  259.  
  260. (define-built-in-class structure (common))
  261.  
  262. (define-built-in-class number (t) numberp)
  263.  
  264. (define-built-in-class rational (number) rationalp)
  265. (define-built-in-class float (number) floatp)
  266. (define-built-in-class complex (number common) complexp)
  267.  
  268. (define-built-in-class integer (rational))
  269. (define-built-in-class ratio   (rational common))
  270.  
  271. (define-built-in-class fixnum (integer common))
  272. (define-built-in-class bignum (integer common))
  273.  
  274. (define-built-in-class short-float  (float common))
  275. (define-built-in-class single-float (float common))
  276. (define-built-in-class double-float (float common))
  277. (define-built-in-class long-float   (float common))
  278.  
  279. (define-built-in-class hash-table (common) hash-table-p)
  280. (define-built-in-class readtable (common) readtablep)
  281. (define-built-in-class package (common) packagep)
  282. (define-built-in-class random-state (common) random-state-p)
  283.  
  284.  
  285. (eval-when (load)
  286.   (setq *error-when-defining-method-on-existing-function* t))
  287.  
  288.