| 1 | ;;; defstruct.lisp |
|---|
| 2 | ;;; |
|---|
| 3 | ;;; Copyright (C) 2003-2007 Peter Graves <peter@armedbear.org> |
|---|
| 4 | ;;; $Id: defstruct.lisp 12113 2009-08-23 17:39:56Z ehuelsmann $ |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. |
|---|
| 19 | ;;; |
|---|
| 20 | ;;; As a special exception, the copyright holders of this library give you |
|---|
| 21 | ;;; permission to link this library with independent modules to produce an |
|---|
| 22 | ;;; executable, regardless of the license terms of these independent |
|---|
| 23 | ;;; modules, and to copy and distribute the resulting executable under |
|---|
| 24 | ;;; terms of your choice, provided that you also meet, for each linked |
|---|
| 25 | ;;; independent module, the terms and conditions of the license of that |
|---|
| 26 | ;;; module. An independent module is a module which is not derived from |
|---|
| 27 | ;;; or based on this library. If you modify this library, you may extend |
|---|
| 28 | ;;; this exception to your version of the library, but you are not |
|---|
| 29 | ;;; obligated to do so. If you do not wish to do so, delete this |
|---|
| 30 | ;;; exception statement from your version. |
|---|
| 31 | |
|---|
| 32 | (in-package "SYSTEM") |
|---|
| 33 | |
|---|
| 34 | (export 'compiler-defstruct) |
|---|
| 35 | |
|---|
| 36 | ;;; DEFSTRUCT-DESCRIPTION |
|---|
| 37 | |
|---|
| 38 | (defmacro dd-name (x) `(aref ,x 0)) |
|---|
| 39 | (defmacro dd-conc-name (x) `(aref ,x 1)) |
|---|
| 40 | (defmacro dd-default-constructor (x) `(aref ,x 2)) |
|---|
| 41 | (defmacro dd-constructors (x) `(aref ,x 3)) |
|---|
| 42 | (defmacro dd-copier (x) `(aref ,x 4)) |
|---|
| 43 | (defmacro dd-include (x) `(aref ,x 5)) |
|---|
| 44 | (defmacro dd-type (x) `(aref ,x 6)) |
|---|
| 45 | (defmacro dd-named (x) `(aref ,x 7)) |
|---|
| 46 | (defmacro dd-initial-offset (x) `(aref ,x 8)) |
|---|
| 47 | (defmacro dd-predicate (x) `(aref ,x 9)) |
|---|
| 48 | (defmacro dd-print-function (x) `(aref ,x 10)) |
|---|
| 49 | (defmacro dd-print-object (x) `(aref ,x 11)) |
|---|
| 50 | (defmacro dd-direct-slots (x) `(aref ,x 12)) |
|---|
| 51 | (defmacro dd-slots (x) `(aref ,x 13)) |
|---|
| 52 | |
|---|
| 53 | (defun make-defstruct-description (&key name |
|---|
| 54 | conc-name |
|---|
| 55 | default-constructor |
|---|
| 56 | constructors |
|---|
| 57 | copier |
|---|
| 58 | include |
|---|
| 59 | type |
|---|
| 60 | named |
|---|
| 61 | initial-offset |
|---|
| 62 | predicate |
|---|
| 63 | print-function |
|---|
| 64 | print-object |
|---|
| 65 | direct-slots |
|---|
| 66 | slots) |
|---|
| 67 | (let ((dd (make-array 14))) |
|---|
| 68 | (setf (dd-name dd) name |
|---|
| 69 | (dd-conc-name dd) conc-name |
|---|
| 70 | (dd-default-constructor dd) default-constructor |
|---|
| 71 | (dd-constructors dd) constructors |
|---|
| 72 | (dd-copier dd) copier |
|---|
| 73 | (dd-include dd) include |
|---|
| 74 | (dd-type dd) type |
|---|
| 75 | (dd-named dd) named |
|---|
| 76 | (dd-initial-offset dd) initial-offset |
|---|
| 77 | (dd-predicate dd) predicate |
|---|
| 78 | (dd-print-function dd) print-function |
|---|
| 79 | (dd-print-object dd) print-object |
|---|
| 80 | (dd-direct-slots dd) direct-slots |
|---|
| 81 | (dd-slots dd) slots) |
|---|
| 82 | dd)) |
|---|
| 83 | |
|---|
| 84 | ;;; DEFSTRUCT-SLOT-DESCRIPTION |
|---|
| 85 | |
|---|
| 86 | (defmacro dsd-name (x) `(aref ,x 1)) |
|---|
| 87 | (defmacro dsd-index (x) `(aref ,x 2)) |
|---|
| 88 | (defmacro dsd-reader (x) `(aref ,x 3)) |
|---|
| 89 | (defmacro dsd-initform (x) `(aref ,x 4)) |
|---|
| 90 | (defmacro dsd-type (x) `(aref ,x 5)) |
|---|
| 91 | (defmacro dsd-read-only (x) `(aref ,x 6)) |
|---|
| 92 | |
|---|
| 93 | (defun make-defstruct-slot-description (&key name |
|---|
| 94 | index |
|---|
| 95 | reader |
|---|
| 96 | initform |
|---|
| 97 | (type t) |
|---|
| 98 | read-only) |
|---|
| 99 | (let ((dsd (make-array 7))) |
|---|
| 100 | (setf (aref dsd 0) 'defstruct-slot-description |
|---|
| 101 | (dsd-name dsd) name |
|---|
| 102 | (dsd-index dsd) index |
|---|
| 103 | (dsd-reader dsd) reader |
|---|
| 104 | (dsd-initform dsd) initform |
|---|
| 105 | (dsd-type dsd) type |
|---|
| 106 | (dsd-read-only dsd) read-only) |
|---|
| 107 | dsd)) |
|---|
| 108 | |
|---|
| 109 | (defvar *dd-name*) |
|---|
| 110 | (defvar *dd-conc-name*) |
|---|
| 111 | (defvar *dd-default-constructor*) |
|---|
| 112 | (defvar *dd-constructors*) |
|---|
| 113 | (defvar *dd-copier*) |
|---|
| 114 | (defvar *dd-include*) |
|---|
| 115 | (defvar *dd-type*) |
|---|
| 116 | (defvar *dd-default-slot-type* t) |
|---|
| 117 | (defvar *dd-named*) |
|---|
| 118 | (defvar *dd-initial-offset*) |
|---|
| 119 | (defvar *dd-predicate*) |
|---|
| 120 | (defvar *dd-print-function*) |
|---|
| 121 | (defvar *dd-print-object*) |
|---|
| 122 | (defvar *dd-direct-slots*) |
|---|
| 123 | (defvar *dd-slots*) |
|---|
| 124 | |
|---|
| 125 | (defun keywordify (symbol) |
|---|
| 126 | (intern (symbol-name symbol) +keyword-package+)) |
|---|
| 127 | |
|---|
| 128 | (defun define-keyword-constructor (constructor) |
|---|
| 129 | (let* ((constructor-name (car constructor)) |
|---|
| 130 | (keys ()) |
|---|
| 131 | (values ())) |
|---|
| 132 | (dolist (slot *dd-slots*) |
|---|
| 133 | (let ((name (dsd-name slot)) |
|---|
| 134 | (initform (dsd-initform slot))) |
|---|
| 135 | (if (or name (dsd-reader slot)) |
|---|
| 136 | (let ((dummy (gensym))) |
|---|
| 137 | (push (list (list (keywordify name) dummy) initform) keys) |
|---|
| 138 | (push dummy values)) |
|---|
| 139 | (push initform values)))) |
|---|
| 140 | (setf keys (cons '&key (nreverse keys)) |
|---|
| 141 | values (nreverse values)) |
|---|
| 142 | (cond ((eq *dd-type* 'list) |
|---|
| 143 | `((defun ,constructor-name ,keys |
|---|
| 144 | (list ,@values)))) |
|---|
| 145 | ((or (eq *dd-type* 'vector) |
|---|
| 146 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 147 | (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t))) |
|---|
| 148 | `((defun ,constructor-name ,keys |
|---|
| 149 | (make-array ,(length values) |
|---|
| 150 | :element-type ',element-type |
|---|
| 151 | :initial-contents (list ,@values)))))) |
|---|
| 152 | ((<= 1 (length values) 6) |
|---|
| 153 | `((defun ,constructor-name ,keys |
|---|
| 154 | (make-structure (truly-the symbol ',*dd-name*) ,@values)))) |
|---|
| 155 | (t |
|---|
| 156 | `((defun ,constructor-name ,keys |
|---|
| 157 | (%make-structure (truly-the symbol ',*dd-name*) (list ,@values)))))))) |
|---|
| 158 | |
|---|
| 159 | (defun find-dsd (name) |
|---|
| 160 | (dolist (dsd *dd-slots*) |
|---|
| 161 | (when (string= name (dsd-name dsd)) |
|---|
| 162 | (return dsd)))) |
|---|
| 163 | |
|---|
| 164 | (defun get-slot (name) |
|---|
| 165 | ;; (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name))) |
|---|
| 166 | (let ((res nil)) |
|---|
| 167 | (dolist (dsd *dd-slots*) |
|---|
| 168 | (when (string= name (dsd-name dsd)) |
|---|
| 169 | (setf res dsd) |
|---|
| 170 | (return))) |
|---|
| 171 | (if res |
|---|
| 172 | (values (dsd-type res) (dsd-initform res)) |
|---|
| 173 | (values t nil)))) |
|---|
| 174 | |
|---|
| 175 | (defun define-boa-constructor (constructor) |
|---|
| 176 | (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux) |
|---|
| 177 | (parse-lambda-list (cadr constructor)) |
|---|
| 178 | (let ((arglist ()) |
|---|
| 179 | (vars ()) |
|---|
| 180 | (types ()) |
|---|
| 181 | (skipped-vars ())) |
|---|
| 182 | (dolist (arg req) |
|---|
| 183 | (push arg arglist) |
|---|
| 184 | (push arg vars) |
|---|
| 185 | (push (get-slot arg) types)) |
|---|
| 186 | (when opt |
|---|
| 187 | (push '&optional arglist) |
|---|
| 188 | (dolist (arg opt) |
|---|
| 189 | (cond ((consp arg) |
|---|
| 190 | (destructuring-bind |
|---|
| 191 | (name |
|---|
| 192 | &optional |
|---|
| 193 | (def (nth-value 1 (get-slot name))) |
|---|
| 194 | (supplied-test nil supplied-test-p)) |
|---|
| 195 | arg |
|---|
| 196 | (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist) |
|---|
| 197 | (push name vars) |
|---|
| 198 | (push (get-slot name) types))) |
|---|
| 199 | (t |
|---|
| 200 | (multiple-value-bind (type default) (get-slot arg) |
|---|
| 201 | (push `(,arg ,default) arglist) |
|---|
| 202 | (push arg vars) |
|---|
| 203 | (push type types)))))) |
|---|
| 204 | (when restp |
|---|
| 205 | (push '&rest arglist) |
|---|
| 206 | (push rest arglist) |
|---|
| 207 | (push rest vars) |
|---|
| 208 | (push 'list types)) |
|---|
| 209 | (when keyp |
|---|
| 210 | (push '&key arglist) |
|---|
| 211 | (dolist (key keys) |
|---|
| 212 | (if (consp key) |
|---|
| 213 | (destructuring-bind (wot |
|---|
| 214 | &optional |
|---|
| 215 | (def nil def-p) |
|---|
| 216 | (supplied-test nil supplied-test-p)) |
|---|
| 217 | key |
|---|
| 218 | (let ((name (if (consp wot) |
|---|
| 219 | (destructuring-bind (key var) wot |
|---|
| 220 | (declare (ignore key)) |
|---|
| 221 | var) |
|---|
| 222 | wot))) |
|---|
| 223 | (multiple-value-bind (type slot-def) |
|---|
| 224 | (get-slot name) |
|---|
| 225 | (push `(,wot ,(if def-p def slot-def) |
|---|
| 226 | ,@(if supplied-test-p `(,supplied-test) nil)) |
|---|
| 227 | arglist) |
|---|
| 228 | (push name vars) |
|---|
| 229 | (push type types)))) |
|---|
| 230 | (multiple-value-bind (type default) (get-slot key) |
|---|
| 231 | (push `(,key ,default) arglist) |
|---|
| 232 | (push key vars) |
|---|
| 233 | (push type types))))) |
|---|
| 234 | (when allowp |
|---|
| 235 | (push '&allow-other-keys arglist)) |
|---|
| 236 | (when auxp |
|---|
| 237 | (push '&aux arglist) |
|---|
| 238 | (dolist (arg aux) |
|---|
| 239 | (push arg arglist) |
|---|
| 240 | (if (and (consp arg) (eql (length arg) 2)) |
|---|
| 241 | (let ((var (first arg))) |
|---|
| 242 | (push var vars) |
|---|
| 243 | (push (get-slot var) types)) |
|---|
| 244 | (push (if (consp arg) (first arg) arg) skipped-vars)))) |
|---|
| 245 | (setq arglist (nreverse arglist)) |
|---|
| 246 | (setq vars (nreverse vars)) |
|---|
| 247 | (setq types (nreverse types)) |
|---|
| 248 | (setq skipped-vars (nreverse skipped-vars)) |
|---|
| 249 | (let ((values ())) |
|---|
| 250 | (dolist (dsd *dd-slots*) |
|---|
| 251 | (let ((name (dsd-name dsd)) |
|---|
| 252 | var) |
|---|
| 253 | (cond ((find name skipped-vars :test #'string=) |
|---|
| 254 | (push nil values)) |
|---|
| 255 | ((setf var (find name vars :test #'string=)) |
|---|
| 256 | (push var values)) |
|---|
| 257 | (t |
|---|
| 258 | (push (dsd-initform dsd) values))))) |
|---|
| 259 | (setf values (nreverse values)) |
|---|
| 260 | (let* ((constructor-name (car constructor))) |
|---|
| 261 | (cond ((eq *dd-type* 'list) |
|---|
| 262 | `((defun ,constructor-name ,arglist |
|---|
| 263 | (list ,@values)))) |
|---|
| 264 | ((or (eq *dd-type* 'vector) |
|---|
| 265 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 266 | (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t))) |
|---|
| 267 | `((defun ,constructor-name ,arglist |
|---|
| 268 | (make-array ,(length values) |
|---|
| 269 | :element-type ',element-type |
|---|
| 270 | :initial-contents (list ,@values)))))) |
|---|
| 271 | ((<= 1 (length values) 6) |
|---|
| 272 | `((declaim (inline ,constructor-name)) |
|---|
| 273 | (defun ,constructor-name ,arglist |
|---|
| 274 | (make-structure (truly-the symbol ',*dd-name*) ,@values)))) |
|---|
| 275 | (t |
|---|
| 276 | `((declaim (inline ,constructor-name)) |
|---|
| 277 | (defun ,constructor-name ,arglist |
|---|
| 278 | (%make-structure (truly-the symbol ',*dd-name*) (list ,@values))))))))))) |
|---|
| 279 | |
|---|
| 280 | (defun default-constructor-name () |
|---|
| 281 | (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*)))) |
|---|
| 282 | |
|---|
| 283 | (defun define-constructors () |
|---|
| 284 | (if *dd-constructors* |
|---|
| 285 | (let ((results ())) |
|---|
| 286 | (dolist (constructor *dd-constructors*) |
|---|
| 287 | (when (car constructor) |
|---|
| 288 | (setf results (nconc results |
|---|
| 289 | (if (cadr constructor) |
|---|
| 290 | (define-boa-constructor constructor) |
|---|
| 291 | (define-keyword-constructor constructor)))))) |
|---|
| 292 | results) |
|---|
| 293 | (define-keyword-constructor (cons (default-constructor-name) nil)))) |
|---|
| 294 | |
|---|
| 295 | (defun name-index () |
|---|
| 296 | (dolist (dsd *dd-slots*) |
|---|
| 297 | (let ((name (dsd-name dsd)) |
|---|
| 298 | (initform (dsd-initform dsd))) |
|---|
| 299 | (when (and (null name) |
|---|
| 300 | (equal initform (list 'quote *dd-name*))) |
|---|
| 301 | (return-from name-index (dsd-index dsd))))) |
|---|
| 302 | ;; We shouldn't get here. |
|---|
| 303 | nil) |
|---|
| 304 | |
|---|
| 305 | (defun define-predicate () |
|---|
| 306 | (when (and *dd-predicate* |
|---|
| 307 | (or *dd-named* (null *dd-type*))) |
|---|
| 308 | (let ((pred (if (symbolp *dd-predicate*) |
|---|
| 309 | *dd-predicate* |
|---|
| 310 | (intern *dd-predicate*)))) |
|---|
| 311 | (cond ((eq *dd-type* 'list) |
|---|
| 312 | (let ((index (name-index))) |
|---|
| 313 | `((defun ,pred (object) |
|---|
| 314 | (and (consp object) |
|---|
| 315 | (> (length object) ,index) |
|---|
| 316 | (eq (nth ,index object) ',*dd-name*)))))) |
|---|
| 317 | ((or (eq *dd-type* 'vector) |
|---|
| 318 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 319 | (let ((index (name-index))) |
|---|
| 320 | `((defun ,pred (object) |
|---|
| 321 | (and (vectorp object) |
|---|
| 322 | (> (length object) ,index) |
|---|
| 323 | (eq (aref object ,index) ',*dd-name*)))))) |
|---|
| 324 | (t |
|---|
| 325 | `((defun ,pred (object) |
|---|
| 326 | (simple-typep object ',*dd-name*)))))))) |
|---|
| 327 | |
|---|
| 328 | (defun define-reader (slot) |
|---|
| 329 | (let ((accessor-name (if *dd-conc-name* |
|---|
| 330 | (intern (concatenate 'string |
|---|
| 331 | (symbol-name *dd-conc-name*) |
|---|
| 332 | (symbol-name (dsd-name slot)))) |
|---|
| 333 | (dsd-name slot))) |
|---|
| 334 | (index (dsd-index slot)) |
|---|
| 335 | (type (dsd-type slot))) |
|---|
| 336 | (cond ((eq *dd-type* 'list) |
|---|
| 337 | `((declaim (ftype (function * ,type) ,accessor-name)) |
|---|
| 338 | (defun ,accessor-name (instance) (elt instance ,index)))) |
|---|
| 339 | ((or (eq *dd-type* 'vector) |
|---|
| 340 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 341 | `((declaim (ftype (function * ,type) ,accessor-name)) |
|---|
| 342 | (defun ,accessor-name (instance) (aref instance ,index)) |
|---|
| 343 | (define-source-transform ,accessor-name (instance) |
|---|
| 344 | `(aref (truly-the ,',*dd-type* ,instance) ,,index)))) |
|---|
| 345 | (t |
|---|
| 346 | `((declaim (ftype (function * ,type) ,accessor-name)) |
|---|
| 347 | (defun ,accessor-name (instance) |
|---|
| 348 | (structure-ref (the ,*dd-name* instance) ,index)) |
|---|
| 349 | (define-source-transform ,accessor-name (instance) |
|---|
| 350 | ,(if (eq type 't) |
|---|
| 351 | ``(structure-ref (the ,',*dd-name* ,instance) ,,index) |
|---|
| 352 | ``(the ,',type |
|---|
| 353 | (structure-ref (the ,',*dd-name* ,instance) ,,index))))))))) |
|---|
| 354 | |
|---|
| 355 | (defun define-writer (slot) |
|---|
| 356 | (let ((accessor-name (if *dd-conc-name* |
|---|
| 357 | (intern (concatenate 'string |
|---|
| 358 | (symbol-name *dd-conc-name*) |
|---|
| 359 | (symbol-name (dsd-name slot)))) |
|---|
| 360 | (dsd-name slot))) |
|---|
| 361 | (index (dsd-index slot))) |
|---|
| 362 | (cond ((eq *dd-type* 'list) |
|---|
| 363 | `((defun (setf ,accessor-name) (value instance) |
|---|
| 364 | (%set-elt instance ,index value)))) |
|---|
| 365 | ((or (eq *dd-type* 'vector) |
|---|
| 366 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 367 | `((defun (setf ,accessor-name) (value instance) |
|---|
| 368 | (aset instance ,index value)) |
|---|
| 369 | (define-source-transform (setf ,accessor-name) (value instance) |
|---|
| 370 | `(aset (truly-the ,',*dd-type* ,instance) ,,index ,value)))) |
|---|
| 371 | (t |
|---|
| 372 | `((defun (setf ,accessor-name) (value instance) |
|---|
| 373 | (structure-set (the ,*dd-name* instance) ,index value)) |
|---|
| 374 | (define-source-transform (setf ,accessor-name) (value instance) |
|---|
| 375 | `(structure-set (the ,',*dd-name* ,instance) |
|---|
| 376 | ,,index ,value))))))) |
|---|
| 377 | |
|---|
| 378 | (defun define-access-functions () |
|---|
| 379 | (let ((result ())) |
|---|
| 380 | (dolist (slot *dd-slots*) |
|---|
| 381 | (setf result (nconc result (define-reader slot))) |
|---|
| 382 | (unless (dsd-read-only slot) |
|---|
| 383 | (setf result (nconc result (define-writer slot))))) |
|---|
| 384 | result)) |
|---|
| 385 | |
|---|
| 386 | (defun define-copier () |
|---|
| 387 | (when *dd-copier* |
|---|
| 388 | (cond ((eq *dd-type* 'list) |
|---|
| 389 | `((setf (fdefinition ',*dd-copier*) #'copy-list))) |
|---|
| 390 | ((or (eq *dd-type* 'vector) |
|---|
| 391 | (and (consp *dd-type*) (eq (car *dd-type*) 'vector))) |
|---|
| 392 | `((setf (fdefinition ',*dd-copier*) #'copy-seq))) |
|---|
| 393 | (t |
|---|
| 394 | `((setf (fdefinition ',*dd-copier*) #'copy-structure)))))) |
|---|
| 395 | |
|---|
| 396 | (defun define-print-function () |
|---|
| 397 | (cond (*dd-print-function* |
|---|
| 398 | (if (cadr *dd-print-function*) |
|---|
| 399 | `((defmethod print-object ((instance ,*dd-name*) stream) |
|---|
| 400 | (funcall (function ,(cadr *dd-print-function*)) |
|---|
| 401 | instance stream *current-print-level*))) |
|---|
| 402 | `((defmethod print-object ((instance ,*dd-name*) stream) |
|---|
| 403 | (write-string (%write-to-string instance) stream))))) |
|---|
| 404 | (*dd-print-object* |
|---|
| 405 | (if (cadr *dd-print-object*) |
|---|
| 406 | `((defmethod print-object ((instance ,*dd-name*) stream) |
|---|
| 407 | (funcall (function ,(cadr *dd-print-object*)) |
|---|
| 408 | instance stream))) |
|---|
| 409 | `((defmethod print-object ((instance ,*dd-name*) stream) |
|---|
| 410 | (write-string (%write-to-string instance) stream))))) |
|---|
| 411 | (t |
|---|
| 412 | nil))) |
|---|
| 413 | |
|---|
| 414 | (defun parse-1-option (option) |
|---|
| 415 | (case (car option) |
|---|
| 416 | (:conc-name |
|---|
| 417 | (setf *dd-conc-name* (if (symbolp (cadr option)) |
|---|
| 418 | (cadr option) |
|---|
| 419 | (make-symbol (string (cadr option)))))) |
|---|
| 420 | (:constructor |
|---|
| 421 | (let* ((args (cdr option)) |
|---|
| 422 | (numargs (length args))) |
|---|
| 423 | (case numargs |
|---|
| 424 | (0 ; Use default name. |
|---|
| 425 | (push (list (default-constructor-name) nil) *dd-constructors*)) |
|---|
| 426 | (1 |
|---|
| 427 | (push (list (car args) nil) *dd-constructors*)) |
|---|
| 428 | (2 |
|---|
| 429 | (push args *dd-constructors*))))) |
|---|
| 430 | (:copier |
|---|
| 431 | (when (eql (length option) 2) |
|---|
| 432 | (setf *dd-copier* (cadr option)))) |
|---|
| 433 | (:include |
|---|
| 434 | (setf *dd-include* (cdr option))) |
|---|
| 435 | (:initial-offset |
|---|
| 436 | (setf *dd-initial-offset* (cadr option))) |
|---|
| 437 | (:predicate |
|---|
| 438 | (when (eql (length option) 2) |
|---|
| 439 | (setf *dd-predicate* (cadr option)))) |
|---|
| 440 | (:print-function |
|---|
| 441 | (setf *dd-print-function* option)) |
|---|
| 442 | (:print-object |
|---|
| 443 | (setf *dd-print-object* option)) |
|---|
| 444 | (:type |
|---|
| 445 | (setf *dd-type* (cadr option)) |
|---|
| 446 | (when (and (consp *dd-type*) (eq (car *dd-type*) 'vector)) |
|---|
| 447 | (unless (eq (second *dd-type*) '*) |
|---|
| 448 | (setf *dd-default-slot-type* (second *dd-type*))))))) |
|---|
| 449 | |
|---|
| 450 | (defun parse-name-and-options (name-and-options) |
|---|
| 451 | (setf *dd-name* (the symbol (car name-and-options))) |
|---|
| 452 | (setf *dd-conc-name* (make-symbol (concatenate 'string (symbol-name *dd-name*) "-"))) |
|---|
| 453 | (setf *dd-copier* (intern (concatenate 'string "COPY-" (symbol-name *dd-name*)))) |
|---|
| 454 | (setf *dd-predicate* (concatenate 'string (symbol-name *dd-name*) "-P")) |
|---|
| 455 | (let ((options (cdr name-and-options))) |
|---|
| 456 | (dolist (option options) |
|---|
| 457 | (cond ((consp option) |
|---|
| 458 | (parse-1-option option)) |
|---|
| 459 | ((eq option :named) |
|---|
| 460 | (setf *dd-named* t)) |
|---|
| 461 | ((member option '(:constructor :copier :predicate :named :conc-name)) |
|---|
| 462 | (parse-1-option (list option))) |
|---|
| 463 | (t |
|---|
| 464 | (error "Unrecognized DEFSTRUCT option: ~S." option)))))) |
|---|
| 465 | |
|---|
| 466 | (defun compiler-defstruct (name &key |
|---|
| 467 | conc-name |
|---|
| 468 | default-constructor |
|---|
| 469 | constructors |
|---|
| 470 | copier |
|---|
| 471 | include |
|---|
| 472 | type |
|---|
| 473 | named |
|---|
| 474 | initial-offset |
|---|
| 475 | predicate |
|---|
| 476 | print-function |
|---|
| 477 | print-object |
|---|
| 478 | direct-slots |
|---|
| 479 | slots) |
|---|
| 480 | (setf (get name 'structure-definition) |
|---|
| 481 | (make-defstruct-description :name name |
|---|
| 482 | :conc-name conc-name |
|---|
| 483 | :default-constructor default-constructor |
|---|
| 484 | :constructors constructors |
|---|
| 485 | :copier copier |
|---|
| 486 | :include include |
|---|
| 487 | :type type |
|---|
| 488 | :named named |
|---|
| 489 | :initial-offset initial-offset |
|---|
| 490 | :predicate predicate |
|---|
| 491 | :print-function print-function |
|---|
| 492 | :print-object print-object |
|---|
| 493 | :direct-slots direct-slots |
|---|
| 494 | :slots slots)) |
|---|
| 495 | (when (or (null type) named) |
|---|
| 496 | (make-structure-class name direct-slots slots (car include))) |
|---|
| 497 | (when default-constructor |
|---|
| 498 | (proclaim `(ftype (function * t) ,default-constructor)))) |
|---|
| 499 | |
|---|
| 500 | (defmacro defstruct (name-and-options &rest slots) |
|---|
| 501 | (let ((*dd-name* nil) |
|---|
| 502 | (*dd-conc-name* nil) |
|---|
| 503 | (*dd-default-constructor* nil) |
|---|
| 504 | (*dd-constructors* nil) |
|---|
| 505 | (*dd-copier* nil) |
|---|
| 506 | (*dd-include* nil) |
|---|
| 507 | (*dd-type* nil) |
|---|
| 508 | (*dd-default-slot-type* t) |
|---|
| 509 | (*dd-named* nil) |
|---|
| 510 | (*dd-initial-offset* nil) |
|---|
| 511 | (*dd-predicate* nil) |
|---|
| 512 | (*dd-print-function* nil) |
|---|
| 513 | (*dd-print-object* nil) |
|---|
| 514 | (*dd-direct-slots* ()) |
|---|
| 515 | (*dd-slots* ())) |
|---|
| 516 | (parse-name-and-options (if (atom name-and-options) |
|---|
| 517 | (list name-and-options) |
|---|
| 518 | name-and-options)) |
|---|
| 519 | (check-declaration-type *dd-name*) |
|---|
| 520 | (if *dd-constructors* |
|---|
| 521 | (dolist (constructor *dd-constructors*) |
|---|
| 522 | (unless (cadr constructor) |
|---|
| 523 | (setf *dd-default-constructor* (car constructor)) |
|---|
| 524 | (return))) |
|---|
| 525 | (setf *dd-default-constructor* (default-constructor-name))) |
|---|
| 526 | (when (stringp (car slots)) |
|---|
| 527 | (%set-documentation *dd-name* 'structure (pop slots))) |
|---|
| 528 | (dolist (slot slots) |
|---|
| 529 | (let* ((name (if (atom slot) slot (car slot))) |
|---|
| 530 | (reader (if *dd-conc-name* |
|---|
| 531 | (intern (concatenate 'string |
|---|
| 532 | (symbol-name *dd-conc-name*) |
|---|
| 533 | (symbol-name name))) |
|---|
| 534 | name)) |
|---|
| 535 | (initform (if (atom slot) nil (cadr slot))) |
|---|
| 536 | (dsd (apply #'make-defstruct-slot-description |
|---|
| 537 | :name name |
|---|
| 538 | :reader reader |
|---|
| 539 | :initform initform |
|---|
| 540 | (cond |
|---|
| 541 | ((atom slot) |
|---|
| 542 | (list :type *dd-default-slot-type*)) |
|---|
| 543 | ((getf (cddr slot) :type) |
|---|
| 544 | (cddr slot)) |
|---|
| 545 | (t |
|---|
| 546 | (list* :type *dd-default-slot-type* (cddr slot))))))) |
|---|
| 547 | (push dsd *dd-direct-slots*))) |
|---|
| 548 | (setf *dd-direct-slots* (nreverse *dd-direct-slots*)) |
|---|
| 549 | (let ((index 0)) |
|---|
| 550 | (when *dd-include* |
|---|
| 551 | (let ((dd (get (car *dd-include*) 'structure-definition))) |
|---|
| 552 | (unless dd |
|---|
| 553 | (error 'simple-error |
|---|
| 554 | :format-control "Class ~S is undefined." |
|---|
| 555 | :format-arguments (list (car *dd-include*)))) |
|---|
| 556 | (dolist (dsd (dd-slots dd)) |
|---|
| 557 | ;; MUST COPY SLOT DESCRIPTION! |
|---|
| 558 | (setf dsd (copy-seq dsd)) |
|---|
| 559 | (setf (dsd-index dsd) index) |
|---|
| 560 | (push dsd *dd-slots*) |
|---|
| 561 | (incf index))) |
|---|
| 562 | (when (cdr *dd-include*) |
|---|
| 563 | (dolist (slot (cdr *dd-include*)) |
|---|
| 564 | (let* ((name (if (atom slot) slot (car slot))) |
|---|
| 565 | (initform (if (atom slot) nil (cadr slot))) |
|---|
| 566 | (dsd (find-dsd name))) |
|---|
| 567 | (when dsd |
|---|
| 568 | (setf (dsd-initform dsd) initform)))))) |
|---|
| 569 | (when *dd-initial-offset* |
|---|
| 570 | (dotimes (i *dd-initial-offset*) |
|---|
| 571 | (push (make-defstruct-slot-description :name nil |
|---|
| 572 | :index index |
|---|
| 573 | :reader nil |
|---|
| 574 | :initform nil |
|---|
| 575 | :type t |
|---|
| 576 | :read-only t) |
|---|
| 577 | *dd-slots*) |
|---|
| 578 | (incf index))) |
|---|
| 579 | (when *dd-named* |
|---|
| 580 | (push (make-defstruct-slot-description :name nil |
|---|
| 581 | :index index |
|---|
| 582 | :reader nil |
|---|
| 583 | :initform (list 'quote *dd-name*) |
|---|
| 584 | :type t |
|---|
| 585 | :read-only t) |
|---|
| 586 | *dd-slots*) |
|---|
| 587 | (incf index)) |
|---|
| 588 | (dolist (dsd *dd-direct-slots*) |
|---|
| 589 | (setf (dsd-index dsd) index) |
|---|
| 590 | (push dsd *dd-slots*) |
|---|
| 591 | (incf index))) |
|---|
| 592 | (setf *dd-slots* (nreverse *dd-slots*)) |
|---|
| 593 | `(progn |
|---|
| 594 | (eval-when (:compile-toplevel :load-toplevel :execute) |
|---|
| 595 | (compiler-defstruct ',*dd-name* |
|---|
| 596 | :conc-name ',*dd-conc-name* |
|---|
| 597 | :default-constructor ',*dd-default-constructor* |
|---|
| 598 | ,@(if *dd-constructors* `(:constructors ',*dd-constructors*)) |
|---|
| 599 | :copier ',*dd-copier* |
|---|
| 600 | ,@(if *dd-include* `(:include ',*dd-include*)) |
|---|
| 601 | ,@(if *dd-type* `(:type ',*dd-type*)) |
|---|
| 602 | ,@(if *dd-named* `(:named ,*dd-named*)) |
|---|
| 603 | ,@(if *dd-initial-offset* `(:initial-offset ,*dd-initial-offset*)) |
|---|
| 604 | :predicate ',*dd-predicate* |
|---|
| 605 | ,@(if *dd-print-function* `(:print-function ',*dd-print-function*)) |
|---|
| 606 | ,@(if *dd-print-object* `(:print-object ',*dd-print-object*)) |
|---|
| 607 | :direct-slots ',*dd-direct-slots* |
|---|
| 608 | :slots ',*dd-slots*)) |
|---|
| 609 | ,@(define-constructors) |
|---|
| 610 | ,@(define-predicate) |
|---|
| 611 | ,@(define-access-functions) |
|---|
| 612 | ,@(define-copier) |
|---|
| 613 | ,@(define-print-function) |
|---|
| 614 | ',*dd-name*))) |
|---|
| 615 | |
|---|
| 616 | (defun defstruct-default-constructor (arg) |
|---|
| 617 | (let ((type (cond ((symbolp arg) |
|---|
| 618 | arg) |
|---|
| 619 | ((classp arg) |
|---|
| 620 | (class-name arg)) |
|---|
| 621 | (t |
|---|
| 622 | (type-of arg))))) |
|---|
| 623 | (when type |
|---|
| 624 | (let ((dd (get type 'structure-definition))) |
|---|
| 625 | (and dd (dd-default-constructor dd)))))) |
|---|
