1 | ;;; defstruct.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003 Peter Graves |
---|
4 | ;;; $Id: defstruct.lisp,v 1.25 2003-10-05 15:36:54 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "SYSTEM") |
---|
21 | |
---|
22 | (defvar *ds-name*) |
---|
23 | (defvar *ds-conc-name*) |
---|
24 | (defvar *ds-constructors*) |
---|
25 | (defvar *ds-copier*) |
---|
26 | (defvar *ds-named*) |
---|
27 | (defvar *ds-predicate*) |
---|
28 | (defvar *ds-print-function*) |
---|
29 | |
---|
30 | (defun define-constructor (constructor slots) |
---|
31 | (let* ((constructor-name (intern (car constructor))) |
---|
32 | (slot-names (mapcar #'(lambda (x) (if (atom x) x (car x))) slots)) |
---|
33 | (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots)) |
---|
34 | (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits)) |
---|
35 | (keys (cons '&key slot-descriptions))) |
---|
36 | `((defun ,constructor-name ,keys |
---|
37 | (%make-structure ',*ds-name* (list ,@slot-names)))))) |
---|
38 | |
---|
39 | (defun default-constructor-name () |
---|
40 | (concatenate 'string "MAKE-" (symbol-name *ds-name*))) |
---|
41 | |
---|
42 | (defun define-constructors (slots) |
---|
43 | (if *ds-constructors* |
---|
44 | (let ((results ())) |
---|
45 | (dolist (constructor *ds-constructors*) |
---|
46 | (when (car constructor) |
---|
47 | (setf results (append results (define-constructor constructor slots))))) |
---|
48 | results) |
---|
49 | (define-constructor (cons (default-constructor-name) nil) slots))) |
---|
50 | |
---|
51 | (defun define-predicate () |
---|
52 | (when *ds-predicate* |
---|
53 | (let ((pred (intern *ds-predicate*))) |
---|
54 | `((defun ,pred (object) |
---|
55 | (typep object ',*ds-name*)))))) |
---|
56 | |
---|
57 | |
---|
58 | (defmacro get-slot-accessor (slot) |
---|
59 | (case slot |
---|
60 | (0 #'%structure-ref-0) |
---|
61 | (1 #'%structure-ref-1) |
---|
62 | (2 #'%structure-ref-2) |
---|
63 | (t |
---|
64 | `(lambda (instance) (%structure-ref instance ,slot))))) |
---|
65 | |
---|
66 | (defmacro get-slot-mutator (slot) |
---|
67 | (case slot |
---|
68 | (0 #'%structure-set-0) |
---|
69 | (1 #'%structure-set-1) |
---|
70 | (2 #'%structure-set-2) |
---|
71 | (t |
---|
72 | `(lambda (instance value) (%structure-set instance ,slot value))))) |
---|
73 | |
---|
74 | (defun define-access-function (slot-name index) |
---|
75 | (let ((accessor |
---|
76 | (if *ds-conc-name* |
---|
77 | (intern (concatenate 'string (symbol-name *ds-conc-name*) (symbol-name slot-name))) |
---|
78 | slot-name))) |
---|
79 | `((setf (symbol-function ',accessor) (get-slot-accessor ,index)) |
---|
80 | (%put ',accessor 'setf-inverse (get-slot-mutator ,index))))) |
---|
81 | |
---|
82 | (defun define-access-functions (slots) |
---|
83 | (let ((index 0) |
---|
84 | (result ())) |
---|
85 | (dolist (slot slots) |
---|
86 | (let ((slot-name (if (atom slot) slot (car slot)))) |
---|
87 | (setf result (append result (define-access-function slot-name index)))) |
---|
88 | (incf index)) |
---|
89 | result)) |
---|
90 | |
---|
91 | (defun define-copier () |
---|
92 | (let ((copier (intern (concatenate 'string "COPY-" (symbol-name *ds-name*))))) |
---|
93 | `((setf (fdefinition ',copier) #'copy-structure)))) |
---|
94 | |
---|
95 | (defun parse-1-option (option) |
---|
96 | (case (car option) |
---|
97 | (:conc-name |
---|
98 | (setf *ds-conc-name* (if (symbolp (cadr option)) |
---|
99 | (cadr option) |
---|
100 | (make-symbol (string (cadr option)))))) |
---|
101 | (:constructor |
---|
102 | (let* ((args (cdr option)) |
---|
103 | (numargs (length args)) |
---|
104 | name arglist) |
---|
105 | (case numargs |
---|
106 | (0 ; Use default name. |
---|
107 | (setf name (default-constructor-name)) |
---|
108 | (setf arglist nil) |
---|
109 | (push (list name arglist) *ds-constructors*)) |
---|
110 | (1 |
---|
111 | (if (null (car args)) |
---|
112 | (setf name nil) ; No constructor. |
---|
113 | (setf name (symbol-name (car args)))) |
---|
114 | (setf arglist nil) |
---|
115 | (push (list name arglist) *ds-constructors*)) |
---|
116 | (2)))) |
---|
117 | (:predicate |
---|
118 | (when (= (length option) 2) |
---|
119 | (if (null (cadr option)) |
---|
120 | (setf *ds-predicate* nil) |
---|
121 | (setf *ds-predicate* (symbol-name (cadr option)))))))) |
---|
122 | |
---|
123 | (defun parse-name-and-options (name-and-options) |
---|
124 | (setf *ds-name* (car name-and-options)) |
---|
125 | (setf *ds-conc-name* (make-symbol (concatenate 'string (symbol-name *ds-name*) "-"))) |
---|
126 | (setf *ds-predicate* (concatenate 'string (symbol-name *ds-name*) "-P")) |
---|
127 | (let ((options (cdr name-and-options))) |
---|
128 | (dolist (option options) |
---|
129 | (cond ((consp option) |
---|
130 | (parse-1-option option)) |
---|
131 | ((eq option :named) |
---|
132 | (setf *ds-named* t)) |
---|
133 | ((member option '(:constructor :copier :predicate :named |
---|
134 | :conc-name)) |
---|
135 | (parse-1-option (list option))) |
---|
136 | (t |
---|
137 | (error "unrecognized DEFSTRUCT option: ~S" option)))))) |
---|
138 | |
---|
139 | (defmacro defstruct (name-and-options &rest slots) |
---|
140 | (let ((*ds-name* nil) |
---|
141 | (*ds-conc-name* nil) |
---|
142 | (*ds-constructors* nil) |
---|
143 | (*ds-copier* nil) |
---|
144 | (*ds-predicate* nil) |
---|
145 | (*ds-print-function* nil)) |
---|
146 | (parse-name-and-options (if (atom name-and-options) |
---|
147 | (list name-and-options) |
---|
148 | name-and-options)) |
---|
149 | (when (stringp (car slots)) |
---|
150 | (setf (documentation *ds-name* 'structure) (pop slots))) |
---|
151 | `(progn |
---|
152 | (make-structure-class ',*ds-name*) |
---|
153 | ,@(define-constructors slots) |
---|
154 | ,@(define-predicate) |
---|
155 | ,@(define-access-functions slots) |
---|
156 | ,@(define-copier) |
---|
157 | ',*ds-name*))) |
---|
158 | |
---|
159 | (provide 'defstruct) |
---|