| 1 | (declaim (optimize (speed 2) (space 3) (safety 0))) |
| 2 | |
| 3 | (in-package :lisp-on-lines) |
| 4 | |
| 5 | (defparameter *default-type* :ucw) |
| 6 | |
| 7 | ;;;; I think these are unused now |
| 8 | (defmethod perform-set-attributes ((occurence-name t) definitions) |
| 9 | (dolist (def definitions) |
| 10 | (funcall #'set-attribute occurence-name (first def) (rest def)))) |
| 11 | |
| 12 | (defmethod perform-set-attribute-properties ((occurence-name t) definitions) |
| 13 | (dolist (def definitions) |
| 14 | (funcall #'set-attribute-properties occurence-name (car def) (cdr def)))) |
| 15 | |
| 16 | ;;;; PLIST Utilities. |
| 17 | |
| 18 | (defun plist-nunion (new-props plist) |
| 19 | "Destructive Merge of plists. PLIST is modified and returned. |
| 20 | NEW-PROPS is merged into PLIST such that any properties |
| 21 | in both PLIST and NEW-PROPS get the value in NEW-PROPS. |
| 22 | The other properties in PLIST are left untouched." |
| 23 | (loop for cons on new-props by #'cddr |
| 24 | do (setf (getf plist (first cons)) (second cons)) |
| 25 | finally (return plist)) |
| 26 | plist) |
| 27 | |
| 28 | (defun plist-union (new-props plist) |
| 29 | "Non-destructive version of plist-nunion" |
| 30 | (plist-nunion new-props (copy-list plist))) |
| 31 | |
| 32 | |
| 33 | ;;;; * Occurences |
| 34 | |
| 35 | (defvar *occurence-map* (make-hash-table) |
| 36 | "Presentations are created by associating an 'occurence' |
| 37 | with an instance of a class. This is usually keyed off class-name, |
| 38 | although an arbitrary occurence can be used with an arbitrary class.") |
| 39 | |
| 40 | (define-layered-class |
| 41 | standard-occurence () |
| 42 | ((attribute-map :accessor attribute-map :initform (make-hash-table))) |
| 43 | (:documentation |
| 44 | "an occurence holds the attributes like a class holds slot-definitions. |
| 45 | Attributes are the metadata used to display, validate, and otherwise manipulate actual values stored in lisp objects.")) |
| 46 | |
| 47 | (defun find-or-create-occurence (name) |
| 48 | "Returns the occurence associated with this name." |
| 49 | (let ((occurence (gethash name *occurence-map*))) |
| 50 | (if occurence |
| 51 | occurence |
| 52 | (let ((new-occurence (make-instance 'standard-occurence))) |
| 53 | (setf (gethash name *occurence-map*) new-occurence) |
| 54 | new-occurence)))) |
| 55 | |
| 56 | (defun clear-occurence (occurence) |
| 57 | "removes all attributes from the occurence" |
| 58 | (setf (attribute-map occurence) (make-hash-table))) |
| 59 | |
| 60 | (defgeneric find-occurence (name) |
| 61 | (:method (thing) |
| 62 | nil) |
| 63 | (:method ((name symbol)) |
| 64 | (find-or-create-occurence name)) |
| 65 | (:method ((instance standard-object)) |
| 66 | (find-or-create-occurence (class-name (class-of instance))))) |
| 67 | |
| 68 | |
| 69 | ;;;; * Attributes |
| 70 | |
| 71 | (define-layered-class |
| 72 | standard-attribute () |
| 73 | ((name :layered-accessor attribute.name :initarg :name :initform "attribute") |
| 74 | (type :layered-accessor attribute.type :initarg :type :initform t :type symbol) |
| 75 | (properties :layered-accessor attribute.properties :initarg :properties :initform nil)) |
| 76 | (:documentation "Attributes are used to display a part of a thing, such as a slot of an object, a text label, the car of a list, etc.")) |
| 77 | |
| 78 | (defmacro defattribute (name supers slots &rest args) |
| 79 | (let ((type (or (second (assoc :type-name args)) name)) |
| 80 | (properties (cdr (assoc :default-properties args)))) |
| 81 | `(progn |
| 82 | |
| 83 | (define-layered-class |
| 84 | ;;;; TODO: fix the naive way of making sure s-a is a superclass |
| 85 | ,name ,(or supers '(standard-attribute)) |
| 86 | ,slots |
| 87 | #+ (or) ,@ (cdr args) |
| 88 | (:default-initargs :properties (list ,@properties))) |
| 89 | (defmethod find-attribute-class-for-type ((type (eql ',type))) |
| 90 | ',name)))) |
| 91 | |
| 92 | (defmethod print-object ((self standard-attribute) stream) |
| 93 | (print-unreadable-object (self stream :type t) |
| 94 | (with-slots (name type) self |
| 95 | (format stream "~A ~A" name type)))) |
| 96 | |
| 97 | (define-layered-class |
| 98 | presentation-attribute (standard-attribute) |
| 99 | () |
| 100 | (:documentation "Presentation Attributes are used to display objects |
| 101 | using the attributes defined in an occurence. Presentation Attributes are always named using keywords.")) |
| 102 | |
| 103 | (defun clear-attributes (name) |
| 104 | "removes all attributes from an occurance" |
| 105 | (clear-occurence (find-occurence name))) |
| 106 | |
| 107 | (defmethod find-attribute-class-for-type (type) |
| 108 | nil) |
| 109 | |
| 110 | (defmethod find-attribute-class-for-name (name) |
| 111 | "presentation attributes are named using keywords" |
| 112 | (if (keywordp name) |
| 113 | 'presentation-attribute |
| 114 | 'standard-attribute)) |
| 115 | |
| 116 | (defun make-attribute (&key name type properties) |
| 117 | (let ((i (make-instance (or (find-attribute-class-for-type type) |
| 118 | (find-attribute-class-for-name name)) |
| 119 | :name name :type type))) |
| 120 | (setf (attribute.properties i) |
| 121 | (plist-union properties (attribute.properties i))) |
| 122 | i)) |
| 123 | |
| 124 | (defmethod ensure-attribute ((occurence standard-occurence) name type properties) |
| 125 | "Creates an attribute in the given occurence" |
| 126 | (setf (gethash name (attribute-map occurence)) |
| 127 | (make-attribute :name name :type type :properties properties))) |
| 128 | |
| 129 | (defmethod find-attribute ((occurence standard-occurence) name) |
| 130 | (gethash name (attribute-map occurence))) |
| 131 | |
| 132 | (defmethod find-all-attributes ((occurence standard-occurence)) |
| 133 | (loop for att being the hash-values of (attribute-map occurence) |
| 134 | collect att)) |
| 135 | |
| 136 | (defmethod ensure-attribute (occurence-name name type properties) |
| 137 | (ensure-attribute |
| 138 | (find-occurence occurence-name) |
| 139 | name |
| 140 | type |
| 141 | properties)) |
| 142 | |
| 143 | ;;;; The following functions make up the public interface to the |
| 144 | ;;;; MEWA Attribute Occurence system. |
| 145 | |
| 146 | (defmethod find-all-attributes (occurence-name) |
| 147 | (find-all-attributes (find-occurence occurence-name))) |
| 148 | |
| 149 | (defmethod find-attribute (occurence-name attribute-name) |
| 150 | "Returns the ATTRIBUTE named by ATTRIBUTE-NAME in OCCURANCE-name" |
| 151 | (find-attribute (find-occurence occurence-name) attribute-name)) |
| 152 | |
| 153 | (defmethod (setf find-attribute) ((def list) occurence-name attribute-name) |
| 154 | (ensure-attribute occurence-name attribute-name (first def) (rest def))) |
| 155 | |
| 156 | (defmethod set-attribute (occurence-name attribute-name definition &key (inherit t)) |
| 157 | (let ((att (find-attribute occurence-name attribute-name))) |
| 158 | (setf (find-attribute occurence-name attribute-name) |
| 159 | (if (and att inherit) |
| 160 | (cons (car definition) |
| 161 | (plist-union (cdr definition) |
| 162 | (attribute.properties att))) |
| 163 | definition)))) |
| 164 | |
| 165 | (defmethod set-attribute-properties ((occurence-name t) attribute properties) |
| 166 | (let ((a (find-attribute occurence-name attribute))) |
| 167 | (if a |
| 168 | (setf (attribute.properties a) (plist-nunion properties (attribute.properties a))) |
| 169 | (error "Attribute ~A does not exist" attribute)))) |
| 170 | |
| 171 | (defmethod perform-define-attributes ((occurence-name t) attributes) |
| 172 | (loop for attribute in attributes |
| 173 | do (destructuring-bind (name type &rest args) |
| 174 | attribute |
| 175 | (cond ((eq type t) |
| 176 | ;;use the existing (default) type |
| 177 | (set-attribute-properties occurence-name name args)) |
| 178 | ((not (null type)) |
| 179 | ;;set the type as well |
| 180 | (set-attribute occurence-name name (cons type args))))))) |
| 181 | |
| 182 | (defmacro define-attributes (occurence-names &body attribute-definitions) |
| 183 | `(progn |
| 184 | ,@(loop for occurence-name in occurence-names |
| 185 | collect `(perform-define-attributes (quote ,occurence-name) (quote ,attribute-definitions))))) |
| 186 | |
| 187 | |
| 188 | (defmethod setter (attribute) |
| 189 | (warn "Setting ~A in ~A" attribute *context*) |
| 190 | (let ((setter (getf (attribute.properties attribute) :setter)) |
| 191 | (slot-name (getf (attribute.properties attribute) :slot-name))) |
| 192 | (cond (setter |
| 193 | setter) |
| 194 | (slot-name |
| 195 | #'(lambda (value object) |
| 196 | (setf (slot-value object slot-name) value))) |
| 197 | (t |
| 198 | #'(lambda (value object) |
| 199 | (warn "Can't find anywere to set ~A in ~A using ~A" value object attribute)))))) |
| 200 | |
| 201 | (defmethod getter (attribute) |
| 202 | (let ((getter (getf (attribute.properties attribute) :getter)) |
| 203 | (slot-name (getf (attribute.properties attribute) :slot-name))) |
| 204 | (cond (getter |
| 205 | getter) |
| 206 | (slot-name |
| 207 | #'(lambda (object) |
| 208 | (when (slot-boundp object slot-name) |
| 209 | (slot-value object slot-name))))))) |
| 210 | |
| 211 | |
| 212 | (define-layered-function attribute-value (instance attribute) |
| 213 | (:documentation " Like SLOT-VALUE for instances, the base method calls GETTER.")) |
| 214 | |
| 215 | (define-layered-method attribute-value (instance (attribute standard-attribute)) |
| 216 | (funcall (getter attribute) instance)) |
| 217 | |
| 218 | (define-layered-function (setf attribute-value) (value instance attribute)) |
| 219 | |
| 220 | (define-layered-method (setf attribute-value) (value instance (attribute standard-attribute)) |
| 221 | (funcall (setter attribute) value instance)) |
| 222 | |
| 223 | |
| 224 | ;;;; ** Default Attributes |
| 225 | |
| 226 | |
| 227 | ;;;; The default mewa class contains the types use as defaults. |
| 228 | ;;;; maps meta-model slot-types to slot-presentation |
| 229 | |
| 230 | (defvar *default-attributes-class-name* 'default) |
| 231 | |
| 232 | (defmacro with-default-attributes ((occurence-name) &body body) |
| 233 | `(let ((*default-attributes-class-name* ',occurence-name)) |
| 234 | ,@body)) |
| 235 | |
| 236 | (define-attributes (default) |
| 237 | (boolean mewa-boolean) |
| 238 | (string mewa-string) |
| 239 | (number mewa-currency) |
| 240 | (integer mewa-integer) |
| 241 | (currency mewa-currency) |
| 242 | (clsql:generalized-boolean mewa-boolean) |
| 243 | (foreign-key foreign-key) |
| 244 | (:viewer mewa-viewer) |
| 245 | (:editor mewa-editor) |
| 246 | (:creator mewa-creator) |
| 247 | (:as-string mewa-one-line-presentation) |
| 248 | (:one-line mewa-one-line-presentation) |
| 249 | (:listing mewa-list-presentation :global-properties (:editablep nil) :editablep t) |
| 250 | (:search-model mewa-object-presentation)) |
| 251 | |
| 252 | (defun find-presentation-attributes (occurence-name) |
| 253 | (loop for att in (find-all-attributes occurence-name) |
| 254 | when (typep att 'presentation-attribute) |
| 255 | collect att)) |
| 256 | |
| 257 | (defun attribute-to-definition (attribute) |
| 258 | (nconc (list (attribute.name attribute) |
| 259 | (attribute.type attribute)) |
| 260 | (attribute.properties attribute))) |
| 261 | |
| 262 | (defun find-default-presentation-attribute-definitions () |
| 263 | (if (eql *default-attributes-class-name* 'default) |
| 264 | (mapcar #'attribute-to-definition (find-presentation-attributes 'default)) |
| 265 | (remove-duplicates (mapcar #'attribute-to-definition |
| 266 | (append |
| 267 | (find-presentation-attributes 'default) |
| 268 | (find-presentation-attributes |
| 269 | *default-attributes-class-name*)))))) |
| 270 | (defun gen-ptype (type) |
| 271 | (let* ((type (if (consp type) (car type) type)) |
| 272 | (possible-default (find-attribute *default-attributes-class-name* type)) |
| 273 | (real-default (find-attribute 'default type))) |
| 274 | (cond |
| 275 | (possible-default |
| 276 | (attribute.type possible-default)) |
| 277 | (real-default |
| 278 | (attribute.type real-default)) |
| 279 | (t type)))) |
| 280 | |
| 281 | (defun gen-presentation-slots (instance) |
| 282 | (mapcar #'(lambda (x) (gen-pslot (cadr x) |
| 283 | (string (car x)) |
| 284 | (car x))) |
| 285 | (meta-model:list-slot-types instance))) |
| 286 | |
| 287 | |
| 288 | (defun gen-pslot (type label slot-name) |
| 289 | (copy-list `(,(gen-ptype type) |
| 290 | :label ,label |
| 291 | :slot-name ,slot-name))) |
| 292 | |
| 293 | |
| 294 | |
| 295 | ;;;presentations |
| 296 | (defcomponent mewa () |
| 297 | ((instance :accessor instance :initarg :instance) |
| 298 | (attributes |
| 299 | :initarg :attributes |
| 300 | :accessor attributes |
| 301 | :initform nil) |
| 302 | (attributes-getter |
| 303 | :accessor attributes-getter |
| 304 | :initform #'get-attributes |
| 305 | :initarg :attributes-getter) |
| 306 | (attribute-slot-map |
| 307 | :accessor attribute-slot-map |
| 308 | :initform nil) |
| 309 | (global-properties |
| 310 | :initarg :global-properties |
| 311 | :accessor global-properties |
| 312 | :initform nil) |
| 313 | (classes |
| 314 | :initarg :classes |
| 315 | :accessor classes |
| 316 | :initform nil) |
| 317 | (use-instance-class-p |
| 318 | :initarg :use-instance-class-p |
| 319 | :accessor use-instance-class-p |
| 320 | :initform t) |
| 321 | (initializedp :initform nil) |
| 322 | (modifiedp :accessor modifiedp :initform nil :initarg :modifiedp) |
| 323 | (modifications :accessor modifications :initform nil))) |
| 324 | |
| 325 | |
| 326 | (defmethod attributes :around ((self mewa)) |
| 327 | (let ((a (call-next-method))) |
| 328 | (or a (funcall (attributes-getter self) self)))) |
| 329 | |
| 330 | (defgeneric get-attributes (mewa)) |
| 331 | |
| 332 | (defmethod get-attributes ((self mewa)) |
| 333 | (if (instance self) |
| 334 | (append (meta-model:list-slots (instance self)) |
| 335 | (meta-model:list-has-many (instance self))) |
| 336 | nil)) |
| 337 | |
| 338 | (defmethod find-instance-classes ((self mewa)) |
| 339 | (mapcar #'class-name |
| 340 | (it.bese.arnesi.mopp:compute-class-precedence-list (class-of (instance self))))) |
| 341 | |
| 342 | (defun make-presentation-for-attribute-list-item |
| 343 | (occurence att-name plist parent-presentation &optional type) |
| 344 | (declare (type list plist) (type symbol att-name)) |
| 345 | "This is a ucw specific function that will eventually be factored elsewhere." |
| 346 | (let* ((attribute (find-attribute occurence att-name)) |
| 347 | (type (when attribute (or type (attribute.type attribute)))) |
| 348 | (class-name |
| 349 | (or (gethash (if (consp type) |
| 350 | (car type) |
| 351 | type) |
| 352 | *presentation-slot-type-mapping*) |
| 353 | (error "Can't find slot type for ~A in ~A from ~A" att-name occurence parent-presentation)))) |
| 354 | |
| 355 | (cons (attribute.name attribute) (apply #'make-instance |
| 356 | class-name |
| 357 | (append (plist-nunion |
| 358 | plist |
| 359 | (plist-union |
| 360 | (global-properties parent-presentation) |
| 361 | (attribute.properties attribute))) |
| 362 | (list :size 30 :parent parent-presentation)))))) |
| 363 | |
| 364 | (defmethod find-applicable-attributes-using-attribute-list (occurence attribute-list) |
| 365 | "Returns a list of functions that, when called with an object presentation, |
| 366 | returns the ucw slot presentation that will be used to present this attribute |
| 367 | in that object presentation." |
| 368 | (loop for att in attribute-list |
| 369 | with funs = (list) |
| 370 | do (let ((att att)) (cond |
| 371 | ;;simple casee |
| 372 | ((symbolp att) |
| 373 | (push #'(lambda (p) |
| 374 | (make-presentation-for-attribute-list-item occurence att nil p)) |
| 375 | funs)) |
| 376 | ;;if the car is a keyword then this is an inline def |
| 377 | ;; drewc nov 12 2005: |
| 378 | ;; i never used this, and never told anybody about it. |
| 379 | ;; removing it. |
| 380 | #+ (or) ((and (listp x) (keywordp (car x))) |
| 381 | (let ((att (apply #'make-attribute x))) |
| 382 | (setf (cddr att) |
| 383 | (plist-union (cddr att) (global-properties self))) |
| 384 | att)) |
| 385 | |
| 386 | ;; if the plist has a :type |
| 387 | ((and (listp att) (getf (cdr att) :type)) |
| 388 | (let ((type (getf (cdr att) :type))) |
| 389 | (push #'(lambda (p) |
| 390 | (make-presentation-for-attribute-list-item |
| 391 | occurence (first att) |
| 392 | (cdr att) |
| 393 | p |
| 394 | type)) |
| 395 | funs))) |
| 396 | ;;finally if we are just overiding the props |
| 397 | ((and (listp att) (symbolp (car att))) |
| 398 | (push #'(lambda (p) |
| 399 | (make-presentation-for-attribute-list-item occurence (first att) (rest att) p)) |
| 400 | funs)))) |
| 401 | finally (return (nreverse funs)))) |
| 402 | |
| 403 | |
| 404 | (defun find-attribute-names (mewa) |
| 405 | (mapcar #'(lambda (x) |
| 406 | (if (listp x) |
| 407 | (first x) |
| 408 | x)) |
| 409 | (attributes mewa))) |
| 410 | |
| 411 | (defmethod find-applicable-attributes ((self mewa)) |
| 412 | (if (attributes self) |
| 413 | (find-applicable-attributes-using-attribute-list (instance self) (attributes self)) |
| 414 | (find-applicable-attributes-using-attribute-list (instance (get-attributes self))))) |
| 415 | |
| 416 | |
| 417 | (defmethod find-slot-presentations ((self mewa)) |
| 418 | (mapcar #'(lambda (a) (funcall a self)) |
| 419 | (find-applicable-attributes self))) |
| 420 | |
| 421 | (defmethod find-attribute-slot ((self mewa) (attribute symbol)) |
| 422 | (cdr (assoc attribute (attribute-slot-map self)))) |
| 423 | |
| 424 | (defmethod initialize-slots ((self mewa)) |
| 425 | (when (instance self) |
| 426 | (when (use-instance-class-p self) |
| 427 | (setf (classes self) |
| 428 | (append (find-instance-classes self) |
| 429 | (classes self)))) |
| 430 | (setf (attribute-slot-map self) (find-slot-presentations self)) |
| 431 | (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))) |
| 432 | |
| 433 | |
| 434 | (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil)) |
| 435 | ;(warn "Initargs : ~A" initargs) |
| 436 | (let* ((a (find-attribute object type)) |
| 437 | (i (apply #'make-instance |
| 438 | (if a |
| 439 | (attribute.type a) |
| 440 | type) |
| 441 | (plist-union initargs (when a |
| 442 | (attribute.properties a)))))) |
| 443 | |
| 444 | (setf (slot-value i 'instance) object) |
| 445 | (initialize-slots i) |
| 446 | (setf (slot-value i 'initializedp) t) |
| 447 | i)) |
| 448 | |
| 449 | (defmethod make-presentation ((list list) &key (type :listing) (initargs nil)) |
| 450 | (let ((args (append |
| 451 | `(:type ,type) |
| 452 | `(:initargs |
| 453 | (:instances ,list |
| 454 | ,@initargs))))) |
| 455 | |
| 456 | (apply #'make-presentation (car list) args))) |
| 457 | |
| 458 | (defmethod initialize-slots-place ((place ucw::place) (mewa mewa)) |
| 459 | (setf (slots mewa) (mapcar #'(lambda (x) |
| 460 | (prog1 x |
| 461 | (setf (component.place x) place))) |
| 462 | (slots mewa)))) |
| 463 | |
| 464 | (arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa)) |
| 465 | (unless (slot-value to 'initializedp) |
| 466 | (initialize-slots to)) |
| 467 | (setf (slot-value to 'initializedp) t) |
| 468 | (initialize-slots-place (component.place from) to) |
| 469 | to) |
| 470 | |
| 471 | |
| 472 | |
| 473 | (defmacro call-presentation (object &rest args) |
| 474 | `(present-object ,object :presentation (make-presentation ,object ,@args))) |
| 475 | |
| 476 | |
| 477 | (defcomponent about-dialog (option-dialog) |
| 478 | ((body :initarg :body))) |
| 479 | |
| 480 | (defmethod render-on ((res response) (self about-dialog)) |
| 481 | (call-next-method) |
| 482 | (render-on res (slot-value self 'body))) |
| 483 | |
| 484 | |
| 485 | (defaction cancel-save-instance ((self mewa)) |
| 486 | (cond |
| 487 | ((meta-model::persistentp (instance self)) |
| 488 | (meta-model::update-instance-from-records (instance self)) |
| 489 | (answer self)) |
| 490 | (t (answer nil)))) |
| 491 | |
| 492 | (defaction save-instance ((self mewa)) |
| 493 | (meta-model:sync-instance (instance self)) |
| 494 | (setf (modifiedp self) nil) |
| 495 | (answer self)) |
| 496 | |
| 497 | (defmethod confirm-sync-instance ((self mewa)) |
| 498 | nil) |
| 499 | |
| 500 | (defaction ensure-instance-sync ((self mewa)) |
| 501 | (when (modifiedp self) |
| 502 | (if nil |
| 503 | (let ((message (format nil "Record has been modified, Do you wish to save the changes?"))) |
| 504 | (case (call 'about-dialog |
| 505 | :body (make-presentation (instance self) |
| 506 | :type :viewer) |
| 507 | :message message |
| 508 | :options '((:save . "Save changes to Database") |
| 509 | (:cancel . "Cancel all changes"))) |
| 510 | (:cancel |
| 511 | (cancel-save-instance self)) |
| 512 | (:save |
| 513 | (save-instance self)))) |
| 514 | (save-instance self)))) |
| 515 | |
| 516 | (defaction sync-and-answer ((self mewa)) |
| 517 | (ensure-instance-sync self) |
| 518 | (answer (instance self))) |
| 519 | |
| 520 | (defaction ok ((self mewa) &optional arg) |
| 521 | "Returns the component if it has not been modified. if it has been, prompt user to save or cancel" |
| 522 | ;(declare (ignore arg)) |
| 523 | (sync-and-answer self)) |
| 524 | |
| 525 | (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance) |
| 526 | (let* ((old (prog1 |
| 527 | (presentation-slot-value slot instance) |
| 528 | (call-next-method))) |
| 529 | (new (presentation-slot-value slot instance))) |
| 530 | |
| 531 | (unless (equal new old ) |
| 532 | (let ((self (ucw::parent slot))) |
| 533 | (setf (modifiedp self) instance |
| 534 | (modifications self) (append (list new old value slot instance) (modifications self))))))) |
| 535 | |
| 536 | |
| 537 | |
| 538 | |
| 539 | |
| 540 | |
| 541 | |
| 542 | ;; This software is Copyright (c) Drew Crampsie, 2004-2005. |
| 543 | ;; You are granted the rights to distribute |
| 544 | ;; and use this software as governed by the terms |
| 545 | ;; of the Lisp Lesser GNU Public License |
| 546 | ;; (http://opensource.franz.com/preamble.html), |
| 547 | ;; known as the LLGPL. |