1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:         PU:BACKQUOTE.SL
4% Description:  tool for building partially quoted lists
5% Author:       Don Morrison, Hewlett-Packard CRC
6% Created:      Wednesday, 12 May 1982
7% Modified:     19 Jan 1984 1429-PST (Brian Beach)
8% Status:       Open Source: BSD License
9% Mode:         Lisp
10% Package:      Utilities
11% Compiletime:
12% Runtime:
13%
14% (c) Copyright 1983, Hewlett-Packard Company, see the file
15%            HP_disclaimer at the root of the PSL file tree
16%
17% (c) Copyright 1982, University of Utah
18%
19% Redistribution and use in source and binary forms, with or without
20% modification, are permitted provided that the following conditions are met:
21%
22%    * Redistributions of source code must retain the relevant copyright
23%      notice, this list of conditions and the following disclaimer.
24%    * Redistributions in binary form must reproduce the above copyright
25%      notice, this list of conditions and the following disclaimer in the
26%      documentation and/or other materials provided with the distribution.
27%
28% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
29% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
30% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
31% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
32% CONTRIBUTORS
33% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
34% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
35% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
36% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
37% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
38% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
39% POSSIBILITY OF SUCH DAMAGE.
40%
41%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
42%
43% Revisions:
44%
45% 19 Jan 1984 1429-PST (Brian Beach)
46%   Added standard header.
47%
48%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
49
50% Backquote is  similar  to MACLISP's  `  (that's backwards!)   mechanism.   In
51% essence the  body  of  the  backquote is  quoted,  except  for  those  things
52% surrounded by unquote, which are evaluated at macro expansion time.  UNQUOTEL
53% splices in a  list, and  unquoted splices  in a  list destructively.   Mostly
54% useful for defining macro's.
55
56(dm backquote (u) (backquote-form (cadr u)))
57
58(de backquote-form (u)
59  (cond
60    ((vectorp u) (backquote-vector u))
61    ((atom u)
62      (cond
63	((and (idp u) (not (memq u '(t nil)))) (mkquote u))
64	(t u)))
65    ((eq (car u) 'unquote) (cadr u))
66    ((eq (car u) 'backquote) (backquote-form (backquote-form (cadr u))))
67    ((memq (car u) '(unquotel unquoted))
68      (ContinuableError 99 (BldMsg "%r can't be spliced in here." u)) u)
69    ((eqcar (car u) 'unquotel)
70      (cond
71	((cdr u) (list 'append (cadar u) (backquote-form (cdr u))))
72	(t (cadar u))))
73    ((eqcar (car u) 'unquoted)
74      (cond
75	((cdr u) (list 'nconc (cadar u) (backquote-form (cdr u))))
76	(t (cadar u))))
77    (t (backquote-list u))))
78
79(de backquote-vector (u)
80  ((lambda (n rslt all-quoted)  % can't use LET 'cause it ain't defined yet
81     ((lambda (i)
82	(while (not (minusp i)) % can't use FOR or DO for the same reason
83	  ((lambda (x)
84	     (setq all-quoted (and all-quoted (backquote-constantp x)))
85	     (setq rslt (cons x rslt)))
86	    (backquote-form (getv u i)))
87	  (setq i (sub1 i))))
88       n)
89     (cond
90       (all-quoted
91	 ((lambda (i vec)
92	    (while (not (greaterp i n))
93	      (putv vec i (backquote-constant-value (car rslt)))
94	      (setq rslt (cdr rslt))
95	      (setq i (add1 i)))
96	    vec)
97	   0
98	   (mkvect n)))
99       (t (cons 'vector rslt))))
100    (upbv u)
101    nil
102    t))
103
104(de backquote-list (u)
105  ((lambda (car-u cdr-u)  % can't use LET 'cause it ain't defined yet
106     (cond
107       ((null cdr-u)
108	 (cond
109	   ((backquote-constantp car-u)
110	     (list 'quoted-list (backquote-constant-value car-u)))
111	   (t (list 'list car-u))))
112       ((constantp cdr-u)
113	 (cond
114	   ((backquote-constantp car-u)
115	     (list 'quoted-list* (backquote-constant-value car-u) cdr-u))
116	   (t (list 'list* car-u cdr-u))))
117       ((and (pairp cdr-u) (memq (car cdr-u) '(list list*)))
118	 (cons (car cdr-u) (cons car-u (cdr cdr-u))))
119       ((and
120	  (pairp cdr-u)
121	  (memq (car cdr-u) '(quoted-list quoted-list*)))
122	 (cond
123	   ((backquote-constantp car-u)
124	     (cons
125	       (car cdr-u)
126	       (cons (backquote-constant-value car-u) (cdr cdr-u))))
127	   (t (list
128		'list*
129		car-u
130		(mkquote (backquote-constant-value cdr-u))))))
131       ((eqcar cdr-u 'quote)
132	 (cond
133	   ((backquote-constantp car-u)
134	      (list
135	       'quoted-list*
136	       (backquote-constant-value car-u)
137	       (cadr cdr-u)))
138	   (t (list 'list* car-u cdr-u))))
139       (t (list 'list* car-u cdr-u))))
140    (backquote-form (car u))
141    (backquote-form (cdr u))))
142
143(de backquote-constantp (u)
144  (cond
145    ((pairp u) (memq (car u) '(quote quoted-list quoted-list*)))
146    (t (not (idp u)))))
147
148(de backquote-constant-value (x)
149  (cond
150    ((eqcar x 'quote) (cadr x))
151    ((eqcar x 'quoted-list) (cdr x))
152    ((eqcar x 'quoted-list*)
153      (cadr (apply 'quoted-list* (list x))))
154    (t x)))
155
156% The following, while possibly useful in themselves, are mostly included
157% for use by backquote and friends.
158
159(dm quoted-list (u) (mkquote (cdr u)))
160
161(dm list* (u) (expand (cdr u) 'cons))
162
163(dm quoted-list* (u)
164  (cond
165    ((pairp (cdr u))
166      (setq u (reverse (cdr u)))
167      ((lambda (a)
168	 (foreach elem in (cdr u) do
169	   (setq a (cons elem a)))
170	 (mkquote a))
171	(car u)))))
172%     (t (error ... ?
173
174% Since unquote and friends should be completely stripped out by backquote,
175% make it an error to try and evaluate them.  These could be much better...
176
177(dm unquote (u) (ContinuableError
178		  99
179		  (BldMsg "%r is not within backquote." u)
180		  u))
181
182(copyd 'unquotel 'unquote)
183
184(copyd 'unquoted 'unquote)
185