Ignore:
Timestamp:
May 16, 2008, 1:38:38 AM (12 years ago)
Author:
gb
Message:

Arrange that structure instances will have a list of their class's
CLASS-CELLS (rather than class-names) in its 0th element.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711-perf/ccl/lib/defstruct-lds.lisp

    r9329 r9521  
    287287    `(require-type ,value ',slot-type)))
    288288
     289(defun make-class-cells-list (class-names)
     290  (if (and (consp class-names)
     291           (eq (car class-names) 'quote)
     292           (consp (cdr class-names))
     293           (null (cddr class-names))
     294           (listp (cadr class-names))
     295           (every #'symbolp (cadr class-names)))
     296    `',(mapcar (lambda (name) (find-class-cell name t)) (cadr class-names))
     297    class-names))
     298
    289299(defun defstruct-constructor (sd constructor &aux (offset 0)
    290300                                                  (args ())
     
    300310      (setq offset (%i+ offset 1)))
    301311    (if (fixnump (setq name (ssd-name slot)))
    302       (push (wrap-with-type-check (ssd-initform slot) slot) values)
     312      (if (eql 0 name)
     313        (push (make-class-cells-list (ssd-initform slot)) values)
     314        (push (wrap-with-type-check (ssd-initform slot) slot) values))
    303315      (let* ((temp (make-symbol (symbol-name name))))
    304316        (push (list (list (make-keyword name) temp) (ssd-initform slot)) args)
     
    319331
    320332(defun defstruct-boa-constructor (sd boa &aux (args ())
    321                                               (used-slots ())
    322                                               (values ())
    323                                               (offset 0)
    324                                               arg-kind slot slot-offset)
     333                                     (used-slots ())
     334                                     (values ())
     335                                     (offset 0)
     336                                     arg-kind slot slot-offset)
    325337  (unless (verify-lambda-list (cadr boa))
    326338    (error "Invalid lambda-list in ~S ." (cons :constructor boa)))
     
    330342          ((setq slot (named-ssd arg (sd-slots sd)))
    331343           (when (or (eq arg-kind '&optional) (eq arg-kind '&key)
    332                      ;; for &aux variables, init value is implementation-defined, however it's not supposed
    333                      ;; to signal a type error until slot is assigned, so might as well just use the initform.
     344                     ;; for &aux variables, init value is
     345                     ;; implementation-defined, however it's not
     346                     ;; supposed to signal a type error until slot is
     347                     ;; assigned, so might as well just use the
     348                     ;; initform.
    334349                     (eq arg-kind '&aux))
    335350             (setq arg (list arg (ssd-initform slot))))
     
    346361      (setq offset (%i+ offset 1)))
    347362    (push (if (memq slot used-slots) (ssd-name slot)
     363            (if (eql 0 (ssd-name slot))
     364              (make-class-cells-list (ssd-initform slot))
    348365              (if (constantp (ssd-initform slot)) (ssd-initform slot)
    349                   (progn
    350                     (unless (eq arg-kind '&aux)
    351                       (push (setq arg-kind '&aux) args))
    352                     (push (list (ssd-name slot) (ssd-initform slot)) args)
    353                     (ssd-name slot))))
     366                (progn
     367                  (unless (eq arg-kind '&aux)
     368                    (push (setq arg-kind '&aux) args))
     369                  (push (list (ssd-name slot) (ssd-initform slot)) args)
     370                  (ssd-name slot)))))
    354371          values)
    355372    (setq offset (%i+ offset 1)))
    356373  (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd)))
    357374  `(defun ,(car boa) ,(nreverse args)
    358      ,(case (setq slot (defstruct-reftype (sd-type sd)))
    359           (#.$defstruct-nth `(list ,@values))
    360           (#.target::subtag-simple-vector `(vector ,@values))
    361           ((#.target::subtag-struct #.$defstruct-struct)
    362            `(gvector :struct ,@values))
    363           (t `(uvector ,slot ,@values)))))
     375    ,(case (setq slot (defstruct-reftype (sd-type sd)))
     376           (#.$defstruct-nth `(list ,@values))
     377           (#.target::subtag-simple-vector `(vector ,@values))
     378           ((#.target::subtag-struct #.$defstruct-struct)
     379            `(gvector :struct ,@values))
     380           (t `(uvector ,slot ,@values)))))
    364381
    365382(defun defstruct-copier (sd copier env)
     
    376393         (body
    377394          (case (sd-type sd)
    378             ((nil) `(structure-typep ,arg ',sd-name))
     395            ((nil) `(structure-typep ,arg ',(find-class-cell sd-name t)))
    379396            ((list) `(and (consp ,arg) (eq (nth ,named ,arg) ',sd-name)))
    380397            (t `(and (uvector-subtype-p ,arg ,(defstruct-reftype (sd-type sd)))
Note: See TracChangeset for help on using the changeset viewer.