aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap/utility.clisp
blob: db11171fdb02977ff07571b4a7124783e97bbb35 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
(PROCLAIM '(OPTIMIZE SPEED))
(DEFPACKAGE "BOOTTRAN")

(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (PROGN
   (COND
    ((|%hasFeature| :COMMON-LISP)
     (USE-PACKAGE "COMMON-LISP" . #1=(#2="BOOTTRAN")))
    (T (USE-PACKAGE "LISP" . #1#)))
   (USE-PACKAGE "AxiomCore" #2#)))

(IN-PACKAGE "BOOTTRAN")

(PROVIDE "utility")

(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (EXPORT
   '(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
                     |scalarMember?| |listMember?| |reverse| |reverse!|
                     |lastNode| |append| |append!| |copyList| |substitute|
                     |substitute!| |setDifference| |setUnion| |setIntersection|
                     |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ|
                     |objectAssoc| |remove| |removeSymbol| |atomic?|
                     |finishLine|)))

(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))

(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute!|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
  |append|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
  |append!|))

(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%List| |%Thing|)) |copyList|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%Maybe| (|%Node| |%Thing|)))
  |lastNode|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) |%Symbol|) (|%List| |%Thing|))
  |removeSymbol|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) (|%List| |%Thing|)) |remove|))

(DECLAIM
 (FTYPE
  (FUNCTION (|%Thing| (|%List| |%Thing|))
   (|%Maybe| (|%Pair| |%Thing| |%Thing|)))
  |objectAssoc|))

(DECLAIM
 (FTYPE
  (FUNCTION (|%Symbol| (|%List| |%Thing|))
   (|%Maybe| (|%Pair| |%Symbol| |%Thing|)))
  |symbolAssoc|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
  |setDifference|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
  |setUnion|))

(DECLAIM
 (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
  |setIntersection|))

(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|))

(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Void|) |finishLine|))

(DECLAIM
 (FTYPE (FUNCTION (|%String| |%Short|) (|%Maybe| |%Short|))
  |firstBlankPosition|))

(|%defaultReadAndLoadSettings|)

(DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE)))

(DEFUN |objectMember?| (|x| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (EQ |x| |l|))))))

(DEFUN |symbolMember?| (|s| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (EQ |s| |l|))))))

(DEFUN |stringMember?| (|s| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((STRING= |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (STRING= |s| |l|))))))

(DEFUN |charMember?| (|c| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((CHAR= |c| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (CHAR= |c| |l|))))))

(DEFUN |scalarMember?| (|s| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((EQL |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (EQL |s| |l|))))))

(DEFUN |listMember?| (|x| |l|)
  (LOOP
   (COND ((NULL |l|) (RETURN NIL))
         ((CONSP |l|)
          (COND ((EQUAL |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
         (T (RETURN (EQUAL |x| |l|))))))

(DEFUN |reverse| (|l|)
  (PROG (|r|)
    (RETURN
     (PROGN
      (SETQ |r| NIL)
      (LOOP
       (COND ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) (SETQ |l| (CDR |l|)))
             (T (RETURN |r|))))))))

(DEFUN |reverse!| (|l|)
  (PROG (|l2| |l1|)
    (RETURN
     (PROGN
      (SETQ |l1| NIL)
      (LOOP
       (COND
        ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) (SETQ |l1| |l|)
         (SETQ |l| |l2|))
        (T (RETURN |l1|))))))))

(DEFUN |lastNode| (|l|)
  (PROG (|l'|)
    (RETURN
     (PROGN
      (LOOP
       (COND
        ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) (CONSP |l'|)))
         (RETURN NIL))
        (T (SETQ |l| |l'|))))
      |l|))))

(DEFUN |copyList| (|l|)
  (PROG (|l'| |t|)
    (RETURN
     (COND ((NOT (CONSP |l|)) |l|)
           (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
            (LOOP
             (PROGN
              (SETQ |l| (CDR |l|))
              (COND
               ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) (SETQ |t| (CDR |t|)))
               (T (RPLACD |t| |l|) (RETURN |l'|))))))))))

(DEFUN |append!| (|x| |y|)
  (COND ((NULL |x|) |y|) ((NULL |y|) |x|)
        (T (RPLACD (|lastNode| |x|) |y|) |x|)))

(DEFUN |append| (|x| |y|) (|append!| (|copyList| |x|) |y|))

(DEFUN |symbolAssoc| (|s| |l|)
  (PROG (|x|)
    (RETURN
     (LOOP
      (COND
       ((NOT
         (AND (CONSP |l|) (PROGN (SETQ |x| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
        (RETURN NIL))
       ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (RETURN |x|)))))))

(DEFUN |objectAssoc| (|x| |l|)
  (PROG (|p|)
    (RETURN
     (LOOP
      (COND
       ((NOT
         (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
        (RETURN NIL))
       ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|)))))))

(DEFUN |substitute!| (|y| |x| |s|)
  (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
        (T
         (COND
          ((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|)))
           (RPLACD |s| (|substitute!| |y| |x| (CDR |s|)))))
         |s|)))

(DEFUN |substitute| (|y| |x| |s|)
  (PROG (|t| |h|)
    (RETURN
     (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
           ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
            (SETQ |t| (|substitute| |y| |x| (CDR |s|)))
            (COND ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
                  (T (CONS |h| |t|))))
           (T |s|)))))

(DEFUN |applySubst| (|sl| |t|)
  (PROG (|p| |tl| |hd|)
    (RETURN
     (COND
      ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|)))
       (SETQ |tl| (|applySubst| |sl| (CDR |t|)))
       (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
             (T (CONS |hd| |tl|))))
      ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
      (T |t|)))))

(DEFUN |applySubst!| (|sl| |t|)
  (PROG (|p| |tl| |hd|)
    (RETURN
     (COND
      ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|)))
       (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|)
       (RPLACD |t| |tl|))
      ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
      (T |t|)))))

(DEFUN |applySubstNQ| (|sl| |t|)
  (PROG (|p| |tl| |hd|)
    (RETURN
     (COND
      ((AND (CONSP |t|) (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T))
       (COND ((EQ |hd| 'QUOTE) |t|)
             (T (SETQ |hd| (|applySubstNQ| |sl| |hd|))
              (SETQ |tl| (|applySubstNQ| |sl| |tl|))
              (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
                    (T (CONS |hd| |tl|))))))
      ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|))
      (T |t|)))))

(DEFUN |setDifference| (|x| |y|)
  (PROG (|a| |l| |p|)
    (RETURN
     (COND ((NULL |x|) NIL) ((NULL |y|) |x|)
           (T (SETQ |l| (SETQ |p| (LIST NIL)))
            (LET ((|bfVar#1| |x|))
              (LOOP
               (COND ((NOT (CONSP |bfVar#1|)) (RETURN NIL))
                     (T
                      (AND (CONSP |bfVar#1|)
                           (PROGN (SETQ |a| (CAR |bfVar#1|)) T)
                           (NOT (|objectMember?| |a| |y|))
                           (PROGN
                            (RPLACD |p| (LIST |a|))
                            (SETQ |p| (CDR |p|))))))
               (SETQ |bfVar#1| (CDR |bfVar#1|))))
            (CDR |l|))))))

(DEFUN |setUnion| (|x| |y|)
  (PROG (|z|)
    (RETURN
     (PROGN
      (SETQ |z| NIL)
      (LET ((|bfVar#1| |x|) (|a| NIL))
        (LOOP
         (COND
          ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
           (RETURN NIL))
          (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
         (SETQ |bfVar#1| (CDR |bfVar#1|))))
      (LET ((|bfVar#2| |y|) (|a| NIL))
        (LOOP
         (COND
          ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |a| (CAR |bfVar#2|)) NIL))
           (RETURN NIL))
          (T (AND (NOT (|objectMember?| |a| |z|)) (SETQ |z| (CONS |a| |z|)))))
         (SETQ |bfVar#2| (CDR |bfVar#2|))))
      (|reverse!| |z|)))))

(DEFUN |setIntersection| (|x| |y|)
  (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|a| NIL))
    (LOOP
     (COND
      ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |a| (CAR |bfVar#1|)) NIL))
       (RETURN |bfVar#2|))
      (T
       (AND (|objectMember?| |a| |y|)
            (COND
             ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |a| NIL))
              (SETQ |bfVar#3| |bfVar#2|))
             (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
     (SETQ |bfVar#1| (CDR |bfVar#1|)))))

(DEFUN |removeSymbol| (|l| |x|)
  (PROG (|y| |LETTMP#1| |l'| |before|)
    (RETURN
     (PROGN
      (SETQ |before| NIL)
      (SETQ |l'| |l|)
      (LOOP
       (COND ((NOT (CONSP |l'|)) (RETURN |l|))
             (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
              (SETQ |l'| (CDR |LETTMP#1|))
              (COND
               ((EQ |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
               (T (SETQ |before| (CONS |y| |before|)))))))))))

(DEFUN |removeScalar| (|l| |x|)
  (PROG (|y| |LETTMP#1| |l'| |before|)
    (RETURN
     (PROGN
      (SETQ |before| NIL)
      (SETQ |l'| |l|)
      (LOOP
       (COND ((NOT (CONSP |l'|)) (RETURN |l|))
             (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
              (SETQ |l'| (CDR |LETTMP#1|))
              (COND
               ((EQL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
               (T (SETQ |before| (CONS |y| |before|)))))))))))

(DEFUN |removeValue| (|l| |x|)
  (PROG (|y| |LETTMP#1| |l'| |before|)
    (RETURN
     (PROGN
      (SETQ |before| NIL)
      (SETQ |l'| |l|)
      (LOOP
       (COND ((NOT (CONSP |l'|)) (RETURN |l|))
             (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
              (SETQ |l'| (CDR |LETTMP#1|))
              (COND
               ((EQUAL |x| |y|)
                (RETURN (|append!| (|reverse!| |before|) |l'|)))
               (T (SETQ |before| (CONS |y| |before|)))))))))))

(DEFUN |remove| (|l| |x|)
  (COND ((SYMBOLP |x|) (|removeSymbol| |l| |x|))
        ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|))
        (T (|removeValue| |l| |x|))))

(DEFUN |charPosition| (|c| |s| |k|)
  (PROG (|n|)
    (RETURN
     (PROGN
      (SETQ |n| (LENGTH |s|))
      (LOOP
       (COND ((NOT (< |k| |n|)) (RETURN NIL))
             ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
             (T (SETQ |k| (+ |k| 1)))))))))

(DEFUN |firstNonblankPosition| (|s| |k|)
  (LET ((|bfVar#2| NIL) (|bfVar#1| (- (LENGTH |s|) 1)) (|i| |k|))
    (LOOP
     (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
           (T
            (AND (NOT (CHAR= (SCHAR |s| |i|) (|char| '| |)))
                 (PROGN
                  (SETQ |bfVar#2| |i|)
                  (COND (|bfVar#2| (RETURN |bfVar#2|)))))))
     (SETQ |i| (+ |i| 1)))))

(DEFUN |firstBlankPosition| (|s| |k|)
  (LET ((|bfVar#2| NIL) (|bfVar#1| (- (LENGTH |s|) 1)) (|i| |k|))
    (LOOP
     (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|))
           (T
            (AND (CHAR= (SCHAR |s| |i|) (|char| '| |))
                 (PROGN
                  (SETQ |bfVar#2| |i|)
                  (COND (|bfVar#2| (RETURN |bfVar#2|)))))))
     (SETQ |i| (+ |i| 1)))))

(DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|)))