Ignore:
Timestamp:
11/18/03 01:55:51 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4821 r4822  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.31 2003-11-18 01:29:23 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.32 2003-11-18 01:55:51 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    3535         (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
    3636         (keys (cons '&key slot-descriptions)))
    37     (case *ds-type*
    38       (LIST
    39        (if *ds-named*
     37    (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)))))
     43          ((or (eq *ds-type* 'vector)
     44               (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)))))
     50          (t
    4051           `((defun ,constructor-name ,keys
    41                (list ',*ds-name* ,@slot-names)))
    42            `((defun ,constructor-name ,keys
    43                (list ,@slot-names)))))
    44       (t
    45        `((defun ,constructor-name ,keys
    46            (%make-structure ',*ds-name* (list ,@slot-names))))))))
     52               (%make-structure ',*ds-name* (list ,@slot-names))))))))
    4753
    4854(defun default-constructor-name ()
     
    6268             (or *ds-named* (null *ds-type*)))
    6369    (let ((pred (intern *ds-predicate*)))
    64       (case *ds-type*
    65         (LIST
    66          `((defun ,pred (object)
    67              (and (consp object) (eq (car object) ',*ds-name*)))))
     70      (cond ((eq *ds-type* 'list)
     71             `((defun ,pred (object)
     72                 (and (consp object) (eq (car object) ',*ds-name*)))))
     73            ((or (eq *ds-type* 'vector)
     74                 (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     75             `((defun ,pred (object)
     76                 (and (vectorp object)
     77                      (> (length object) 0)
     78                      (eq (aref object 0) ',*ds-name*)))))
     79            (t
     80             `((defun ,pred (object)
     81                 (typep object ',*ds-name*))))))))
     82
     83(defun get-slot-accessor (slot)
     84  (cond ((eq *ds-type* 'list)
     85         (when *ds-named*
     86           (incf slot))
     87         `(lambda (instance) (elt instance ,slot)))
     88        ((or (eq *ds-type* 'vector)
     89             (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     90         `(lambda (instance) (aref instance ,slot)))
    6891        (t
    69          `((defun ,pred (object)
    70              (typep object ',*ds-name*))))))))
    71 
    72 (defun get-slot-accessor (slot)
    73   (case *ds-type*
    74     (LIST
    75      (when *ds-named*
    76        (incf slot))
    77      `(lambda (instance) (elt instance ,slot)))
    78     (t
    79      (case slot
    80        (0 #'%structure-ref-0)
    81        (1 #'%structure-ref-1)
    82        (2 #'%structure-ref-2)
    83        (t
    84         `(lambda (instance) (%structure-ref instance ,slot)))))))
     92         (case slot
     93           (0 #'%structure-ref-0)
     94           (1 #'%structure-ref-1)
     95           (2 #'%structure-ref-2)
     96           (t
     97            `(lambda (instance) (%structure-ref instance ,slot)))))))
    8598
    8699(defun get-slot-mutator (slot)
    87   (case *ds-type*
    88     (LIST
    89      (when *ds-named*
    90        (incf slot))
    91      `(lambda (instance value) (%set-elt instance ,slot value)))
    92     (t
    93      (case slot
    94        (0 #'%structure-set-0)
    95        (1 #'%structure-set-1)
    96        (2 #'%structure-set-2)
    97        (t
    98         `(lambda (instance value) (%structure-set instance ,slot value)))))))
     100  (cond ((eq *ds-type* 'list)
     101         (when *ds-named*
     102           (incf slot))
     103         `(lambda (instance value) (%set-elt instance ,slot value)))
     104        ((or (eq *ds-type* 'vector)
     105             (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     106         `(lambda (instance value) (%aset instance ,slot value)))
     107        (t
     108         (case slot
     109           (0 #'%structure-set-0)
     110           (1 #'%structure-set-1)
     111           (2 #'%structure-set-2)
     112           (t
     113            `(lambda (instance value) (%structure-set instance ,slot value)))))))
    99114
    100115(defun define-access-function (slot-name index)
     
    117132(defun define-copier ()
    118133  (when *ds-copier*
    119     (case *ds-type*
    120       (LIST
    121        `((setf (fdefinition ',*ds-copier*) #'copy-list)))
    122       (t
    123        `((setf (fdefinition ',*ds-copier*) #'copy-structure))))))
     134    (cond ((eq *ds-type* 'list)
     135           `((setf (fdefinition ',*ds-copier*) #'copy-list)))
     136          ((or (eq *ds-type* 'vector)
     137               (and (consp *ds-type*) (eq (car *ds-type*) 'vector)))
     138           `((setf (fdefinition ',*ds-copier*) #'copy-seq)))
     139          (t
     140           `((setf (fdefinition ',*ds-copier*) #'copy-structure))))))
    124141
    125142(defun parse-1-option (option)
Note: See TracChangeset for help on using the changeset viewer.