Changeset 4854


Ignore:
Timestamp:
11/20/03 19:04:24 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4853 r4854  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.35 2003-11-20 18:42:09 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.36 2003-11-20 19:04:24 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2929(defvar *ds-predicate*)
    3030(defvar *ds-print-function*)
    31 (defvar *ds-slot-descriptions*)
    32 
    33 (defun define-constructor (constructor slots)
     31(defvar *ds-direct-slots*)
     32
     33(defun define-constructor (constructor)
    3434  (let* ((constructor-name (intern (car constructor)))
    35          (slot-names (mapcar #'(lambda (x) (if (atom x) x (car x))) slots))
    36          (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots))
    37          (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
    38          (keys (cons '&key slot-descriptions))
    39          (elements slot-names))
     35         (keys ())
     36         (elements ()))
     37    (dolist (slot *ds-direct-slots*)
     38      (let ((name (getf slot :name))
     39            (initform (getf slot :initform)))
     40        (push (list name initform) keys)
     41        (push name elements)))
     42    (setf keys (cons '&key (nreverse keys)))
     43    (setf elements (nreverse elements))
    4044    (when *ds-named*
    4145      (push (list 'quote *ds-name*) elements))
     
    5559          (t
    5660           `((defun ,constructor-name ,keys
    57                (%make-structure ',*ds-name* (list ,@slot-names))))))))
     61               (%make-structure ',*ds-name* (list ,@elements))))))))
    5862
    5963(defun default-constructor-name ()
    6064  (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
    6165
    62 (defun define-constructors (slots)
     66(defun define-constructors ()
    6367  (if *ds-constructors*
    6468      (let ((results ()))
    6569        (dolist (constructor *ds-constructors*)
    6670          (when (car constructor)
    67             (setf results (nconc results (define-constructor constructor slots)))))
     71            (setf results (nconc results (define-constructor constructor)))))
    6872        results)
    69       (define-constructor (cons (default-constructor-name) nil) slots)))
     73      (define-constructor (cons (default-constructor-name) nil))))
    7074
    7175(defun define-predicate ()
     
    221225        (*ds-predicate* nil)
    222226        (*ds-print-function* nil)
    223         (*ds-slot-descriptions* ()))
     227        (*ds-direct-slots* ()))
    224228    (parse-name-and-options (if (atom name-and-options)
    225229                                (list name-and-options)
     
    231235                                  (list :name slot :initform nil)
    232236                                  (list :name (car slot) :initform (cadr slot)))))
    233         (push slot-description *ds-slot-descriptions*)))
    234     (setf *ds-slot-descriptions* (nreverse *ds-slot-descriptions*))
     237        (push slot-description *ds-direct-slots*)))
     238    (setf *ds-direct-slots* (nreverse *ds-direct-slots*))
    235239    `(progn
    236        (make-structure-class ',*ds-name* ',*ds-slot-descriptions*)
    237        ,@(define-constructors slots)
     240       (make-structure-class ',*ds-name* ',*ds-direct-slots*)
     241       ,@(define-constructors)
    238242       ,@(define-predicate)
    239243       ,@(define-access-functions slots)
Note: See TracChangeset for help on using the changeset viewer.