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