Commit | Line | Data |
---|---|---|
147c0c77 C |
1 | ;;;-*-lisp-*- |
2 | (setq rcs-strictini- | |
3 | "$Header: /usr/lib/lisp/structini.l,v 1.1 83/01/29 18:40:11 jkf Exp $") | |
4 | ||
5 | #+franz | |
6 | (declare (macros t)) | |
7 | ||
8 | (defmacro defstruct ((name . opts) . slots) | |
9 | (let ((dp (cadr (assq ':default-pointer opts))) | |
10 | (conc-name (cadr (assq ':conc-name opts))) | |
11 | (cons-name (implode (append '(m a k e -) (explodec name))))) | |
12 | #Q (fset-carefully cons-name '(macro . initial_defstruct-cons)) | |
13 | #M (putprop cons-name 'initial_defstruct-cons 'macro) | |
14 | #F (putd cons-name '(macro (x) (initial_defstruct-cons x))) | |
15 | (do ((i 0 (1+ i)) | |
16 | (l slots (cdr l)) | |
17 | (foo nil (cons (list slot init) foo)) | |
18 | (chars (explodec conc-name)) | |
19 | (slot) (acsor) (init)) | |
20 | ((null l) | |
21 | (putprop cons-name foo 'initial_defstruct-inits) | |
22 | `',name) | |
23 | (cond ((atom (car l)) | |
24 | (setq slot (car l)) | |
25 | (setq init nil)) | |
26 | (t (setq slot (caar l)) | |
27 | (setq init (cadar l)))) | |
28 | (setq acsor (implode (append chars (explodec slot)))) | |
29 | (putprop acsor dp 'initial_defstruct-dp) | |
30 | #Q (fset-carefully acsor '(macro . initial_defstruct-ref)) | |
31 | #M (putprop acsor 'initial_defstruct-ref 'macro) | |
32 | #F (putd acsor '(macro (x) (initial_defstruct-ref x))) | |
33 | (putprop acsor i 'initial_defstruct-i)))) | |
34 | ||
35 | (defun initial_defstruct-ref (form) | |
36 | (let ((i (get (car form) 'initial_defstruct-i)) | |
37 | (p (if (null (cdr form)) | |
38 | (get (car form) 'initial_defstruct-dp) | |
39 | (cadr form)))) | |
40 | #-Multics `(nth ,i ,p) | |
41 | #+Multics `(car ,(do ((i i (1- i)) | |
42 | (x p `(cdr ,x))) | |
43 | ((zerop i) x))) | |
44 | )) | |
45 | ||
46 | (defun initial_defstruct-cons (form) | |
47 | (do ((inits (get (car form) 'initial_defstruct-inits) | |
48 | (cdr inits)) | |
49 | (gen (gensym)) | |
50 | (x nil (cons (or (get form (caar inits)) | |
51 | (cadar inits)) | |
52 | x))) | |
53 | ((null inits) | |
54 | `(list . ,x)))) | |
55 |