1;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2;
3; File:         PU:STRUCT.INITIAL
4; Description:  File included in NSTRUCT
5; Author:
6; Created:
7; Modified:     28-Aug-84 09:01:01 (Brian Beach)
8; Status:       Experimental (Do Not Distribute)
9; Mode:         Lisp
10; Package:      Utilities
11; Compile to:   none
12;
13; (c) Copyright 1983, Hewlett-Packard Company, see the file
14;            HP_disclaimer at the root of the PSL file tree
15;
16; This file is included in PU:NSTRUCT.LSP
17;
18;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19;
20; Revisions:
21;
22; 19 Jan 1984 1450-PST (Brian Beach)
23;   Added standard header.
24;
25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
26
27(defmacro defstruct ((name . opts) . slots)
28  (let ((dp (cadr (assq 'default-pointer opts)))
29	(conc-name (cadr (assq 'conc-name opts)))
30	(cons-name (implode (append '(m a k e -) (explodec name)))))
31;    #Q (fset-carefully cons-name '(macro . initial_defstruct-cons))
32;    #M (putprop cons-name 'initial_defstruct-cons 'macro)
33;    PSL change
34	(putd cons-name 'macro (cdr (getd 'initial_defstruct-cons)))
35;    PSL change    1+ ==> add1
36    (do ((i 0 (add1 i))
37	 (l slots (cdr l))
38	 (foo nil (cons (list slot init) foo))
39	 (chars (explodec conc-name))
40	 (slot) (acsor) (init))
41	((null l)
42	 (putprop cons-name foo 'initial_defstruct-inits)
43	 `',name)
44      (cond ((atom (car l))
45	     (setq slot (car l))
46	     (setq init nil))
47	    (t (setq slot (caar l))
48	       (setq init (cadar l))))
49      (setq acsor (implode (append chars (explodec slot))))
50      (putprop acsor dp 'initial_defstruct-dp)
51;      #Q (fset-carefully acsor '(macro . initial_defstruct-ref))
52;      #M (putprop acsor 'initial_defstruct-ref 'macro)
53;      PSL change
54	  (putd acsor 'macro (cdr (getd 'initial_defstruct-ref)))
55      (putprop acsor i 'initial_defstruct-i))))
56
57(defun initial_defstruct-ref (form)
58  (let ((i (get (car form) 'initial_defstruct-i))
59	(p (if (null (cdr form))
60	       (get (car form) 'initial_defstruct-dp)
61	       (cadr form))))
62;     PSL change	incompatible NTH
63    #-Multics `(nth ,p ,(add1 i))
64;    #-Multics `(nth ,i ,p)
65    #+Multics `(car ,(do ((i i (1- i))
66			  (x p `(cdr ,x)))
67			 ((zerop i) x)))
68    ))
69
70(defun initial_defstruct-cons (form)
71  (do ((inits (get (car form) 'initial_defstruct-inits)
72	      (cdr inits))
73       (gen (gensym))
74       (x nil (cons (or (get form (caar inits))
75			(cadar inits))
76		    x)))
77      ((null inits)
78       `(list . ,x))))
79