Changeset 4823


Ignore:
Timestamp:
11/18/03 02:58:20 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4822 r4823  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.32 2003-11-18 01:55:51 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.33 2003-11-18 02:58:20 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2626(defvar *ds-type*)
    2727(defvar *ds-named*)
     28(defvar *ds-initial-offset*)
    2829(defvar *ds-predicate*)
    2930(defvar *ds-print-function*)
     
    3435         (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots))
    3536         (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
    36          (keys (cons '&key slot-descriptions)))
     37         (keys (cons '&key slot-descriptions))
     38         (elements slot-names))
     39    (when *ds-named*
     40      (push (list 'quote *ds-name*) elements))
     41    (when *ds-initial-offset*
     42      (dotimes (i *ds-initial-offset*)
     43        (push nil elements)))
    3744    (cond ((eq *ds-type* 'list)
    38            (if *ds-named*
    39                `((defun ,constructor-name ,keys
    40                    (list ',*ds-name* ,@slot-names)))
    41                `((defun ,constructor-name ,keys
    42                    (list ,@slot-names)))))
     45           `((defun ,constructor-name ,keys
     46               (list ,@elements))))
    4347          ((or (eq *ds-type* 'vector)
    4448               (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
    45            (if *ds-named*
    46                `((defun ,constructor-name ,keys
    47                    (vector ',*ds-name* ,@slot-names)))
    48                `((defun ,constructor-name ,keys
    49                    (vector ,@slot-names)))))
     49           (let ((element-type (if (consp *ds-type*) (cadr *ds-type*) t)))
     50             `((defun ,constructor-name ,keys
     51                 (make-array ,(length elements)
     52                             :element-type ',element-type
     53                             :initial-contents (list ,@elements))))))
    5054          (t
    5155           `((defun ,constructor-name ,keys
     
    8286
    8387(defun get-slot-accessor (slot)
     88  (when *ds-initial-offset*
     89    (incf slot *ds-initial-offset*))
     90  (when *ds-named*
     91    (incf slot))
    8492  (cond ((eq *ds-type* 'list)
    85          (when *ds-named*
    86            (incf slot))
    8793         `(lambda (instance) (elt instance ,slot)))
    8894        ((or (eq *ds-type* 'vector)
     
    98104
    99105(defun get-slot-mutator (slot)
     106  (when *ds-initial-offset*
     107    (incf slot *ds-initial-offset*))
     108  (when *ds-named*
     109    (incf slot))
    100110  (cond ((eq *ds-type* 'list)
    101          (when *ds-named*
    102            (incf slot))
    103111         `(lambda (instance value) (%set-elt instance ,slot value)))
    104112        ((or (eq *ds-type* 'vector)
     
    167175       (when (= numargs 1)
    168176          (setf *ds-copier* (car args)))))
     177    (:initial-offset
     178     (setf *ds-initial-offset* (cadr option)))
    169179    (:predicate
    170180     (when (= (length option) 2)
     
    201211        (*ds-type* nil)
    202212        (*ds-named* nil)
     213        (*ds-initial-offset* nil)
    203214        (*ds-predicate* nil)
    204215        (*ds-print-function* nil))
Note: See TracChangeset for help on using the changeset viewer.