Changeset 4856


Ignore:
Timestamp:
11/21/03 01:19:32 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4854 r4856  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.36 2003-11-20 19:04:24 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.37 2003-11-21 01:19:32 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2424(defvar *ds-constructors*)
    2525(defvar *ds-copier*)
     26(defvar *ds-include*)
    2627(defvar *ds-type*)
    2728(defvar *ds-named*)
     
    3031(defvar *ds-print-function*)
    3132(defvar *ds-direct-slots*)
     33(defvar *ds-slots*)
    3234
    3335(defun define-constructor (constructor)
     
    3537         (keys ())
    3638         (elements ()))
    37     (dolist (slot *ds-direct-slots*)
     39    (dolist (slot *ds-slots*)
    3840      (let ((name (getf slot :name))
    3941            (initform (getf slot :initform)))
     
    140142      (%put ',accessor 'setf-inverse ,(get-slot-mutator index )))))
    141143
    142 (defun define-access-functions (slots)
     144(defun define-access-functions ()
    143145  (let ((index 0)
    144146        (result ()))
    145     (dolist (slot slots)
    146       (let ((slot-name (if (atom slot) slot (car slot))))
     147    (dolist (slot *ds-slots*)
     148      (let ((slot-name (getf slot :name)))
    147149        (setf result (nconc result (define-access-function slot-name index))))
    148150      (incf index))
     
    186188       (when (= numargs 1)
    187189          (setf *ds-copier* (car args)))))
     190    (:include
     191     (setf *ds-include* (cdr option)))
    188192    (:initial-offset
    189193     (setf *ds-initial-offset* (cadr option)))
     
    220224        (*ds-constructors* nil)
    221225        (*ds-copier* nil)
     226        (*ds-include* nil)
    222227        (*ds-type* nil)
    223228        (*ds-named* nil)
     
    225230        (*ds-predicate* nil)
    226231        (*ds-print-function* nil)
    227         (*ds-direct-slots* ()))
     232        (*ds-direct-slots* ())
     233        (*ds-slots* ()))
    228234    (parse-name-and-options (if (atom name-and-options)
    229235                                (list name-and-options)
     
    237243        (push slot-description *ds-direct-slots*)))
    238244    (setf *ds-direct-slots* (nreverse *ds-direct-slots*))
     245    (setf *ds-slots* *ds-direct-slots*)
    239246    `(progn
    240        (make-structure-class ',*ds-name* ',*ds-direct-slots*)
     247       (make-structure-class ',*ds-name* ',*ds-direct-slots* ',*ds-slots*)
    241248       ,@(define-constructors)
    242249       ,@(define-predicate)
    243        ,@(define-access-functions slots)
     250       ,@(define-access-functions)
    244251       ,@(define-copier)
    245252       ',*ds-name*)))
Note: See TracChangeset for help on using the changeset viewer.