home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cl-support / cl-structs.lisp < prev    next >
Encoding:
Text File  |  1994-09-27  |  21.4 KB  |  139 lines  |  [TEXT/CCL2]
  1. ;;; cl-structs.lisp -- extended structure definitions
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  19 Aug 1992
  5. ;;;
  6.  
  7.  
  8. ;;;====================================================================
  9. ;;; Basic structure types
  10. ;;;====================================================================
  11.  
  12.  
  13. ;;; Use this hash table for mapping names -> type descriptors
  14.  
  15. (defvar *struct-lookup-table* (make-hash-table :test #'eq))
  16.  
  17. (defmacro lookup-type (name)
  18.   `(gethash ,name *struct-lookup-table*))
  19.  
  20.  
  21. ;;; Do NOT add or remove slots from these DEFSTRUCTS without also
  22. ;;; changing the bootstrap code below!!!
  23. ;;; Do NOT try to give these structs complicated defaulting behavior!!!
  24.  
  25. ;;; All of our objects are subtypes of STRUCT.
  26.  
  27.  
  28. (mumble::predefine (mumble::write object . maybe-stream))
  29.  
  30. (defun print-struct-object (object stream depth)
  31.   (declare (ignore depth))
  32.   (mumble::write object stream)
  33. ;  (format stream "#<Struct ~a>" (td-name (struct-type-descriptor object)))
  34.   )
  35.  
  36.  
  37. ;;; Note that non-exported slots are prefixed with % to prevent
  38. ;;; accidental slot name collisions.
  39.  
  40. (defstruct (struct
  41.          (:print-function print-struct-object)
  42.          (:predicate      struct?)
  43.          (:constructor    nil)   ; never instantiated directly
  44.          (:copier         nil))
  45.   (type-descriptor nil :type t)
  46.   (%bits 0 :type fixnum)
  47.   )
  48.  
  49.  
  50. (defstruct (type-descriptor
  51.          (:include struct
  52.                (type-descriptor (lookup-type 'type-descriptor)))
  53.          (:conc-name td-)
  54.          (:constructor create-type-descriptor ())
  55.          (:predicate nil)
  56.          (:copier nil))
  57.   (name nil :type symbol)
  58.   (slots nil :type list)         ; all slots, including inherited
  59.   (parent-type nil :type t)
  60.   (printer nil :type t)
  61.   (%local-slots nil :type list)   ; "real" structure slots
  62.   (%bits-used 0 :type fixnum)
  63.   (%constructor nil :type symbol)
  64.   )
  65.  
  66. (defstruct (slot-descriptor
  67.          (:include struct
  68.                (type-descriptor (lookup-type 'slot-descriptor)))
  69.          (:conc-name sd-)
  70.          (:constructor create-slot-descriptor ())
  71.          (:predicate nil)
  72.          (:copier nil))
  73.   (name nil :type symbol)
  74.   (type nil :type t)
  75.   (default nil :type t)
  76.   (getter nil :type symbol)
  77.   (%bit nil :type (mumble::maybe fixnum))
  78.   (%read-only? nil :type mumble::bool)
  79.   (%required? nil :type mumble::bool)
  80.   (%uninitialized? nil :type mumble::bool))
  81.  
  82.  
  83. ;;; Helper function for bootstrapping.
  84.  
  85. (defun create-slot-simple (prefix name type default
  86.                 &optional read-only? required? uninitialized?)
  87.   (let ((sd  (create-slot-descriptor)))
  88.     (setf (sd-name sd) name)
  89.     (setf (sd-type sd) type)
  90.     (setf (sd-default sd) default)
  91.     (setf (sd-getter sd) (symbol-append prefix name))
  92.     (setf (sd-%read-only? sd) read-only?)
  93.     (setf (sd-%required? sd) required?)
  94.     (setf (sd-%uninitialized? sd) uninitialized?)
  95.     sd))
  96.  
  97.  
  98. ;;; Initialize descriptors for the predefined struct types.
  99.  
  100. (let ((struct-td  (setf (lookup-type 'struct)
  101.             (create-type-descriptor)))
  102.       (type-td    (setf (lookup-type 'type-descriptor)
  103.             (create-type-descriptor)))
  104.       (slot-td    (setf (lookup-type 'slot-descriptor)
  105.             (create-type-descriptor))))
  106.   ;; struct
  107.   (setf (td-type-descriptor struct-td) type-td)
  108.   (setf (td-name struct-td) 'struct)
  109.   (setf (td-%bits-used struct-td) 0)
  110.   ;; type-descriptor
  111.   (setf (td-type-descriptor type-td) type-td)
  112.   (setf (td-name type-td) 'type-descriptor)
  113.   (setf (td-%local-slots type-td)
  114.     (list (create-slot-simple 'td- 'name 'symbol nil)
  115.           (create-slot-simple 'td- 'slots 'list nil)
  116.           (create-slot-simple 'td- 'parent-type 't nil)
  117.           (create-slot-simple 'td- 'printer 't nil)
  118.           (create-slot-simple 'td- '%local-slots 'list nil)
  119.           (create-slot-simple 'td- '%bits-used 'fixnum 0)
  120.           (create-slot-simple 'td- '%constructor 'symbol nil)
  121.           ))
  122.   (setf (td-slots type-td) (td-%local-slots type-td))
  123.   (setf (td-%bits-used type-td) 0)
  124.   (setf (td-%constructor type-td) 'create-type-descriptor)
  125.   (setf (td-parent-type type-td) struct-td)
  126.   ;; slot-descriptor
  127.   (setf (td-type-descriptor slot-td) type-td)
  128.   (setf (td-name slot-td) 'slot-descriptor)
  129.   (setf (td-%local-slots slot-td)
  130.     (list (create-slot-simple 'sd- 'name 'symbol nil)
  131.           (create-slot-simple 'sd- 'type 't nil)
  132.           (create-slot-simple 'sd- 'default 't nil)
  133.           (create-slot-simple 'sd- 'getter 'symbol nil)
  134.           (create-slot-simple 'sd- '%bit '(mumble::maybe fixnum) nil)
  135.           (create-slot-simple 'sd- '%read-only? 'mumble::bool nil)
  136.           (create-slot-simple 'sd- '%required? 'mumble::bool nil)
  137.           (create-slot-simple 'sd- '%uninitialized? 'mumble::bool nil)
  138.           ))
  139.   (setf (td-slots slot-td) (td-%local-slots slot-td)