1 | ;;;-*-Mode: LISP; Package: CCL -*- |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 1994-2001 Digitool, Inc |
---|
4 | ;;; This file is part of OpenMCL. |
---|
5 | ;;; |
---|
6 | ;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public |
---|
7 | ;;; License , known as the LLGPL and distributed with OpenMCL as the |
---|
8 | ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, |
---|
9 | ;;; which is distributed with OpenMCL as the file "LGPL". Where these |
---|
10 | ;;; conflict, the preamble takes precedence. |
---|
11 | ;;; |
---|
12 | ;;; OpenMCL is referenced in the preamble as the "LIBRARY." |
---|
13 | ;;; |
---|
14 | ;;; The LLGPL is also available online at |
---|
15 | ;;; http://opensource.franz.com/preamble.html |
---|
16 | |
---|
17 | ;; Level-2.lisp |
---|
18 | |
---|
19 | (in-package "CCL") |
---|
20 | |
---|
21 | (eval-when (eval compile) |
---|
22 | (require "LEVEL-2") |
---|
23 | (require "BACKQUOTE") |
---|
24 | (require "DEFSTRUCT-MACROS")) |
---|
25 | |
---|
26 | |
---|
27 | |
---|
28 | (eval-when (eval compile) |
---|
29 | (require "LISPEQU")) |
---|
30 | |
---|
31 | |
---|
32 | |
---|
33 | |
---|
34 | |
---|
35 | |
---|
36 | |
---|
37 | |
---|
38 | ; This incredibly essential thing is part of ANSI CL; put it in the |
---|
39 | ; right package someday. |
---|
40 | ; Like maybe when it says something about doc strings, or otherwise |
---|
41 | ; becomes useful. |
---|
42 | |
---|
43 | (defun parse-macro (name arglist body &optional env) |
---|
44 | (values (parse-macro-1 name arglist body env))) |
---|
45 | |
---|
46 | ; Return a list containing a special declaration for SYM |
---|
47 | ; if SYM is declared special in decls. |
---|
48 | ; This is so we can be pedantic about binding &WHOLE/&ENVIRONMENT args |
---|
49 | ; that have been scarfed out of a macro-like lambda list. |
---|
50 | ; The returned value is supposed to be suitable for splicing ... |
---|
51 | (defun hoist-special-decls (sym decls) |
---|
52 | (when sym |
---|
53 | (dolist (decl decls) |
---|
54 | (dolist (spec (cdr decl)) |
---|
55 | (when (eq (car spec) 'special) |
---|
56 | (dolist (s (%cdr spec)) |
---|
57 | (when (eq s sym) |
---|
58 | (return-from hoist-special-decls `((declare (special ,sym))))))))))) |
---|
59 | |
---|
60 | (defun parse-macro-1 (name arglist body &optional env) |
---|
61 | (parse-macro-internal name arglist body env nil)) |
---|
62 | |
---|
63 | (defun parse-macro-internal (name arglist body env default-initial-value) |
---|
64 | (unless (verify-lambda-list arglist t t t) |
---|
65 | (error "Invalid lambda list ~s" arglist)) |
---|
66 | (multiple-value-bind (lambda-list whole environment) |
---|
67 | (normalize-lambda-list arglist t t) |
---|
68 | (multiple-value-bind (body local-decs doc) |
---|
69 | (parse-body body env t) |
---|
70 | (let ((whole-var (gensym "WHOLE")) |
---|
71 | (env-var (gensym "ENVIRONMENT"))) |
---|
72 | (multiple-value-bind (bindings binding-decls) |
---|
73 | (%destructure-lambda-list lambda-list whole-var nil nil |
---|
74 | :cdr-p t |
---|
75 | :whole-p nil |
---|
76 | :use-whole-var t |
---|
77 | :default-initial-value default-initial-value) |
---|
78 | (when environment |
---|
79 | (setq bindings (nconc bindings (list `(,environment ,env-var))))) |
---|
80 | (when whole |
---|
81 | (setq bindings (nconc bindings (list `(,whole ,whole-var))))) |
---|
82 | (values |
---|
83 | `(lambda (,whole-var ,env-var) |
---|
84 | (declare (ignorable ,whole-var ,env-var)) |
---|
85 | (block ,name |
---|
86 | (let* ,(nreverse bindings) |
---|
87 | ,@(when binding-decls `((declare ,@binding-decls))) |
---|
88 | ,@local-decs |
---|
89 | ,@body))) |
---|
90 | doc)))))) |
---|
91 | |
---|
92 | |
---|
93 | (defun %destructure-lambda-list (lambda-list wholeform lets decls |
---|
94 | &key cdr-p (whole-p t) use-whole-var default-initial-value) |
---|
95 | (unless (and (listp lambda-list) |
---|
96 | (verify-lambda-list lambda-list t whole-p)) |
---|
97 | (signal-simple-program-error "Invalid lambda list: ~s" lambda-list)) |
---|
98 | (multiple-value-bind (normalized whole) (normalize-lambda-list |
---|
99 | lambda-list whole-p) |
---|
100 | (let* ((argstate :required) |
---|
101 | (allow-other-keys nil) |
---|
102 | (rest-arg-name nil) |
---|
103 | (w (if use-whole-var wholeform (or whole (gensym "WHOLE")))) |
---|
104 | (argptr (gensym "ARGS")) |
---|
105 | (has-&key nil) |
---|
106 | (most-recent-binding nil) |
---|
107 | (keywords ()) |
---|
108 | (first-keyword-init ()) |
---|
109 | (restp nil)) |
---|
110 | (labels ((simple-var (var &optional (initform `,default-initial-value)) |
---|
111 | (let* ((binding `(,var ,initform))) |
---|
112 | (unless (eq argstate :aux) |
---|
113 | (setq most-recent-binding binding)) |
---|
114 | (push binding lets) |
---|
115 | binding)) |
---|
116 | (structured-var (context sub-lambda-list initform) |
---|
117 | (let* ((v (gensym (string context)))) |
---|
118 | (simple-var v initform) |
---|
119 | (multiple-value-setq (lets decls) |
---|
120 | (%destructure-lambda-list |
---|
121 | sub-lambda-list |
---|
122 | v |
---|
123 | lets |
---|
124 | decls |
---|
125 | :default-initial-value default-initial-value |
---|
126 | )) |
---|
127 | v))) |
---|
128 | (unless use-whole-var |
---|
129 | (if (atom w) |
---|
130 | (simple-var w wholeform) |
---|
131 | (progn |
---|
132 | (setq w (structured-var "WHOLE" w (if cdr-p `(cdr ,wholeform) wholeform)) |
---|
133 | cdr-p nil)))) |
---|
134 | (simple-var argptr `(make-destructure-state ,@(if cdr-p `((cdr ,w)) `(,w)) ,w ',lambda-list)) |
---|
135 | (setq most-recent-binding nil) |
---|
136 | (push `(dynamic-extent ,argptr) decls) |
---|
137 | (do* ((tail normalized (cdr tail))) |
---|
138 | ((null tail) |
---|
139 | (if has-&key |
---|
140 | (let* ((key-check-form `(check-keywords |
---|
141 | ',(nreverse keywords) |
---|
142 | ,rest-arg-name ,allow-other-keys))) |
---|
143 | (if first-keyword-init |
---|
144 | (rplaca (cdr first-keyword-init) |
---|
145 | `(progn |
---|
146 | ,key-check-form |
---|
147 | ,(cadr first-keyword-init))) |
---|
148 | (let* ((check-var (gensym "CHECK"))) |
---|
149 | (push `(ignorable ,check-var) decls) |
---|
150 | (simple-var check-var key-check-form)))) |
---|
151 | (unless restp |
---|
152 | (let* ((checkform `(%check-extra-arguments ,argptr)) |
---|
153 | (b most-recent-binding) |
---|
154 | (b-init (cadr b))) |
---|
155 | (if b |
---|
156 | (rplaca (cdr b) `(prog1 ,b-init ,checkform)) |
---|
157 | (let* ((junk (gensym "JUNK"))) |
---|
158 | (simple-var junk checkform) |
---|
159 | (push `(ignorable ,junk) decls)))))) |
---|
160 | (values lets decls)) |
---|
161 | (let* ((var (car tail))) |
---|
162 | (cond ((or (eq var '&rest) (eq var '&body)) |
---|
163 | (let* ((r (cadr tail)) |
---|
164 | (init `(destructure-state.current ,argptr))) |
---|
165 | (if (listp r) |
---|
166 | (setq rest-arg-name |
---|
167 | (structured-var "REST" r init)) |
---|
168 | (progn |
---|
169 | (setq rest-arg-name (gensym "REST")) |
---|
170 | (simple-var rest-arg-name init) |
---|
171 | (simple-var r rest-arg-name )))) |
---|
172 | (setq restp t) |
---|
173 | (setq tail (cdr tail))) |
---|
174 | ((eq var '&optional) (setq argstate :optional)) |
---|
175 | ((eq var '&key) |
---|
176 | (setq argstate :key) |
---|
177 | (setq has-&key t) |
---|
178 | (unless restp |
---|
179 | (setq restp t |
---|
180 | rest-arg-name (gensym "KEYS")) |
---|
181 | (push `(ignorable ,rest-arg-name) decls) |
---|
182 | (simple-var rest-arg-name |
---|
183 | `(destructure-state.current ,argptr)))) |
---|
184 | ((eq var '&allow-other-keys) |
---|
185 | (setq allow-other-keys t)) |
---|
186 | ((eq var '&aux) |
---|
187 | (setq argstate :aux)) |
---|
188 | ((listp var) |
---|
189 | (case argstate |
---|
190 | (:required |
---|
191 | (structured-var "REQ" var `(%pop-required-arg-ptr ,argptr))) |
---|
192 | (:optional |
---|
193 | (let* ((variable (car var)) |
---|
194 | (initform (if (cdr var) |
---|
195 | (cadr var) |
---|
196 | `,default-initial-value)) |
---|
197 | (spvar (if (cddr var) |
---|
198 | (caddr var) |
---|
199 | (gensym "OPT-SUPPLIED-P"))) |
---|
200 | (varinit `(if ,spvar |
---|
201 | (%default-optional-value ,argptr) |
---|
202 | ,initform))) |
---|
203 | (simple-var spvar |
---|
204 | `(not (null (destructure-state.current ,argptr)))) |
---|
205 | (if (listp variable) |
---|
206 | (structured-var "OPT" variable varinit) |
---|
207 | (simple-var variable varinit)))) |
---|
208 | (:key |
---|
209 | (let* ((explicit-key (consp (car var))) |
---|
210 | (variable (if explicit-key |
---|
211 | (cadar var) |
---|
212 | (car var))) |
---|
213 | (keyword (if explicit-key |
---|
214 | (caar var) |
---|
215 | (make-keyword variable))) |
---|
216 | (initform (if (cdr var) |
---|
217 | (cadr var) |
---|
218 | `,default-initial-value)) |
---|
219 | (spvar (if (cddr var) |
---|
220 | (caddr var) |
---|
221 | (gensym "KEY-SUPPLIED-P")))) |
---|
222 | (push keyword keywords) |
---|
223 | (let* ((sp-init (simple-var spvar |
---|
224 | `(%keyword-present-p |
---|
225 | ,rest-arg-name |
---|
226 | ',keyword))) |
---|
227 | (var-init `(if ,spvar |
---|
228 | (getf ,rest-arg-name ',keyword) |
---|
229 | ,initform))) |
---|
230 | (unless first-keyword-init |
---|
231 | (setq first-keyword-init sp-init)) |
---|
232 | (if (listp variable) |
---|
233 | (structured-var "KEY" variable var-init) |
---|
234 | (simple-var variable var-init))))) |
---|
235 | (:aux |
---|
236 | (simple-var (car var) (cadr var))) |
---|
237 | (t (error "NYI: ~s" argstate)))) |
---|
238 | ((symbolp var) |
---|
239 | (case argstate |
---|
240 | (:required |
---|
241 | (simple-var var `(%pop-required-arg-ptr ,argptr))) |
---|
242 | (:optional |
---|
243 | (simple-var var `(%default-optional-value ,argptr |
---|
244 | ',default-initial-value))) |
---|
245 | (:key |
---|
246 | (let* ((keyword (make-keyword var))) |
---|
247 | (push keyword keywords) |
---|
248 | (let* ((init (simple-var |
---|
249 | var |
---|
250 | `(getf ,rest-arg-name |
---|
251 | ',keyword |
---|
252 | ,@(if default-initial-value |
---|
253 | `(',default-initial-value)))))) |
---|
254 | (unless first-keyword-init |
---|
255 | (setq first-keyword-init init))))) |
---|
256 | (:aux |
---|
257 | (simple-var var))))))))))) |
---|
258 | |
---|
259 | |
---|
260 | |
---|
261 | |
---|
262 | |
---|
263 | |
---|
264 | (defun apply-to-htab-syms (function pkg-vector) |
---|
265 | (let* ((sym nil) |
---|
266 | (foundp nil)) |
---|
267 | (dotimes (i (uvsize pkg-vector)) |
---|
268 | (declare (fixnum i)) |
---|
269 | (multiple-value-setq (sym foundp) (%htab-symbol pkg-vector i)) |
---|
270 | (when foundp (funcall function sym))))) |
---|
271 | |
---|
272 | (defun iterate-over-external-symbols (pkg-spec function) |
---|
273 | (apply-to-htab-syms function (car (pkg.etab (pkg-arg (or pkg-spec *package*)))))) |
---|
274 | |
---|
275 | (defun iterate-over-present-symbols (pkg-spec function) |
---|
276 | (let ((pkg (pkg-arg (or pkg-spec *package*)))) |
---|
277 | (apply-to-htab-syms function (car (pkg.etab pkg))) |
---|
278 | (apply-to-htab-syms function (car (pkg.itab pkg))))) |
---|
279 | |
---|
280 | (defun iterate-over-accessable-symbols (pkg-spec function) |
---|
281 | (let* ((pkg (pkg-arg (or pkg-spec *package*))) |
---|
282 | (used (pkg.used pkg)) |
---|
283 | (shadowed (pkg.shadowed pkg))) |
---|
284 | (iterate-over-present-symbols pkg function) |
---|
285 | (when used |
---|
286 | (if shadowed |
---|
287 | (flet ((ignore-shadowed-conflicts (var) |
---|
288 | (unless (%name-present-in-package-p (symbol-name var) pkg) |
---|
289 | (funcall function var)))) |
---|
290 | (declare (dynamic-extent #'ignore-shadowed-conflicts)) |
---|
291 | (dolist (u used) (iterate-over-external-symbols u #'ignore-shadowed-conflicts))) |
---|
292 | (dolist (u used) (iterate-over-external-symbols u function)))))) |
---|
293 | |
---|
294 | (defun iterate-over-all-symbols (function) |
---|
295 | (dolist (pkg %all-packages%) |
---|
296 | (iterate-over-present-symbols pkg function))) |
---|
297 | |
---|
298 | |
---|
299 | |
---|
300 | ;;;Eval definitions for things open-coded by the compiler. |
---|
301 | ;;;Don't use DEFUN since it should be illegal to DEFUN compiler special forms... |
---|
302 | ;;;Of course, these aren't special forms. |
---|
303 | (macrolet ((%eval-redef (name vars &rest body) |
---|
304 | (when (null body) (setq body `((,name ,@vars)))) |
---|
305 | `(setf (symbol-function ',name) |
---|
306 | (qlfun ,name ,vars ,@body)))) |
---|
307 | (declare (optimize (speed 1) (safety 1))) |
---|
308 | (%eval-redef %ilsl (n x)) |
---|
309 | (%eval-redef %ilsr (n x)) |
---|
310 | (%eval-redef neq (x y)) |
---|
311 | (%eval-redef not (x)) |
---|
312 | (%eval-redef null (x)) |
---|
313 | (%eval-redef rplaca (x y)) |
---|
314 | (%eval-redef rplacd (x y)) |
---|
315 | (%eval-redef set-car (x y)) |
---|
316 | (%eval-redef set-cdr (x y)) |
---|
317 | (%eval-redef int>0-p (x)) |
---|
318 | (%eval-redef %get-byte (ptr &optional (offset 0)) (%get-byte ptr offset)) |
---|
319 | (%eval-redef %get-word (ptr &optional (offset 0)) (%get-word ptr offset)) |
---|
320 | (%eval-redef %get-signed-byte (ptr &optional (offset 0)) (%get-signed-byte ptr offset)) |
---|
321 | (%eval-redef %get-signed-word (ptr &optional (offset 0)) (%get-signed-word ptr offset)) |
---|
322 | (%eval-redef %get-long (ptr &optional (offset 0)) (%get-long ptr offset)) |
---|
323 | (%eval-redef %get-fixnum (ptr &optional (offset 0)) (%get-fixnum ptr offset)) |
---|
324 | (%eval-redef %get-signed-long (ptr &optional (offset 0)) (%get-signed-long ptr offset)) |
---|
325 | (%eval-redef %get-unsigned-long (ptr &optional (offset 0)) (%get-unsigned-long ptr offset)) |
---|
326 | (%eval-redef %get-ptr (ptr &optional (offset 0)) (%get-ptr ptr offset)) |
---|
327 | (%eval-redef %get-full-long (ptr &optional (offset 0)) (%get-full-long ptr offset)) |
---|
328 | (%eval-redef %int-to-ptr (int)) |
---|
329 | (%eval-redef %ptr-to-int (ptr)) |
---|
330 | (%eval-redef %ptr-eql (ptr1 ptr2)) |
---|
331 | (%eval-redef %setf-macptr (ptr1 ptr2)) |
---|
332 | (%eval-redef %null-ptr-p (ptr)) |
---|
333 | |
---|
334 | |
---|
335 | (%eval-redef %iasr (x y)) |
---|
336 | |
---|
337 | |
---|
338 | (%eval-redef %set-byte (p o &optional (new (prog1 o (setq o 0)))) |
---|
339 | (%set-byte p o new)) |
---|
340 | (%eval-redef %set-unsigned-byte (p o &optional (new (prog1 o (setq o 0)))) |
---|
341 | (%set-unsigned-byte p o new)) |
---|
342 | (%eval-redef %set-word (p o &optional (new (prog1 o (setq o 0)))) |
---|
343 | (%set-word p o new)) |
---|
344 | (%eval-redef %set-unsigned-word (p o &optional (new (prog1 o (setq o 0)))) |
---|
345 | (%set-unsigned-word p o new)) |
---|
346 | (%eval-redef %set-long (p o &optional (new (prog1 o (setq o 0)))) |
---|
347 | (%set-long p o new)) |
---|
348 | (%eval-redef %set-unsigned-long (p o &optional (new (prog1 o (setq o 0)))) |
---|
349 | (%set-unsigned-long p o new)) |
---|
350 | (%eval-redef %set-ptr (p o &optional (new (prog1 o (setq o 0)))) |
---|
351 | (%set-ptr p o new)) |
---|
352 | |
---|
353 | |
---|
354 | (%eval-redef %word-to-int (word)) |
---|
355 | (%eval-redef %inc-ptr (ptr &optional (by 1)) (%inc-ptr ptr by)) |
---|
356 | |
---|
357 | (%eval-redef char-code (x)) |
---|
358 | (%eval-redef code-char (x)) |
---|
359 | (%eval-redef 1- (n)) |
---|
360 | (%eval-redef 1+ (n)) |
---|
361 | |
---|
362 | (%eval-redef uvref (x y)) |
---|
363 | (%eval-redef uvset (x y z)) |
---|
364 | (%eval-redef uvsize (x)) |
---|
365 | |
---|
366 | (%eval-redef svref (x y)) |
---|
367 | (%eval-redef svset (x y z)) |
---|
368 | |
---|
369 | |
---|
370 | |
---|
371 | (%eval-redef car (x)) |
---|
372 | (%eval-redef cdr (x)) |
---|
373 | (%eval-redef cons (x y)) |
---|
374 | (%eval-redef endp (x)) |
---|
375 | |
---|
376 | (progn |
---|
377 | (%eval-redef typecode (x)) |
---|
378 | (%eval-redef lisptag (x)) |
---|
379 | (%eval-redef fulltag (x)) |
---|
380 | (%eval-redef %unbound-marker ()) |
---|
381 | (%eval-redef %slot-unbound-marker ()) |
---|
382 | (%eval-redef %slot-ref (v i)) |
---|
383 | (%eval-redef %alloc-misc (count subtag &optional (initial nil initial-p)) |
---|
384 | (if initial-p |
---|
385 | (%alloc-misc count subtag initial) |
---|
386 | (%alloc-misc count subtag))) |
---|
387 | (%eval-redef %setf-double-float (x y)) |
---|
388 | (%eval-redef %lisp-word-ref (x y)) |
---|
389 | (%eval-redef %temp-cons (x y)) |
---|
390 | (%eval-redef require-fixnum (x)) |
---|
391 | (%eval-redef require-symbol (x)) |
---|
392 | (%eval-redef require-list (x)) |
---|
393 | (%eval-redef require-real (x)) |
---|
394 | (%eval-redef require-simple-string (x)) |
---|
395 | (%eval-redef require-simple-vector (x)) |
---|
396 | (%eval-redef require-character (x)) |
---|
397 | (%eval-redef require-number (x)) |
---|
398 | (%eval-redef require-integer (x)) |
---|
399 | (%eval-redef require-s8 (x)) |
---|
400 | (%eval-redef require-u8 (x)) |
---|
401 | (%eval-redef require-s16 (x)) |
---|
402 | (%eval-redef require-u16 (x)) |
---|
403 | (%eval-redef require-s32 (x)) |
---|
404 | (%eval-redef require-u32 (x)) |
---|
405 | (%eval-redef require-s64 (x)) |
---|
406 | (%eval-redef require-u64 (x)) |
---|
407 | (%eval-redef %reference-external-entry-point (x)) |
---|
408 | ) |
---|
409 | |
---|
410 | (%eval-redef %get-bit (ptr offset)) |
---|
411 | (%eval-redef %set-bit (ptr offset val)) |
---|
412 | (%eval-redef %get-double-float (ptr &optional (offset 0)) |
---|
413 | (%get-double-float ptr offset)) |
---|
414 | (%eval-redef %get-single-float (ptr &optional (offset 0)) |
---|
415 | (%get-single-float ptr offset)) |
---|
416 | (%eval-redef %set-double-float (p o &optional (new (prog1 o (setq o 0)))) |
---|
417 | (%set-double-float p o new)) |
---|
418 | (%eval-redef %set-single-float (p o &optional (new (prog1 o (setq o 0)))) |
---|
419 | (%set-single-float p o new)) |
---|
420 | (%eval-redef assq (item list)) |
---|
421 | ) |
---|
422 | |
---|
423 | ; In the spirit of eval-redef ... |
---|
424 | |
---|
425 | |
---|
426 | ;; pointer hacking stuff |
---|
427 | ; |
---|
428 | ; |
---|
429 | |
---|
430 | |
---|
431 | |
---|
432 | ;;; I'd guess that the majority of bitfields in the world whose width is |
---|
433 | ;;; greater than 1 have a width of two. If that's true, this is probably |
---|
434 | ;;; faster than trying to be more clever about it would be. |
---|
435 | (defun %get-bitfield (ptr start-bit width) |
---|
436 | (declare (fixnum start-bit width)) |
---|
437 | (do* ((bit #+big-endian-target start-bit |
---|
438 | #+little-endian-target (the fixnum (1- (the fixnum (+ start-bit width)))) |
---|
439 | #+big-endian-target (1+ bit) |
---|
440 | #+little-endian-target (1- bit)) |
---|
441 | (i 0 (1+ i)) |
---|
442 | (val 0)) |
---|
443 | ((= i width) val) |
---|
444 | (declare (fixnum val i bit)) |
---|
445 | (setq val (logior (ash val 1) (%get-bit ptr bit))))) |
---|
446 | |
---|
447 | (defun %set-bitfield (ptr start width val) |
---|
448 | (declare (fixnum val start width)) |
---|
449 | (do* ((v val (ash v -1)) |
---|
450 | (bit #+big-endian-target (1- (+ start width)) |
---|
451 | #+little-endian-target start |
---|
452 | #+big-endian-target (1- bit) |
---|
453 | #+little-endian-target (1+ bit)) |
---|
454 | (i 0 (1+ i))) |
---|
455 | ((= i width) val) |
---|
456 | (declare (fixnum v bit i)) |
---|
457 | (setf (%get-bit ptr bit) (logand v 1)))) |
---|
458 | |
---|
459 | ; expands into compiler stuff |
---|
460 | |
---|
461 | (setf (symbol-function '%get-unsigned-byte) (symbol-function '%get-byte)) |
---|
462 | (setf (symbol-function '%get-unsigned-word) (symbol-function '%get-word)) |
---|
463 | (setf (symbol-function '%get-signed-long) (symbol-function '%get-long)) |
---|
464 | |
---|
465 | (defun decompose-record-accessor (accessor &aux ret) |
---|
466 | (do* ((str (symbol-name accessor) (%substr str (+ i 1) len)) |
---|
467 | (len (length str) (length str)) |
---|
468 | (i (%str-member #\. str) (%str-member #\. str)) |
---|
469 | (field (%substr str 0 (or i len)) (%substr str 0 (or i len)))) |
---|
470 | ((not i) (nreverse (cons (make-keyword field) ret))) |
---|
471 | (push (make-keyword field) ret))) |
---|
472 | |
---|
473 | |
---|
474 | |
---|
475 | |
---|
476 | (provide 'level-2) |
---|
477 | |
---|
478 | |
---|
479 | |
---|
480 | |
---|
481 | ;; end of level-2.lisp |
---|
482 | |
---|