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