Changeset 14501

Dec 22, 2010, 3:53:00 AM (9 years ago)

Support defining multiple keyword constructor functions in defstruct.

If (:constructor nil) is combined with other :constructor options
(defining either keyword or boa constructors), whine about that.

Fixes ticket:769.

1 edited


  • trunk/source/lib/defstruct-lds.lisp

    r14258 r14501  
    7070  ;There's too much state to keep around here to break it up into little
    7171  ;functions, so what the hell, let's do it all inline...
    72   (prog (struct-name type conc-name constructor copier predicate include
     72  (prog (struct-name type conc-name constructors copier predicate include
    7373         print-function print-object  named initial-offset boa-constructors print-p
    7474         documentation (slot-list ()) (offset 0) superclasses sd
    7979      (setq struct-name (pop options)))
    8080    (unless (symbolp struct-name) (signal-program-error $XNotSym struct-name))
    81     (let (name args constructor-p predicate-p)
     81    (let (name args no-constructors-p predicate-p)
    8282      (while options
    8383        (if (atom (car options))
    9292           (when (cddr args) (go bad-options))
    9393           (cond ((cdr args) (push args boa-constructors))
    94                  (t (when constructor (go dup-options))
    95                     (unless (symbolp (%car args)) (go bad-options))
    96                     (setq constructor-p t constructor args))))
     94                 ((null args)
     95                  (push (concat-pnames "MAKE-" struct-name) constructors))
     96                 ((eq (%car args) nil)
     97                  (setq no-constructors-p t))
     98                 (t (unless (symbolp (%car args)) (go bad-options))
     99                    (push (%car args) constructors))))
    97100          (:copier
    98101           (when copier (go dup-options))
    158161            (if (null conc-name) (%str-cat (symbol-name struct-name) "-")
    159162                (if (%car conc-name) (string (%car conc-name)))))
    160       (unless (and boa-constructors (not constructor-p))
    161         (setq constructor
    162               (if (null constructor)
    163                 (concat-pnames "MAKE-" struct-name) (%car constructor))))
     163      (when (and no-constructors-p
     164                 (or constructors boa-constructors))
     165        (error "~s combined with other ~s options"
     166               '(:constructor nil) :constructor))
     167      (unless no-constructors-p
     168        (unless (or boa-constructors constructors)
     169          (push (concat-pnames "MAKE-" struct-name) constructors)))
    164170      (setq copier
    165171            (if (null copier) (concat-pnames "COPY-" struct-name) (%car copier))))
    241247                refnames)))
    242248      (setq refnames (nreverse refnames)))
    243     (setq sd (vector type slot-list superclasses offset constructor () refnames))
     249    (setq sd (vector type slot-list superclasses offset (car constructors) () refnames))
    244250    (return
    245251     `(progn
    263269        ,.(%defstruct-compile sd refnames env)
    264270        ,.(defstruct-boa-constructors sd boa-constructors env)
    265         ,.(if constructor (list (defstruct-constructor sd constructor env)))
     271        ,.(defstruct-constructors sd constructors env)
    266272       ;; Wait until slot accessors are defined, to avoid
    267273       ;; undefined function warnings in the print function/method.
    301307    `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names))
    302308    class-names))
     310(defun defstruct-constructors (sd constructors env &aux (list ()))
     311  (dolist (c constructors list)
     312    (push (defstruct-constructor sd c env) list)))
    304314(defun defstruct-constructor (sd constructor env &aux (offset 0)
Note: See TracChangeset for help on using the changeset viewer.