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