Ignore:
Timestamp:
Sep 15, 2010, 12:07:42 AM (9 years ago)
Author:
gz
Message:

r14258 from trunk (defstruct changes)

Location:
branches/qres/ccl
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/qres/ccl

  • branches/qres/ccl/lib/defstruct-lds.lisp

    r14057 r14259  
    249249       (remove-structure-defs  ',struct-name) ; lose any previous defs
    250250        ,.(defstruct-slot-defs sd refnames env)
    251         ,.(if copier (defstruct-copier sd copier env))
    252         ,.(if predicate (defstruct-predicate sd named predicate env))
    253251        (eval-when (:compile-toplevel)
    254252          (define-compile-time-structure
     
    261259         ,(if (and predicate (null (sd-type sd))) `',predicate)
    262260         ,.(if documentation (list documentation)))
     261        ,.(if copier (defstruct-copier sd copier env))
     262        ,.(if predicate (defstruct-predicate sd named predicate env))
    263263        ,.(%defstruct-compile sd refnames env)
    264         ,.(defstruct-boa-constructors sd boa-constructors)
    265         ,.(if constructor (list (defstruct-constructor sd constructor)))
     264        ,.(defstruct-boa-constructors sd boa-constructors env)
     265        ,.(if constructor (list (defstruct-constructor sd constructor env)))
    266266       ;; Wait until slot accessors are defined, to avoid
    267267       ;; undefined function warnings in the print function/method.
     
    286286  (intern (%str-cat (string name1) (string name2))))
    287287
    288 (defun wrap-with-type-check (value slot &aux (slot-type (ssd-type slot)))
    289   (if (eq t slot-type)
    290     value
    291     `(require-type ,value ',slot-type)))
     288(defun wrap-with-typecheck (value slot env)
     289  (let ((slot-type (defstruct-type-for-typecheck (ssd-type slot) env)))
     290    (if (eq t slot-type)
     291      value
     292      `(typecheck ,value ,slot-type))))
    292293
    293294(defun make-class-cells-list (class-names)
     
    301302    class-names))
    302303
    303 (defun defstruct-constructor (sd constructor &aux (offset 0)
    304                                                   (args ())
    305                                                   (values ())
    306                                                   slot-offset
    307                                                   name)
     304(defun defstruct-constructor (sd constructor env &aux (offset 0)
     305                                                      (args ())
     306                                                      (values ())
     307                                                      slot-offset
     308                                                      name)
    308309  (dolist (slot (sd-slots sd))
    309310    (setq slot-offset (ssd-offset slot))
     
    316317      (if (eql 0 name)
    317318        (push (make-class-cells-list (ssd-initform slot)) values)
    318         (push (wrap-with-type-check (ssd-initform slot) slot) values))
     319        (push (wrap-with-typecheck (ssd-initform slot) slot env) values))
    319320      (let* ((temp (make-symbol (symbol-name name))))
    320321        (push (list (list (make-keyword name) temp) (ssd-initform slot)) args)
    321         (push (wrap-with-type-check temp slot) values)))
     322        (push (wrap-with-typecheck temp slot env) values)))
    322323    (setq offset (%i+ offset 1)))
    323324  (setq values (nreverse values))
     
    330331          (t `(uvector ,name ,@values)))))
    331332
    332 (defun defstruct-boa-constructors (sd boas &aux (list ()))
     333(defun defstruct-boa-constructors (sd boas env &aux (list ()))
    333334  (dolist (boa boas list)
    334     (push (defstruct-boa-constructor sd boa) list)))
    335 
    336 (defun defstruct-boa-constructor (sd boa &aux (args ())
     335    (push (defstruct-boa-constructor sd boa env) list)))
     336
     337(defun defstruct-boa-constructor (sd boa env &aux (args ())
    337338                                     (used-slots ())
    338339                                     (values ())
     
    375376          values)
    376377    (setq offset (%i+ offset 1)))
    377   (setq values (mapcar #'wrap-with-type-check (nreverse values) (sd-slots sd)))
     378  (setq values (mapcar (lambda (v s) (wrap-with-typecheck v s env)) (nreverse values) (sd-slots sd)))
    378379  `(defun ,(car boa) ,(nreverse args)
    379     ,(case (setq slot (defstruct-reftype (sd-type sd)))
    380            (#.$defstruct-nth `(list ,@values))
    381            (#.target::subtag-simple-vector `(vector ,@values))
    382            ((#.target::subtag-struct #.$defstruct-struct)
    383             `(gvector :struct ,@values))
    384            (t `(uvector ,slot ,@values)))))
     380     ,(case (setq slot (defstruct-reftype (sd-type sd)))
     381        (#.$defstruct-nth `(list ,@values))
     382        (#.target::subtag-simple-vector `(vector ,@values))
     383        ((#.target::subtag-struct #.$defstruct-struct)
     384         `(gvector :struct ,@values))
     385        (t `(uvector ,slot ,@values)))))
    385386
    386387(defun defstruct-copier (sd copier env)
    387   `((eval-when (:compile-toplevel)
    388       (record-function-info ',copier ',*one-arg-defun-def-info* ,env))
    389     (fset ',copier
    390           ,(if (eq (sd-type sd) 'list) '#'copy-list '#'copy-uvector))
    391     (record-source-file ',copier 'function)))
     388  (let* ((sd-name (sd-name sd))
     389         (sd-type (sd-type sd))
     390         (var (defstruct-var sd-name env))
     391         (arg (if sd-type var `(typecheck ,var ,sd-name)))
     392         (fn (if (eq sd-type 'list) 'copy-list 'copy-uvector)))
     393    `((defun ,copier (,var) (,fn ,arg)))))
    392394
    393395(defun defstruct-predicate (sd named predicate env)
Note: See TracChangeset for help on using the changeset viewer.