mop.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-\r
   2 ;;;; *************************************************************************\r
   3 ;;;; FILE IDENTIFICATION\r
   4 ;;;;\r
   5 ;;;; Name:          mop.lisp\r
   6 ;;;; Purpose:       Metaobject Protocol Interface\r
   7 ;;;; Programmer:    Kevin M. Rosenberg\r
   8 ;;;; Date Started:  Apr 2000\r
   9 ;;;;\r
  10 ;;;; This metaclass as functions to classes to allow display\r
  11 ;;;; in Text, HTML, and XML formats. This includes hyperlinking\r
  12 ;;;; capability and sub-objects.\r
  13 ;;;;\r
  14 ;;;; $Id: mop.lisp,v 1.80 2003/06/25 19:28:31 kevin Exp $\r
  15 ;;;;\r
  16 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg\r
  17 ;;;; *************************************************************************\r
  18  \r
  19 (in-package #:hyperobject)\r
  20 \r
  21 ;; Main class\r
  22 \r
  23 (defclass hyperobject-class (standard-class)\r
  24   ( ;; slots initialized in defclass\r
  25    (user-name :initarg :user-name :type string :initform nil\r
  26               :accessor user-name\r
  27               :documentation "User name for class")\r
  28    (user-name-plural :initarg :user-name-plural :type string :initform nil\r
  29                      :accessor user-name-plural\r
  30                      :documentation "Plural user name for class")\r
  31    (default-print-slots :initarg :default-print-slots :type list :initform nil\r
  32                         :accessor default-print-slots\r
  33                         :documentation "Defaults slots for a view")\r
  34    (description :initarg :description :initform nil\r
  35                 :accessor description\r
  36                 :documentation "Class description")\r
  37    (version :initarg :version :initform nil\r
  38             :accessor version\r
  39             :documentation "Version number for class")\r
  40    (closures :initarg :closures :initform nil\r
  41              :accessor closures\r
  42              :documentation "Closures to call on slot chnages")\r
  43    (sql-name :initarg :sql-name :accessor sql-name :initform nil\r
  44              :documentation "SQL Name for this class")\r
  45    (guid :initarg :guid :accessor guid :initform nil\r
  46          :documentation "ID string for this class")\r
  47 \r
  48    ;;; The remainder of these fields are calculated one time\r
  49    ;;; in finalize-inheritence.\r
  50    \r
  51    (subobjects :initform nil :accessor subobjects\r
  52                :documentation\r
  53                "List of fields that contain a list of subobjects objects.")\r
  54    (hyperlinks :type list :initform nil :accessor hyperlinks\r
  55                :documentation "List of fields that have hyperlinks")\r
  56    (direct-rules :type list :initform nil :initarg :direct-rules\r
  57                  :accessor direct-rules\r
  58                  :documentation "List of rules to fire on slot changes.")\r
  59    (class-id :type integer :initform nil\r
  60              :accessor class-id\r
  61              :documentation "Unique ID for the class")\r
  62    (default-view :initform nil :initarg :default-view :accessor default-view\r
  63                  :documentation "The default view for a class")\r
  64 \r
  65    ;; SQL commands\r
  66    (create-table-cmd :initform nil :reader create-table-cmd)\r
  67    (create-indices-cmds :initform nil :reader create-index-cmds)\r
  68    (drop-table-cmd :initform nil :reader drop-table-cmd)\r
  69 \r
  70    (views :type list :initform nil :initarg :views :accessor views\r
  71           :documentation "List of views")\r
  72    (rules :type list :initform nil :initarg :rules :accessor rules\r
  73           :documentation "List of rules")\r
  74    )\r
  75   (:documentation "Metaclass for Markup Language classes."))\r
  76 \r
  77 (defclass subobject ()\r
  78   ((name-class :type symbol :initform nil :initarg :name-class :reader name-class)\r
  79    (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot)\r
  80    (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup)\r
  81    (lookup-keys :type list :initform nil :initarg :lookup-keys\r
  82                 :reader lookup-keys))\r
  83   (:documentation "Contains subobject information"))\r
  84 \r
  85 \r
  86 (defmethod print-object ((obj subobject) (s stream))\r
  87   (print-unreadable-object (obj s :type t)\r
  88     (format s "~S" (name-slot obj))))\r
  89 \r
  90 (defclass hyperlink ()\r
  91   ((name :type symbol :initform nil :initarg :name :reader name)\r
  92    (lookup\r
  93     ;; The type specifier seems to break sbcl\r
  94     :type (or function symbol)\r
  95     ;;    :type t\r
  96     :initform nil :initarg :lookup :reader lookup)\r
  97    (link-parameters :type list :initform nil :initarg :link-parameters\r
  98                     :reader link-parameters)))\r
  99 \r
 100 (defmethod print-object ((obj hyperlink) (s stream))\r
 101   (print-unreadable-object (obj s :type t :identity t)\r
 102     (format s "~S" (name obj))))\r
 103 \r
 104 (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class))\r
 105   t)\r
 106 \r
 107 (defmethod finalize-inheritance :after ((cl hyperobject-class))\r
 108   (init-hyperobject-class cl)\r
 109   )\r
 110 \r
 111 (eval-when (:compile-toplevel :load-toplevel :execute)\r
 112   (when (>= (length (generic-function-lambda-list\r
 113                      (ensure-generic-function\r
 114                       'compute-effective-slot-definition)))\r
 115             3)\r
 116     (pushnew :ho-normal-cesd cl:*features*))\r
 117   \r
 118     (when (>= (length (generic-function-lambda-list\r
 119                        (ensure-generic-function\r
 120                         'direct-slot-definition-class)))\r
 121             3)\r
 122       (pushnew :ho-normal-dsdc cl:*features*))\r
 123     \r
 124     (when (>= (length (generic-function-lambda-list\r
 125                        (ensure-generic-function\r
 126                         'effective-slot-definition-class)))\r
 127               3)\r
 128       (pushnew :ho-normal-esdc cl:*features*)))\r
 129 \r
 130 ;; Slot definitions\r
 131 (defmethod direct-slot-definition-class ((cl hyperobject-class)\r
 132                                          #+ho-normal-dsdc &rest iargs)\r
 133   (find-class 'hyperobject-dsd))\r
 134 \r
 135 (defmethod effective-slot-definition-class ((cl hyperobject-class) \r
 136                                             #+ho-normal-esdc &rest iargs)\r
 137   (find-class 'hyperobject-esd))\r
 138 \r
 139 \r
 140 ;;; Slot definitions\r
 141 \r
 142 (eval-when (:compile-toplevel :load-toplevel :execute)\r
 143   (defmacro process-class-option (slot-name &optional required)\r
 144     #+lispworks\r
 145     `(defmethod clos:process-a-class-option ((class hyperobject-class)\r
 146                                              (name (eql ,slot-name))\r
 147                                              value)\r
 148       (when (and ,required (null value))\r
 149         (error "hyperobject class slot ~A must have a value" name))\r
 150       (list name `',value))\r
 151     #+(or allegro sbcl cmu scl openmcl)\r
 152     (declare (ignore slot-name required))\r
 153     )\r
 154 \r
 155   (defmacro process-slot-option (slot-name)\r
 156     #+lispworks\r
 157     `(defmethod clos:process-a-slot-option ((class hyperobject-class)\r
 158                                             (option (eql ,slot-name))\r
 159                                             value\r
 160                                             already-processed-options\r
 161                                             slot)\r
 162       (list* option `',value already-processed-options))\r
 163     #-lispworks\r
 164     (declare (ignore slot-name))\r
 165     )\r
 166   \r
 167   (dolist (option *class-options*)\r
 168     (eval `(process-class-option ,option)))\r
 169   (dolist (option *slot-options*)\r
 170     (eval `(process-slot-option ,option)))\r
 171 \r
 172   (eval\r
 173    `(defclass hyperobject-dsd (standard-direct-slot-definition)\r
 174      (,@(mapcar #'(lambda (x)\r
 175                     `(,(intern (symbol-name x))\r
 176                       :initform nil))\r
 177                 *slot-options-no-initarg*)\r
 178       ,@(mapcar #'(lambda (x)\r
 179                     `(,(intern (symbol-name x))\r
 180                       :initarg\r
 181                       ,(intern (symbol-name x) (symbol-name :keyword))\r
 182                       :initform nil\r
 183                       :accessor\r
 184                       ,(intern (concatenate 'string\r
 185                                             (symbol-name :dsd-)\r
 186                                             (symbol-name x)))))\r
 187                 *slot-options*))))\r
 188   (eval\r
 189    `(defclass hyperobject-esd (standard-effective-slot-definition)\r
 190      (,@(mapcar #'(lambda (x)\r
 191                     `(,(intern (symbol-name x))\r
 192                       :initarg\r
 193                       ,(intern (symbol-name x) (symbol-name :keyword))\r
 194                       :initform nil\r
 195                       :accessor\r
 196                       ,(intern (concatenate 'string\r
 197                                             (symbol-name :esd-)\r
 198                                             (symbol-name x)))))\r
 199                 (append *slot-options* *slot-options-no-initarg*)))))\r
 200   ) ;; eval-when\r
 201 \r
 202 (defun intern-in-keyword (obj)\r
 203   (cond\r
 204     ((null obj)\r
 205      nil)\r
 206     ((eq t obj)\r
 207      t)\r
 208     ((atom obj)\r
 209      (intern (symbol-name obj) (find-package 'keyword)))\r
 210     ((consp obj)\r
 211      (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))\r
 212     (t\r
 213      obj)))\r
 214 \r
 215 (defun canonicalize-value-type (vt)\r
 216   (typecase vt\r
 217     (atom\r
 218      (ensure-keyword vt))\r
 219     (cons\r
 220      (list (ensure-keyword (car vt)) (cadr vt)))\r
 221     (t\r
 222      t)))\r
 223 \r
 224 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class)\r
 225                                                       #+ho-normal-cesd name\r
 226                                                       dsds)\r
 227   #+ho-normal-cesd (declare (ignore name))\r
 228   (let* ((esd (call-next-method))\r
 229          (dsd (car dsds))\r
 230          (value-type (canonicalize-value-type (slot-value dsd 'value-type))))\r
 231     (multiple-value-bind (sql-type sql-length) \r
 232         (value-type-to-sql-type value-type)\r
 233       (setf (slot-value esd 'sql-type) sql-type)\r
 234       (setf (slot-value esd 'sql-length) sql-length))\r
 235     (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))\r
 236     (setf (slot-value esd 'value-type) value-type)\r
 237     (setf (slot-value esd 'user-name)\r
 238       (aif (slot-value dsd 'user-name)\r
 239            it\r
 240            (string-downcase (symbol-name (slot-definition-name dsd)))))\r
 241     (setf (slot-value esd 'sql-name)\r
 242       (aif (slot-value dsd 'sql-name)\r
 243            it\r
 244            (lisp-name-to-sql-name (slot-definition-name dsd))))\r
 245     (setf (slot-value esd 'sql-name)\r
 246       (aif (slot-value dsd 'sql-name)\r
 247            it\r
 248            (lisp-name-to-sql-name (slot-definition-name dsd))))\r
 249     (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters\r
 250                     description value-constraint indexed null-allowed\r
 251                     unique short-description void-text read-only-groups\r
 252                     hidden-groups unit disable-predicate view-type\r
 253                     list-of-values stored))\r
 254       (setf (slot-value esd name) (slot-value dsd name)))\r
 255     esd))\r
 256 \r
 257 (defun lisp-name-to-sql-name (lisp)\r
 258   "Convert a lisp name (atom or list, string or symbol) into a canonical\r
 259 SQL name"\r
 260   (unless (stringp lisp)\r
 261     (setq lisp\r
 262           (typecase lisp\r
 263             (symbol (symbol-name lisp))\r
 264             (t (write-to-string lisp)))))\r
 265   (do* ((len (length lisp))\r
 266         (sql (make-string len))\r
 267         (i 0 (1+ i)))\r
 268       ((= i len) (string-upcase sql))\r
 269     (declare (fixnum i)\r
 270              (simple-string sql))\r
 271     (setf (schar sql i)\r
 272           (let ((c (char lisp i)))\r
 273             (case c\r
 274               ((#\- #\$ #\+ #\#) #\_)\r
 275               (otherwise c))))))\r
 276 \r
 277 #+ho-normal-cesd\r
 278 (setq cl:*features* (delete :ho-normal-cesd cl:*features*))\r
 279 #+ho-normal-dsdc\r
 280 (setq cl:*features* (delete :ho-normal-dsdc cl:*features*))\r
 281 #+ho-normal-esdc\r
 282 (setq cl:*features* (delete :ho-normal-esdc cl:*features*))\r
 283 \r
 284 (defun lisp-type-is-a-string (type)\r
 285   (or (eq type 'string)\r
 286       (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))\r
 287 \r
 288 (defun base-value-type (value-type)\r
 289   (if (atom value-type)\r
 290       value-type\r
 291     (car value-type)))\r
 292 \r
 293 (defun value-type-to-lisp-type (value-type)\r
 294   (case (base-value-type value-type)\r
 295     ((:string :cdata :varchar :char)\r
 296      '(or null string))\r
 297     (:character\r
 298      '(or null character))\r
 299     (:fixnum\r
 300      '(or null fixnum))\r
 301     (:boolean\r
 302      '(or null boolean))\r
 303     ((:integer :long-integer)\r
 304      '(or null integer))\r
 305     ((:float :single-float)\r
 306      '(or null single-float))\r
 307     (:double-float\r
 308      '(or null double-float))\r
 309     (otherwise\r
 310      t)))\r
 311 \r
 312 (defun value-type-to-sql-type (value-type)\r
 313   "Return two values, the sql type and field length."\r
 314   (let ((type (base-value-type value-type))\r
 315         (length (when (consp value-type)\r
 316                   (cadr value-type))))\r
 317     (values\r
 318      (case type\r
 319        ((:char :character)\r
 320         :char)\r
 321        (:varchar\r
 322         :varchar)\r
 323        ((:fixnum :integer)\r
 324         :integer)\r
 325        (:long-integer\r
 326         :long-integer)\r
 327        (:boolean\r
 328         :boolean)\r
 329        ((:float :single-float)\r
 330         :single-float)\r
 331        (:double-float\r
 332         :double-float)\r
 333        (otherwise\r
 334         :text))\r
 335      length)))\r
 336 \r
 337 ;;;; Class initialization function\r
 338 \r
 339 ;; defines a slot-unbound method for class and slot-name, fills\r
 340 ;; the slot by calling reader function with the slot values of\r
 341 ;; the instance's reader-keys\r
 342 (defmacro def-lazy-reader (class slot-name reader &rest reader-keys)\r
 343   (let* ((the-slot-name (gensym))\r
 344          (the-class (gensym))\r
 345          (the-instance (gensym))\r
 346          (keys '()))\r
 347     (dolist (key reader-keys)\r
 348       (push (list 'slot-value the-instance (list 'quote key)) keys))\r
 349     (setq keys (nreverse keys))\r
 350     `(defmethod slot-unbound (,the-class (,the-instance ,class)\r
 351                               (,the-slot-name (eql ',slot-name)))\r
 352       (declare (ignore ,the-class))\r
 353       (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys)))))\r
 354 \r
 355 \r
 356 #+lispworks\r
 357 (defun intern-eql-specializer (slot)\r
 358   `(eql ,slot))\r
 359 \r
 360 #+(or sbcl cmu lispworks)\r
 361 (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)\r
 362   (let ((keys nil)\r
 363         (gf (ensure-generic-function 'slot-unbound)))\r
 364     (dolist (key reader-keys)\r
 365       (push (list 'slot-value 'the-instance (list 'quote key)) keys))\r
 366     (setq keys (nreverse keys))\r
 367     (multiple-value-bind (method-lambda init-args-values)\r
 368         (make-method-lambda\r
 369          gf\r
 370          (class-prototype (generic-function-method-class gf))\r
 371          #-lispworks\r
 372          `(lambda (the-class the-instance the-slot-name)\r
 373            (declare (ignore the-class))\r
 374            (setf (slot-value the-instance the-slot-name) (,reader ,@keys)))\r
 375          #+lispworks\r
 376          '(the-class the-instance the-slot-name)\r
 377          #+lispworks\r
 378          nil\r
 379          #+lispworks\r
 380          `(setf (slot-value the-instance the-slot-name) (,reader ,@keys))\r
 381          nil)\r
 382       (add-method gf\r
 383                   (apply\r
 384                    #'make-instance (generic-function-method-class gf)\r
 385                    ':specializers (list (class-of (find-class class-name))\r
 386                                         (find-class class-name)\r
 387                                         (intern-eql-specializer slot-name))\r
 388                    ':lambda-list '(the-class the-instance the-slot-name)\r
 389                    ':function (compile nil method-lambda)\r
 390                    init-args-values)))))\r
 391 \r
 392 #+(or allegro scl openmcl)\r
 393 (progn\r
 394   ;; One entry for each class with lazy readers defined.  The value is a plist mapping\r
 395   ;; slot-name to a lazy reader, each of which is a list of a function and slot-names.\r
 396   (defvar *lazy-readers* (make-hash-table))\r
 397 \r
 398 (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name)\r
 399   (let ((lazy-reader (loop for super in (class-precedence-list class)\r
 400                            as lazy-reader = (getf (gethash super *lazy-readers*) slot-name)\r
 401                            when lazy-reader return it)))\r
 402     (if lazy-reader\r
 403         (setf (slot-value instance slot-name)\r
 404               (apply (car lazy-reader)\r
 405                      (loop for arg-slot-name in (cdr lazy-reader)\r
 406                            collect (slot-value instance arg-slot-name))))\r
 407         ;; No lazy reader -- defer to regular slot-unbound handling.\r
 408         (call-next-method))))\r
 409 \r
 410   ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to\r
 411   ;; the result of applying the function to the slot-values of those slots, and that value\r
 412   ;; is also returned.\r
 413   (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys)\r
 414     (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
 415           (list* reader (copy-list reader-keys))))\r
 416 \r
 417   (defun remove-lazy-reader (class-name slot-name)\r
 418     (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name)\r
 419           nil))\r
 420   \r
 421   ) ;; #+(or allegro sc openmcll)\r
 422 \r
 423 \r
 424 (defun finalize-subobjects (cl)\r
 425   "Process class subobjects slot"\r
 426   (setf (subobjects cl)\r
 427         (let ((subobjects '()))\r
 428           (dolist (slot (class-slots cl))\r
 429             (let-when\r
 430              (subobj-def (esd-subobject slot))\r
 431              (let ((subobject\r
 432                     (make-instance 'subobject\r
 433                                    :name-class (class-name cl)\r
 434                                    :name-slot (slot-definition-name slot)\r
 435                                    :lookup (if (atom subobj-def)\r
 436                                                subobj-def\r
 437                                                (car subobj-def))\r
 438                                    :lookup-keys (if (atom subobj-def)\r
 439                                                     nil\r
 440                                                     (cdr subobj-def)))))\r
 441                (unless (eq (lookup subobject) t)\r
 442                  #+ignore ;; #-(or sbcl cmu lispworks)\r
 443                  (eval\r
 444                   `(hyperobject::def-lazy-reader ,(name-class subobject)\r
 445                     ,(name-slot subobject) ,(lookup subobject)\r
 446                     ,@(lookup-keys subobject)))\r
 447                  #+(or sbcl cmu lispworks allegro scl openmcl)\r
 448                  (apply #'ensure-lazy-reader \r
 449                         (name-class subobject) (name-slot subobject)\r
 450                         (lookup subobject) (lookup-keys subobject)))\r
 451                (push subobject subobjects))))\r
 452           ;; sbcl/cmu reverse class-slots compared to the defclass form\r
 453           ;; so re-reverse on cmu/sbcl\r
 454           #+(or cmu sbcl) subobjects\r
 455           #-(or cmu sbcl) (nreverse subobjects)\r
 456           )))\r
 457 \r
 458 \r
 459 (defun finalize-class-slots (cl)\r
 460   "Make sure all class slots have an expected value"\r
 461   (unless (user-name cl)\r
 462     (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))\r
 463   \r
 464   (setf (user-name-plural cl)\r
 465         (if (and (consp (user-name cl)) (cadr (user-name cl)))\r
 466             (cadr (user-name cl))\r
 467             (format nil "~A~P" (if (consp (user-name cl))\r
 468                                    (car (user-name cl))\r
 469                                    (user-name cl))\r
 470                     2)))\r
 471 \r
 472   (dolist (name '(user-name description version guid sql-name))\r
 473     (awhen (slot-value cl name)\r
 474            (setf (slot-value cl name)\r
 475                  (etypecase (slot-value cl name)\r
 476                    (cons (car it))\r
 477                    ((or string symbol) it)))))\r
 478   \r
 479   (unless (sql-name cl)\r
 480     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))\r
 481   )\r
 482 \r
 483 (defun finalize-documentation (cl)\r
 484   "Calculate class documentation slot"\r
 485   (let ((*print-circle* nil))\r
 486     (setf (documentation (class-name cl) 'class)\r
 487           (format nil "Hyperobject~A~A~A~A"\r
 488                   (aif (user-name cl)\r
 489                        (format nil ": ~A" it ""))\r
 490                   (aif (description cl)\r
 491                        (format nil "~%Class description: ~A" it) "")\r
 492                   (aif (subobjects cl)\r
 493                        (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")\r
 494                   (aif (default-print-slots cl)\r
 495                        (format nil "~%Default print slots:~{ ~A~}" it) "")\r
 496                   ))))\r
 497 \r
 498 (defun finalize-hyperlinks (cl)\r
 499   (let ((hyperlinks '()))\r
 500     (dolist (esd (class-slots cl))\r
 501       (awhen (slot-value esd 'hyperlink)\r
 502              (push\r
 503               (make-instance 'hyperlink\r
 504                              :name (slot-definition-name esd)\r
 505                              :lookup it\r
 506                              :link-parameters (slot-value esd 'hyperlink-parameters))\r
 507               hyperlinks)))\r
 508     ;; cmu/sbcl reverse class-slots compared to the defclass form\r
 509     ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu\r
 510     #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks))\r
 511     (setf (slot-value cl 'hyperlinks) hyperlinks)))\r
 512 \r
 513 (defun init-hyperobject-class (cl)\r
 514   "Initialize a hyperobject class. Calculates all class slots"\r
 515   (finalize-subobjects cl)\r
 516   (finalize-views cl)\r
 517   (finalize-hyperlinks cl)\r
 518   (finalize-sql cl)\r
 519   (finalize-rules cl)\r
 520   (finalize-class-slots cl)\r
 521   (finalize-documentation cl))\r
 522 \r
 523 \r
 524 ;;;; *************************************************************************\r
 525 ;;;;  Metaclass Slot Accessors\r
 526 ;;;; *************************************************************************\r
 527 \r
 528 (defun find-slot-by-name (cl name)\r
 529   (find name (class-slots cl) :key #'slot-definition-name))\r
 530 \r
 531 (defun hyperobject-class-user-name (obj)\r
 532   (user-name (class-of obj)))\r
 533 \r
 534 (defun hyperobject-class-user-name-plural (obj)\r
 535   (user-name-plural (class-of obj)))\r
 536 \r
 537 (defun hyperobject-class-subobjects (obj)\r
 538   (subobjects (class-of obj)))\r
 539 \r
 540 (defun hyperobject-class-hyperlinks (obj)\r
 541   (hyperlinks (class-of obj)))\r
 542 \r
 543 (defun hyperobject-class-slots (obj)\r
 544   ;; cmucl/sbcl reverse class-slots\r
 545   #+(or cmu sbcl) (reverse (class-slots (class-of obj)))\r
 546   #-(or cmu sbcl) (class-slots (class-of obj)))\r
 547 \r
 548 (defun all-subobjects (obj)\r
 549   "Returns a list of all subobjects in an object"\r
 550   (let ((so-list '()))\r
 551     (dolist (subobj-obj (subobjects (class-of obj)) (nreverse so-list))\r
 552       (dolist (so (funcall (name-slot subobj-obj) obj))\r
 553         (push so so-list)))))\r