![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to record.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib|
Return to record.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / lisplib |
1.1 root 1: (setq rcs-common0-
2: "$Header: record.l,v 1.3 84/02/29 19:33:50 jkf Exp $")
3:
4: ;; -[Mon Feb 20 15:00:52 1984 by jkf]-
5: ;; simple record package
6: ;;
7:
8: (eval-when (compile)
9: (or (get 'record 'version) (load 'record)))
10:
11: (defvar record-pkg-indicator 'record-package-dr-record)
12:
13: (declare (macros nil))
14:
15: ;; internal macro
16: (defmacro dr-error (message &rest args)
17: ;; print an error preceeded by 'defrecord'
18: ;; internal use only
19: `(error ',(concat "defrecord: " message) ,@args))
20:
21:
22: ;(defrecord dr-record
23: ; name ; name of record
24: ; storage ; 'list' or 'vector'
25: ; options ; subset of 'named', 'access-check'
26: ; fields ; list of dr-field records
27: ;)
28:
29: (eval-when (compile eval)
30: (putprop 'dr-record
31: '(dr-record list nil ((fields 3 nil)
32: (options 2 nil)
33: (storage 1 nil)
34: (name 0 nil)))
35: record-pkg-indicator))
36: (defmacro make-dr-record (&rest args) (record-pkg-construct 'dr-record args))
37: (defmacro dr-record-storage (arg) `(nth 1 ,arg))
38: (defmacro dr-record-options (arg) `(nth 2 ,arg))
39: (defmacro dr-record-fields (arg) `(nth 3 ,arg))
40:
41: ;(defrecord dr-field
42: ; ;; internal structure used to store info on fields
43: ; name
44: ; offset
45: ; defaultvalue)
46:
47: (eval-when (compile eval)
48: (putprop 'dr-field
49: '(dr-field list nil ((defaultvalue 2 nil)
50: (offset 1 nil)
51: (name 0 nil)))
52: record-pkg-indicator))
53: (defmacro make-dr-field (&rest args) (record-pkg-construct 'dr-field args))
54:
55: (defmacro dr-field-name (arg) `(nth 0 ,arg))
56: (defmacro dr-field-offset (arg) `(nth 1 ,arg))
57: (defmacro dr-field-defaultvalue (arg) `(nth 2 ,arg))
58:
59: ;; internal functions (called by macros)
60:
61: (defun record-pkg-construct (recname args)
62: ;; called to expand a make- form.
63: ;; recname is the name of a record
64:
65: ; convert to an assq list, verifing field names
66: (let* ((dr-record (get recname record-pkg-indicator))
67: (fields (dr-record-fields dr-record))
68: (given))
69: (do ((xx args (cddr xx)))
70: ((null xx))
71: (if (assq (car xx) fields)
72: then (push (cons (car xx) (cadr xx)) given)
73: else (dr-error " for record " recname
74: ", this field doesn't exist " (car xx))))
75: ;; now build a list of values.
76: ;; use the fact that the fields list is in the reverse order
77: (do ((xx fields (cdr xx))
78: (got)
79: (res))
80: ((null xx)
81: ;; now we have a list of values to compute to build this
82: ;; form.
83: (caseq (dr-record-storage dr-record)
84: (list `(list ,@res))
85: (vector `(vector ,@res))
86: (t (error "record package is confused about storage type "))))
87: (if (setq got (assq (dr-field-name (car xx)) given))
88: then (push (cdr got) res) ; given value
89: else (push (dr-field-defaultvalue (car xx))
90: res)))))
91:
92:
93:
94: (defun record-pkg-access (recname fieldname arg)
95: ;; return code access the given field in the given record
96: (let ((dr-record (get recname record-pkg-indicator))
97: (recnamefield)
98: (fieldinfo)
99: (options)
100: (storage))
101: (setq fieldinfo (assq fieldname (dr-record-fields dr-record)))
102: (setq options (dr-record-options dr-record))
103: (setq storage (dr-record-storage dr-record))
104: (if (null fieldinfo)
105: then (dr-error "internal error: can't find field " fieldname
106: " in record " recname))
107: (if (memq 'access-check options)
108: then (setq recnamefield (assq '-record-field-name-
109: (dr-record-fields dr-record)))
110: `((lambda (defrecord-acma)
111: (cond ((not (eq ',recname
112: ,(dr-accessor storage
113: (dr-field-offset
114: recnamefield)
115: 'defrecord-acma)))
116: (record-pkg-illegal-access ',recname ',fieldname
117: defrecord-acma))
118: (t ,(dr-accessor storage
119: (dr-field-offset fieldinfo)
120: 'defrecord-acma))))
121: ,arg)
122: else (dr-accessor storage (dr-field-offset fieldinfo) arg))))
123:
124:
125: (defun dr-accessor (class index obj)
126: ;; determine the correct field accessor to get the index'th element
127: ;; from obj, give the storage type class (either list or vector).
128: ;;
129: (caseq class
130: (list `(nth ,index ,obj))
131: (vector `(vref ,obj ,index))
132: (t (error "record package: illegal storage class " class))))
133:
134: (defun record-pkg-illegal-access (recname fieldname value)
135: (error "Unable to access field " fieldname " of record " recname
136: " because this is not an instance of that record: "
137: value))
138:
139:
140:
141:
142: (defun defrecord-name (form)
143: ;; user callable function to return the record name of
144: ;; a record
145: (if (defrecord-namedp form)
146: then (if (dtpr form) then (cadr form)
147: elseif (vectorp form)
148: then (vref form 1))
149: else (error "record-name: this record doesn't have a name " form)))
150:
151: (defun defrecord-namedp (form)
152: ;; return t iff form is a named record
153: (let (name)
154: (and (or (and (dtpr form)
155: (cdr form)
156: (progn (setq name (cadr form)) t)
157: (symbolp name))
158: (and (vectorp form)
159: (>& (vsize form) 1)
160: (progn (setq name (vref form 1)) t)
161: (symbolp name)))
162: (get name record-pkg-indicator)
163: t)))
164:
165: ;; external functions
166: ;; The following functions are user callable
167:
168:
169: (declare (macros t))
170:
171: (defvar defrecord-default-flags nil) ; what is assumed in the flag field
172:
173: (defmacro defrecord (&rest form)
174: ;; user callable function
175: (if (null form)
176: then (error "defrecord: missing record name in " form))
177:
178: (let ((name (car form))
179: (args (cdr form))
180: (fields)
181: (nameargs)
182: (givenoptions defrecord-default-flags)
183: (savedoptions)
184: ;;options
185: (namedp)(access-checkp) (vectorp))
186: (if (dtpr name)
187: then (setq givenoptions (append givenoptions (cdr name))
188: name (car name)))
189:
190: (if (not (symbolp name))
191: then (dr-error "non symbol record name " name))
192:
193: ;; process given options
194: (do ((xx givenoptions (cdr xx)))
195: ((null xx))
196: (caseq (car xx)
197: (named (setq namedp t))
198: (access-check (setq access-checkp t))
199: (vector (setq vectorp t))
200: (t ; ignore
201: )))
202: ;; look for conflicting options
203: (if (and access-checkp (not namedp))
204: then (error "defrecord: Can't specify access-check without also specifying named " form))
205:
206: (if namedp then (push 'named savedoptions))
207: (if access-checkp then (push 'access-check savedoptions))
208:
209: (if namedp
210: then (let ((namefield `(-record-field-name- ',name)))
211: (if args
212: then (setq args (cons (car args)
213: (cons namefield
214: (cdr args))))
215: else (setq args (list namefield)))))
216:
217: (do ((xx args (cdr xx))
218: (off 0 (1+ off)))
219: ((null xx))
220: (if (dtpr (car xx))
221: then (push (make-dr-field
222: name (caar xx)
223: offset off
224: defaultvalue (cadar xx))
225: fields)
226: else (push (make-dr-field
227: name (car xx)
228: offset off)
229: fields)))
230:
231:
232: ; return a progn compile of an accessor and a collection
233: ; of accessors
234: `(progn 'compile
235: (eval-when (compile load eval)
236: (putprop ',name ',(make-dr-record
237: name name
238: storage (if vectorp
239: then 'vector
240: else 'list)
241: options savedoptions
242: fields fields)
243: ',record-pkg-indicator))
244: (defmacro ,(concat 'make- name) (&rest args)
245: (record-pkg-construct ',name args))
246: ,@(mapcar '(lambda (dr-field)
247: `(defmacro ,(concat name
248: '-
249: (dr-field-name dr-field))
250: (arg)
251: (record-pkg-access
252: ',name
253: ',(dr-field-name dr-field)
254: arg)))
255: fields))))
256:
257:
258: (putprop 'record t 'version)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.