Ignore:
Timestamp:
11/21/03 18:29:28 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r4860 r4863  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.39 2003-11-21 15:58:30 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.40 2003-11-21 18:29:28 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    103103    (when *dd-named*
    104104      (push (list 'quote *dd-name*) elements))
    105     (when *dd-initial-offset*
    106       (dotimes (i *dd-initial-offset*)
    107         (push nil elements)))
     105;;     (when *dd-initial-offset*
     106;;       (dotimes (i *dd-initial-offset*)
     107;;         (push nil elements)))
     108    (setf elements ())
     109    (let ((index 0))
     110      (dolist (slot *dd-slots*)
     111        (loop
     112          (when (= index (dsd-index slot))
     113            (return))
     114;;           (format t "index = ~S slot = ~S dsd-index = ~S~%" index (dsd-name slot) (dsd-index slot))
     115          (push nil elements)
     116          (incf index))
     117        (push (dsd-name slot) elements)
     118        (incf index)))
     119    (setf elements (nreverse elements))
     120    (when *dd-named*
     121      (push (list 'quote *dd-name*) elements))
     122
    108123    (cond ((eq *dd-type* 'list)
    109124           `((defun ,constructor-name ,keys
     
    155170                 (typep object ',*dd-name*))))))))
    156171
    157 (defun get-slot-accessor (slot)
    158   (when *dd-initial-offset*
    159     (incf slot *dd-initial-offset*))
     172(defun get-slot-accessor (index)
     173;;   (when *dd-initial-offset*
     174;;     (incf index *dd-initial-offset*))
    160175  (when *dd-named*
    161     (incf slot))
     176    (incf index))
    162177  (cond ((eq *dd-type* 'list)
    163          `(lambda (instance) (elt instance ,slot)))
     178         `(lambda (instance) (elt instance ,index)))
    164179        ((or (eq *dd-type* 'vector)
    165180             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    166          `(lambda (instance) (aref instance ,slot)))
     181         `(lambda (instance) (aref instance ,index)))
    167182        (t
    168          (case slot
     183         (case index
    169184           (0 #'%structure-ref-0)
    170185           (1 #'%structure-ref-1)
    171186           (2 #'%structure-ref-2)
    172187           (t
    173             `(lambda (instance) (%structure-ref instance ,slot)))))))
    174 
    175 (defun get-slot-mutator (slot)
    176   (when *dd-initial-offset*
    177     (incf slot *dd-initial-offset*))
     188            `(lambda (instance) (%structure-ref instance ,index)))))))
     189
     190(defun get-slot-mutator (index)
     191;;   (when *dd-initial-offset*
     192;;     (incf index *dd-initial-offset*))
    178193  (when *dd-named*
    179     (incf slot))
     194    (incf index))
    180195  (cond ((eq *dd-type* 'list)
    181          `(lambda (instance value) (%set-elt instance ,slot value)))
     196         `(lambda (instance value) (%set-elt instance ,index value)))
    182197        ((or (eq *dd-type* 'vector)
    183198             (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    184          `(lambda (instance value) (%aset instance ,slot value)))
     199         `(lambda (instance value) (%aset instance ,index value)))
    185200        (t
    186          (case slot
     201         (case index
    187202           (0 #'%structure-set-0)
    188203           (1 #'%structure-set-1)
    189204           (2 #'%structure-set-2)
    190205           (t
    191             `(lambda (instance value) (%structure-set instance ,slot value)))))))
     206            `(lambda (instance value) (%structure-set instance ,index value)))))))
    192207
    193208(defun define-access-function (slot-name index)
     
    203218        (result ()))
    204219    (dolist (slot *dd-slots*)
    205 ;;       (let ((slot-name (getf slot :name)))
    206       (let ((slot-name (dsd-name slot)))
    207         (setf result (nconc result (define-access-function slot-name index))))
     220      (let ((slot-name (dsd-name slot))
     221            (expected (dsd-index slot)))
     222        (unless (eql index expected)
     223          (format t "index = ~S expected = ~S~%" index expected))
     224;;         (setf result (nconc result (define-access-function slot-name index))))
     225        (setf result (nconc result (define-access-function slot-name expected))))
    208226      (incf index))
    209227    result))
     
    305323        (push slot-description *dd-direct-slots*)))
    306324    (setf *dd-direct-slots* (nreverse *dd-direct-slots*))
    307     (if *dd-include*
    308         (let* ((def (get (car *dd-include*) 'structure-definition))
    309                (included-slots (dd-slots def)))
    310           (setf *dd-slots* (append included-slots *dd-direct-slots*)))
    311         (setf *dd-slots* *dd-direct-slots*))
     325
     326    (let ((index 0))
     327      (if *dd-include*
     328          (let* ((dd (get (car *dd-include*) 'structure-definition))
     329                 (initial-offset (dd-initial-offset dd))
     330                 (included-slots (dd-slots dd)))
     331            (when initial-offset
     332              (incf index initial-offset))
     333            (setf *dd-slots* (append included-slots *dd-direct-slots*))
     334            (incf index (length included-slots)))
     335          (setf *dd-slots* *dd-direct-slots*))
     336      (when *dd-initial-offset*
     337        (incf index *dd-initial-offset*))
     338      (dolist (slot *dd-direct-slots*)
     339        (setf (dsd-index slot) index)
     340        (incf index)))
     341
    312342    `(progn
    313343       (setf (get ',*dd-name* 'structure-definition)
Note: See TracChangeset for help on using the changeset viewer.