1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PU:PSL_CASE.SL 4% Description: Adjust native case of PSL to lower or upper case. 5% Author: Herbert Melenk, ZIB Berlin 6% Created: 01-Nov-94 7% Package: 8% Status: Open Source: BSD License 9% 10% Redistribution and use in source and binary forms, with or without 11% modification, are permitted provided that the following conditions are met: 12% 13% * Redistributions of source code must retain the relevant copyright 14% notice, this list of conditions and the following disclaimer. 15% * Redistributions in binary form must reproduce the above copyright 16% notice, this list of conditions and the following disclaimer in the 17% documentation and/or other materials provided with the distribution. 18% 19% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 20% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 21% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 22% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR 23% CONTRIBUTORS 24% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 25% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 26% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 27% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN 28% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) 29% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 30% POSSIBILITY OF SUCH DAMAGE. 31% 32%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 33% 34% Revisions: 35% 36% 06-Nov-94 (Herbert Melenk) 37% Enabled switching in both directions. 38% 39%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 40 41% Adjust native case of PSL to lower or upper case. Loading of packages 42% compiled in the opposite case is enabled: the strings are converted 43% during fasin-intern. 44 45(compiletime (progn 46 (errorset '(load fast-integers) nil nil) 47 (errorset '(load fast-int) nil nil) 48 (errorset '(load inum) nil nil))) 49 50(compiletime (load hash-decls sys-consts)) 51 52(fluid '(**low-case **faslin-adjust-case nil-t-diff* *usermode)) 53 54(setq *usermode nil) 55 56(setq **faslin-adjust-case t) 57 58(fluid '(*notinplace)) 59 60(setq *notinplace t) % SUN4 : faster 61 62(de adjust-case-id(i) 63 (prog(w n l c) 64 (xxremob i) 65 (setq n (id2int i)) 66 (when (or *notinplace 67 (atom (errorset (list 'adjust-case-string-in-place (id2string i)) 68 nil nil))) 69 (setq w (copystring (id2string i))) 70 (adjust-case-string-in-place w) 71 (setf (symnam n) w)) 72 (return (intern i)))) 73 74(de adjust-case-string-in-place(s) 75 (if **low-case (lower-string-in-place s) (raise-string-in-place s))) 76 77(de lower-string-in-place(s) 78 (prog(w n l c) 79 (setq w (strinf s)) 80 (setq l (strlen w)) 81 (ifor (from j 0 l 1) 82 (do (progn 83 (setf c (strbyt w j)) 84 (when (and (wgeq c (char !A)) 85 (wleq c (char !Z))) 86 (setf (strbyt w j) 87 (iplus2 c 32)))))))) 88 89(de raise-string-in-place(s) 90 (prog(w n l c) 91 (setq w (strinf s)) 92 (setq l (strlen w)) 93 (ifor (from j 0 l 1) 94 (do (progn 95 (setf c (strbyt w j)) 96 (when (and (wgeq c (char !a)) 97 (wleq c (char !z))) 98 (setf (strbyt w j) 99 (idifference c 32)))))))) 100 101(de xxremob (u) 102 % REMove id from OBlist 103 (if (not (idp u)) 104 (noniderror u 'xxremob) 105 (let* ((inf (idinf u)) 106 (name (symnam inf))) 107 (if (wlessp inf 128) 108 (typeerror u 'xxremob '"non-char") 109 (let ((slot (hash-into-table name))) 110 (when (occupied-slot? slot) 111 (setf (hash-table-entry slot) deleted-slot-value) 112 ) 113 u 114 ))))) 115 116(fluid '(all-ids)) 117 118(de adjust-case-all-ids() 119 (adjust-case-id nil) 120 (mapobl (function(lambda(x)(push x all-ids)))) 121 (mapc all-ids (function(lambda(x) 122 (when (wgreaterp (id2int x) 128) (adjust-case-id x)))))) 123 124(when (null (getd 'old-faslin-intern)) 125 (copyd 'old-faslin-intern 'faslin-intern)) 126 127(de new-faslin-intern(s) 128 (when **faslin-adjust-case (adjust-case-string-in-place s)) 129 (old!-faslin!-intern s)) 130 131(de adjust-case-t() 132(mapobl (function(lambda(x) 133 (progn 134 (adjust-case-t1 (get x 'pattern)) 135 (adjust-case-t1 (get x 'cmacropatterntable)) 136 (adjust-case-t1 (get x 'openfn)) 137 (adjust-case-t1 (get x 'opencode)) 138 (adjust-case-t1 (get x 'exitopencode)) 139 ))))) 140 141(compiletime (off r2i)) 142 143(de adjust-case-t1(u) 144 (when (pairp u) 145 (when (eq (car u) (int2id 84)) (rplaca u '!t)) 146 (when (eq (cdr u) (int2id 84)) (rplacd u '!t)) 147 (adjust-case-t1 (car u)) 148 (adjust-case-t1 (cdr u)) )) 149 150(compiletime (on r2i)) 151 152% ONOFF 153 154(copyd 'true-onoff* 'onoff*) 155 156(de new-onoff*(a b) 157 (if b 158 (progn (true-onoff* a (int2id 84)) 159 (true-onoff* a '!t)) 160 (true-onoff* a nil))) 161 162% Compiler patches 163 164(fluid '(the-t* comcond-t*)) 165 166(setq comcond-t* (list 'quote (int2id 84))) 167 168(de case-pa1f-cond(u v) 169 % set !t back to T in last clause to make 170 % pa1f-cond and &comcond happy. 171 (setq u (true-pa1f-cond u v)) 172 (case-pa1f-cond2 u)) 173 174(de case-pa1f-cond2 (u) 175 (if (eqcar (car u) 'lambda) 176 (cons (list 'lambda (cadar u) (case-pa1f-cond2 (caddar u))) 177 (cdr u)) 178 (cons 'cond 179 (foreach c in (cdr u) collect 180 (cons (if (member (car c) '((quote !t) (quote !T))) 181 comcond-t* 182 (car c)) 183 (cdr c)))))) 184 185(de adjust-case-compiler() 186 (let (*usermode) 187 (setf (symval (id2int 'nil-t-diff*)) 188 (difference (inf nil)(inf (symval (inf 't))))) 189 (when (null (getd 'true-pa1f-cond )) 190 (copyd 'true-pa1f-cond 'pa1f-cond)) 191 % extract the T which the compiler likes best. 192 (setq the-t* (cadr (car (lastcar 193 (true-pa1f-cond '(cond (a b)) '(a b)))))) 194 (remd 'pa1f-cond) 195 (copyd 'pa1f-cond 'case-pa1f-cond) 196 (adjust-case-t) % adjust t in patterns 197 (prin2t "#### compiler patched for new case ####") 198)) 199 200(when (null (getd 'true-load1)) 201 (copyd 'true-load1 'load1)) 202 203(de case-load1(u) 204 (prog(w) 205 (setq w (true-load1 u)) 206 (when (eq u 'compiler)(adjust-case-compiler)) 207 (return w))) 208 209(de psl_case(m) 210 (prog(sys-t) 211 (setq **low-case (memq m '(low lower))) 212 (if **low-case (setq sys-t '!t) (setq sys-t '!T)) 213 (put '!t 'constant? sys-t) 214 (put '!T 'constant? sys-t) 215 (setf (symval (inf '!t)) sys-t) 216 (setf (symval (inf '!T)) sys-t) 217 (adjust-case-all-ids) 218 (remd 'faslin!-intern) 219 (copyd 'faslin!-intern 'new-faslin-intern) 220 (remd 'onoff*) 221 (copyd 'onoff* 'new-onoff*) 222 (if m 223 (prin2t "#### PSL set to native lower case ####") 224 (prin2t "#### PSL set to native UPPER case ####")) 225 (if (member 'compiler options*) 226 (adjust-case-compiler) 227 (progn (remd 'load1) (copyd 'load1 'case-load1))) 228 (copyd (intern "QUIT") 'quit) 229)) 230 231(flag '(psl_case) 'opfn) % REDUCE support. 232 233% switch system to lower case. 234 235(psl_case 'low) 236