src/lsp/common2.lsp

   1 ;;;;
   2 ;;;; Additional Common Lisp Functions for XLISP-STAT 2.0
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990-95, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10
  11 ;;;;;;
  12 ;;;;;;                   New DEFSTRUCT System
  13 ;;;;;;            Replaces the internal special form
  14 ;;;;;;
  15 ;;;;;;
  16 ;;;;;; Limitations: Error checking is poor.
  17 ;;;;;;              Multiple :constructor options are not allowed.
  18 ;;;;;;              Typed structures do not support :initial-offset's.
  19 ;;;;;;              The :type slot option is ignored.
  20 ;;;;;;              Probably lots more.
  21
  22 ;;;;
  23 ;;;; Some Compiler Support Functions
  24 ;;;;
  25
  26 (defvar *cmp-structs*)
  27
  28 (defun cmp-get-slotinfo (structname)
  29   (if (boundp '*cmp-structs*)
  30       (assoc structname *cmp-structs*)))
  31
  32 (defun cmp-register-slotinfo (structname slotinfo)
  33   (if (boundp '*cmp-structs*)
  34       (push (cons structname slotinfo) *cmp-structs*)))
  35
  36
  37 ;;;;
  38 ;;;; Some Runtime Support Functions
  39 ;;;;
  40
  41 (defun get-structure-slot-default (type slot)
  42   (second (assoc slot (get type '*struct-slots*))))
  43
  44 (defun set-structure-slot-default (type slot new)
  45   (let* ((slotinfo (get type '*struct-slots*))
  46          (entry (assoc slot slotinfo)))
  47     (when entry
  48           (let ((new-entry (copy-list entry)))
  49             (setf (second new-entry) new)
  50             (setf (get type '*struct-slots*)
  51                   (subst new-entry entry slotinfo))))))
  52
  53 #|
  54 ;;**** This hash table based method may be slightly better for large
  55 ;;**** structures
  56 (let ((default-table (make-hash-table :test 'equal))
  57       (lookup-cell (cons nil nil)))
  58
  59   (defun set-structure-slot-default (type slot new)
  60     (setf (gethash (cons type slot) default-table) new))
  61
  62   (defun get-structure-slot-default (type slot)
  63     (setf (car lookup-cell) type)
  64     (setf (cdr lookup-cell) slot)
  65     (gethash lookup-cell default-table)))
  66 |#
  67
  68 (defun default-structure-slot-value (type slot)
  69   (let ((init (get-structure-slot-default type slot)))
  70     (if init (funcall init))))
  71
  72 (defun install-sharp-s-constructor (structname f)
  73   (if (symbolp f)
  74       (setf (get structname '*struct-constructor*) f)
  75       (let* ((symname (concatenate 'string "MAKE-" (symbol-name structname)))
  76              (sym (make-symbol symname)))
  77         (setf (get structname '*struct-constructor*) sym)
  78         (setf (symbol-function sym) f))))
  79
  80 (defun install-structure-slots (structname include slots)
  81   (let* ((parent (first include))
  82          (parent-info (if parent (get (first include) '*struct-slots*)))
  83          (slotinfo (append parent-info slots))
  84          (overrides (rest include)))
  85     (setf (get structname '*struct-slots*) slotinfo)
  86     (dolist (s slots)
  87       (set-structure-slot-default structname (first s) (second s)))
  88     (when parent
  89           (dolist (i parent-info)
  90             (let* ((name (structure-slotinfo-name i))
  91                    (default (get-structure-slot-default parent name)))
  92               (set-structure-slot-default structname name default)))
  93           (dolist (new overrides)
  94             (set-structure-slot-default structname (first new)
  95                                         (second new))))))
  96
  97
  98 ;;;;
  99 ;;;; Slot Info Representation
 100 ;;;;
 101
 102 (defun make-structure-slotinfo (name form readonly) (list name form readonly))
 103 (defun structure-slotinfo-name (x) (first x))
 104 (defun structure-slotinfo-form (x) (second x))
 105 (defun structure-slotinfo-read-only (x) (third x))
 106
 107
 108 ;;;;
 109 ;;;; Slot Name Comparison Function
 110 ;;;;
 111
 112 (defun structure-slot-eql (x y) (string= (symbol-name x) (symbol-name y)))
 113
 114
 115 ;;;;
 116 ;;;; Slot Option Extractors
 117 ;;;;
 118
 119 (defun convert-structure-slot-options (slots)
 120   (mapcar #'(lambda (x)
 121               (if (consp x)
 122                   (make-structure-slotinfo (first x)
 123                                            (second x)
 124                                            (getf (rest (rest x)) :read-only))
 125                   (make-structure-slotinfo x nil nil)))
 126           slots))
 127
 128 (defun get-structure-parent-slotinfo (p)
 129   (let ((si (get p '*struct-slots* 'none)))
 130     (if (eq si 'none)
 131         (let ((cmpinfo (cmp-get-slotinfo p)))
 132           (unless cmpinfo (error "no slot info available for structure ~s" p))
 133           (copy-list (cdr cmpinfo)))
 134         si)))
 135
 136 (defun get-structure-slotinfo (include slots)
 137   (let ((parent (first include)))
 138     (append (if parent (get-structure-parent-slotinfo parent)) slots)))
 139
 140
 141 ;;;;
 142 ;;;; Slot Option Expanders
 143 ;;;;
 144
 145 (defun check-structure-slots (structspec slotspecs)
 146   (let* ((structname (if (consp structspec) (first structspec) structspec))
 147          (options (if (consp structspec) (rest structspec)))
 148          (include (get-structure-include options))
 149          (parent (first include))
 150          (overrides (rest include))
 151          (owninfo (convert-structure-slot-options slotspecs))
 152          (incinfo (if parent (get-structure-parent-slotinfo parent)))
 153          (info (append incinfo owninfo)))
 154     (flet ((same (x y)
 155                  (structure-slot-eql (structure-slotinfo-name x)
 156                                      (structure-slotinfo-name y))))
 157       ;; check include slot options for existenc and consistent read-only state
 158       (dolist (new overrides)
 159         (let ((old (find new incinfo :test #'same)))
 160           (unless old
 161                   (error "no inherited slot named ~s"
 162                          (symbol-name (structure-slotinfo-name new))))
 163           (when (and (structure-slotinfo-read-only old)
 164                      (not (structure-slotinfo-read-only new)))
 165                 (error "inherited slot ~s must be read-only"
 166                        (structure-slotinfo-name new)))))
 167       ;; check slots for uniqueness
 168       (dolist (own owninfo)
 169         (when (< 1 (count own info :test #'same))
 170               (error "only one slot named ~s allowed"
 171                      (symbol-name (structure-slotinfo-name own))))))))
 172
 173 (defun make-structure-slot-forms (structname include slots)
 174   (flet ((fix-info (x)
 175           (let ((name (structure-slotinfo-name x))
 176                 (form (structure-slotinfo-form x))
 177                 (readonly (structure-slotinfo-read-only x)))
 178             `(list ',name ,(if form `#'(lambda () ,form)) ,readonly))))
 179     (let ((incname (first include))
 180           (incslots (mapcar #'fix-info (rest include)))
 181           (ownslots (mapcar #'fix-info slots)))
 182       `(install-structure-slots ',structname
 183                                 ,(if incname `(list ',incname ,@incslots))
 184                                 ,(if ownslots `(list ,@ownslots))))))
 185
 186 (defun make-structure-slot-accessor-forms (conc-name slotinfo typed)
 187   (let* ((forms nil)
 188          (named (rest typed))
 189          (i (if (and typed (not named)) 0 1))
 190          (ref-fun (if typed 'elt '%struct-ref)))
 191     (dolist (sk slotinfo)
 192       (let* ((sn (structure-slotinfo-name sk))
 193              (name (intern (concatenate 'string conc-name (symbol-name sn))))
 194              (ro (structure-slotinfo-read-only sk)))
 195         (push `(defun ,name (x) (,ref-fun x ,i)) forms)
 196         ;;**** change this to inlining later?
 197         (push `(define-compiler-macro ,name (x) (list ',ref-fun x ,i)) forms)
 198         (push (if ro
 199                   `(defsetf ,name (x) (v) (error "slot ~s is read-only" ',sn))
 200                   `(defsetf ,name (x) (v)
 201                      ,(if typed
 202                           `(list 'setf (list 'elt x ,i) v)
 203                           `(list '%struct-set x ,i v))))
 204               forms))
 205       (incf i))
 206     (if forms `(progn ,@(nreverse forms)))))
 207
 208
 209 ;;;;
 210 ;;;; Structure Option Extractors
 211 ;;;;
 212
 213 (defconstant *structure-options*
 214   '(:conc-name :copier :constructor :include :named
 215                :print-function :predicate :type))
 216
 217 (defun check-structure-specification (structspec)
 218   (let ((structname (if (consp structspec) (first structspec) structspec))
 219         (options (if (consp structspec) (rest structspec))))
 220     (unless (symbolp structname) (error "bad structure name - ~s" structname))
 221     (flet ((check (x s) (when x (error "~a - ~s" s x)))
 222            (is-opt (x) (or (eq x :named) (consp x)))
 223            (optname (x) (if (symbolp x) x (first x))))
 224       (check (find-if-not #'is-opt options) "bad structure option")
 225       (check (find-if-not #'(lambda (x) (member x *structure-options*))
 226                           options
 227                           :key #'optname)
 228              "unknown structure option")
 229       (dolist (opt *structure-options*)
 230         (check (if (< 1 (count opt options :key #'optname)) opt)
 231                "structure option used more than once")))))
 232
 233 (defun find-structure-option (name options)
 234   (find name options :key #'(lambda (x) (if (symbolp x) x (first x)))))
 235
 236 (defun get-structure-option-symbol (name options optname s1 s2)
 237   (let ((option (find-structure-option optname options)))
 238     (if option
 239         (let ((sym (second option)))
 240           (unless (symbolp sym) (error "~s is not a symbol"))
 241           sym)
 242         (intern (concatenate 'string s1 (string name) s2)))))
 243
 244 (defun get-structure-conc-name (structname options)
 245   (let ((option (find-structure-option :conc-name options)))
 246     (if option
 247         (let ((name (second option)))
 248           (if name (string name) ""))
 249         (concatenate 'string (symbol-name structname) "-"))))
 250
 251 (defun get-structure-copier (structname options)
 252   (get-structure-option-symbol structname options :copier "COPY-" ""))
 253
 254 (defun get-structure-constructor (structname options)
 255   (let ((option (find-structure-option :constructor options)))
 256     (if option
 257         (cond
 258          ((null (second option)) nil)
 259          ((consp (rest (rest option))) (list (second option) (third option)))
 260          (t (second option)))
 261         (intern (concatenate 'string "MAKE-" (symbol-name structname))))))
 262
 263 (defun get-structure-include (options)
 264   (let ((option (find-structure-option :include options)))
 265     (when option
 266           (cons (second option)
 267                 (convert-structure-slot-options (rest (rest option)))))))
 268
 269 (defun get-structure-predicate (structname options)
 270   (get-structure-option-symbol structname options :predicate "" "-P"))
 271
 272 (defun get-structure-print-function (options)
 273   (second (find-structure-option :print-function options)))
 274
 275 (defun get-structure-type (options)
 276   (let ((type (second (find-structure-option :type options))))
 277     (when type (cons type (find-structure-option :named options)))))
 278
 279
 280 ;;;;
 281 ;;;; Structure Option Expanders
 282 ;;;;
 283
 284 (defun make-structure-copier-form (copier)
 285   (when copier `(defun ,copier (x) (%copy-struct x))))
 286
 287 (defun make-structure-predicate-form (structname predicate type)
 288   (when (and predicate (not type))
 289         `(progn
 290            (defun ,predicate (x) (%struct-type-p ',structname x))
 291            (define-compiler-macro ,predicate (x)
 292              (list '%struct-type-p '',structname x)))))
 293
 294 (defun make-structure-print-function-form (structname printfun type)
 295   (if (and printfun (not type))
 296       `(setf (get ',structname '*struct-print-function*)
 297              ,(if (symbolp printfun)
 298                   (list 'quote printfun)
 299                 printfun))
 300     `(remprop ',structname '*struct-print-function*)))
 301
 302
 303 (defun make-structure-constructor-form-body (structname slotnames tn)
 304   (let ((type (first tn))
 305         (named (rest tn)))
 306     (cond
 307      ((eq type 'list) `(list ,@(if named `(',structname)) ,@slotnames))
 308      ((eq type 'vector) `(vector ,@(if named `(',structname)) ,@slotnames))
 309      ((and (consp type) (eq (first type) 'vector))
 310       (let* ((slen (length slotnames))
 311              (n (if named (+ slen 1) slen))
 312              (args (if named `(',structname ,@slotnames) slotnames))
 313              (etype (second type)))
 314         `(make-array ,n
 315                      :element-type ',etype
 316                      :initial-contents (list ,@args))))
 317      (t `(%make-struct ',structname ,@slotnames)))))
 318
 319 (defun make-standard-structure-constructor-form (structname slotinfo tn)
 320   (let ((alist nil)
 321         (slotnames (mapcar #'structure-slotinfo-name slotinfo)))
 322     (dolist (s slotnames)
 323       (push `(,s (default-structure-slot-value ',structname ',s)) alist))
 324     (when alist (setf alist `(&key ,@(nreverse alist))))
 325     `(,alist
 326       ,(make-structure-constructor-form-body structname slotnames tn))))
 327
 328 (defun fixup-structure-constructor-argform (name a)
 329   (flet ((new-form (a) `(,a (default-structure-slot-value ',name ',a))))
 330     (cond
 331      ((symbolp a) (new-form a))
 332      ((and (consp a) (null (rest a)))
 333       (let* ((syment (first a))
 334              (sym (if (symbolp syment) syment (second syment))))
 335         (new-form sym)))
 336      (t a))))
 337
 338 (defun remove-structure-constructor-slot (a slots)
 339   (cond
 340    ((symbolp a) (remove a slots))
 341    ((symbolp (first a)) (remove (first a) slots))
 342    ((consp (first a)) (remove (second (first a)) slots))
 343    (t slots)))
 344
 345 (defun structure-constructor-arglist (name alist slots)
 346   (let ((new-alist nil)
 347         (key nil))
 348     (dolist (a alist)
 349       (cond
 350        ((member a lambda-list-keywords) (setf key a))
 351        (t
 352         (when (member key '(&optional &key))
 353               (setf a (fixup-structure-constructor-argform name a)))))
 354       (setf slots (remove-structure-constructor-slot a slots))
 355       (push a new-alist))
 356     (when slots
 357           (pushnew '&aux new-alist)
 358           (dolist (s slots)
 359             (push (fixup-structure-constructor-argform name s) new-alist)))
 360     (nreverse new-alist)))
 361
 362 (defun make-boa-structure-constructor-form (structname slotinfo alist tn)
 363   (let* ((slots (mapcar #'structure-slotinfo-name slotinfo))
 364          (args (structure-constructor-arglist structname alist slots)))
 365     `(,args
 366       ,(make-structure-constructor-form-body structname slots tn))))
 367
 368 (defun make-structure-constructor-form (structname slotinfo constructor tn)
 369   (cond
 370    ((symbolp constructor)
 371     `(defun ,constructor
 372        ,@(make-standard-structure-constructor-form structname slotinfo tn)))
 373    ((consp constructor)
 374     `(defun ,(first constructor)
 375        ,@(make-boa-structure-constructor-form structname
 376                                               slotinfo
 377                                               (second
 378                                                constructor) tn)))))
 379
 380 (defun make-sharp-s-structure-constructor-form (structname slotinfo tn)
 381   `(install-sharp-s-constructor
 382     ',structname
 383     #'(lambda
 384         ,@(make-standard-structure-constructor-form structname slotinfo tn))))
 385
 386 (defun make-structure-include-form (structname include)
 387   (when include
 388         `(setf (get ',structname '*struct-include*) ',(first include))))
 389
 390
 391 ;;;;
 392 ;;;; DEFSTRUCT Macro
 393 ;;;;
 394
 395 (defmacro defstruct (structspec &rest slotspecs)
 396   (check-structure-specification structspec)
 397   ;;**** drop doc string for now
 398   (when (stringp (first slotspecs)) (pop slotspecs))
 399   (check-structure-slots structspec slotspecs)
 400   (let* ((structname (if (consp structspec) (first structspec) structspec))
 401          (options (if (consp structspec) (rest structspec)))
 402          (slots (convert-structure-slot-options slotspecs))
 403          (conc-name (get-structure-conc-name structname options))
 404          (copier (get-structure-copier structname options))
 405          (constructor (get-structure-constructor structname options))
 406          (include (get-structure-include options))
 407          (printfun (get-structure-print-function options))
 408          (predicate (get-structure-predicate structname options))
 409          (type (get-structure-type options))
 410          (slotinfo (get-structure-slotinfo include slots)))
 411     (flet ((list-if (x) (if x (list x))))
 412       `(progn
 413          (eval-when (:compile-toplevel)
 414                     (cmp-register-slotinfo ',structname ',slotinfo))
 415          ,(make-structure-slot-forms structname include slots)
 416          ,@(list-if (make-structure-slot-accessor-forms conc-name
 417                                                         slotinfo
 418                                                         type))
 419          ,@(list-if (make-structure-copier-form copier))
 420          ,@(list-if (make-structure-predicate-form structname predicate type))
 421          ,@(list-if (make-structure-print-function-form structname
 422                                                         printfun
 423                                                         type))
 424          ,@(list-if (make-structure-constructor-form structname
 425                                                      slotinfo
 426                                                      constructor
 427                                                      type))
 428          ,(make-sharp-s-structure-constructor-form structname slotinfo type)
 429          ,@(list-if (make-structure-include-form structname include))
 430          ',structname))))