Changeset 4858


Ignore:
Timestamp:
11/21/03 02:41:22 (18 years ago)
Author:
piso
Message:

Work in progress.

File:
1 edited

Legend:

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

    r4856 r4858  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.37 2003-11-21 01:19:32 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.38 2003-11-21 02:41:22 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    1919
    2020(in-package "SYSTEM")
     21
     22(defmacro ds-name (x)           `(aref ,x  0))
     23(defmacro ds-conc-name (x)      `(aref ,x  1))
     24(defmacro ds-constructors (x)   `(aref ,x  2))
     25(defmacro ds-copier (x)         `(aref ,x  3))
     26(defmacro ds-include (x)        `(aref ,x  4))
     27(defmacro ds-type (x)           `(aref ,x  5))
     28(defmacro ds-named (x)          `(aref ,x  6))
     29(defmacro ds-initial-offset (x) `(aref ,x  7))
     30(defmacro ds-predicate (x)      `(aref ,x  8))
     31(defmacro ds-print-function (x) `(aref ,x  9))
     32(defmacro ds-direct-slots (x)   `(aref ,x 10))
     33(defmacro ds-slots (x)          `(aref ,x 11))
     34
     35(defun make-defstruct-definition (&key name
     36                                       conc-name
     37                                       constructors
     38                                       copier
     39                                       include
     40                                       type
     41                                       named
     42                                       initial-offset
     43                                       predicate
     44                                       print-function
     45                                       direct-slots
     46                                       slots)
     47  (let ((def (make-array 12)))
     48    (setf (ds-name def) name
     49          (ds-conc-name def) conc-name
     50          (ds-constructors def) constructors
     51          (ds-copier def) copier
     52          (ds-include def) include
     53          (ds-type def) type
     54          (ds-named def) named
     55          (ds-initial-offset def) initial-offset
     56          (ds-predicate def) predicate
     57          (ds-print-function def) print-function
     58          (ds-direct-slots def) direct-slots
     59          (ds-slots def) slots)
     60    def))
    2161
    2262(defvar *ds-name*)
     
    243283        (push slot-description *ds-direct-slots*)))
    244284    (setf *ds-direct-slots* (nreverse *ds-direct-slots*))
    245     (setf *ds-slots* *ds-direct-slots*)
     285    (if *ds-include*
     286        (let* ((def (get (car *ds-include*) 'structure-definition))
     287               (included-slots (ds-slots def)))
     288          (setf *ds-slots* (append included-slots *ds-direct-slots*)))
     289        (setf *ds-slots* *ds-direct-slots*))
    246290    `(progn
     291       (setf (get ',*ds-name* 'structure-definition)
     292             (make-defstruct-definition :name ',*ds-name*
     293                                        :conc-name ',*ds-conc-name*
     294                                        :constructors ',*ds-constructors*
     295                                        :copier ',*ds-copier*
     296                                        :include ',*ds-include*
     297                                        :type ',*ds-type*
     298                                        :named ,*ds-named*
     299                                        :initial-offset ,*ds-initial-offset*
     300                                        :predicate ,*ds-predicate*
     301                                        :print-function ,*ds-print-function*
     302                                        :direct-slots ',*ds-direct-slots*
     303                                        :slots ',*ds-slots*))
    247304       (make-structure-class ',*ds-name* ',*ds-direct-slots* ',*ds-slots*)
    248305       ,@(define-constructors)
Note: See TracChangeset for help on using the changeset viewer.