aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap/includer.clisp
blob: a5beae8e88a164e958096825f7b66fcdad7cd133 (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
(PROCLAIM '(OPTIMIZE SPEED))
(IMPORT-MODULE "tokens")

(IN-PACKAGE "BOOTTRAN")

(PROVIDE "includer")

(DEFUN PNAME (|x|)
  (COND ((SYMBOLP |x|) (SYMBOL-NAME |x|)) ((CHARACTERP |x|) (STRING |x|))
        (T NIL)))

(DEFUN |shoeNotFound| (|fn|) (PROGN (|coreError| (LIST |fn| " not found")) NIL))

(DEFUN |shoeReadLispString| (|s| |n|)
  (PROG (|l|)
    (RETURN
     (PROGN
      (SETQ |l| (LENGTH |s|))
      (COND ((NOT (< |n| |l|)) NIL)
            (T
             (READ-FROM-STRING
              (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")"))))))))

(DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*))

(DEFUN |shoeSpaces| (|n|) (|makeString| |n| (|char| '|.|)))

(DEFUN |diagnosticLocation| (|tok|)
  (PROG (|pos|)
    (RETURN
     (PROGN
      (SETQ |pos| (|shoeTokPosn| |tok|))
      (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
              (WRITE-TO-STRING (|lineCharacter| |pos|)))))))

(DEFUN |SoftShoeError| (|posn| |key|)
  (PROGN
   (|coreError| (LIST "in line " (WRITE-TO-STRING (|lineNo| |posn|))))
   (|shoeConsole| (|lineString| |posn|))
   (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|"))
   (|shoeConsole| |key|)))

(DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
  (PROG (|a|)
    (RETURN
     (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|)))))

(DEFUN |bpSpecificErrorHere| (|key|)
  (DECLARE (SPECIAL |$stok|))
  (|bpSpecificErrorAtToken| |$stok| |key|))

(DEFUN |bpGeneralErrorHere| () (|bpSpecificErrorHere| "syntax error"))

(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|)
  (PROGN
   (|shoeConsole|
    (CONCAT "ignored from line " (WRITE-TO-STRING (|lineNo| |pos1|))))
   (|shoeConsole| (|lineString| |pos1|))
   (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
   (|shoeConsole|
    (CONCAT "ignored through line " (WRITE-TO-STRING (|lineNo| |pos2|))))
   (|shoeConsole| (|lineString| |pos2|))
   (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|"))))

(DEFUN |lineNo| (|p|) (CDAAR |p|))

(DEFUN |lineString| (|p|) (CAAAR |p|))

(DEFUN |lineCharacter| (|p|) (CDR |p|))

(DEFCONSTANT |$bStreamNil| (LIST '|nullstream|))

(DEFUN |bStreamNull| (|x|)
  (PROG (|st| |args| |op| |ISTMP#1|)
    (RETURN
     (COND ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) T)
           (T
            (LOOP
             (COND
              ((NOT
                (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
                     (PROGN
                      (SETQ |ISTMP#1| (CDR |x|))
                      (AND (CONSP |ISTMP#1|)
                           (PROGN
                            (SETQ |op| (CAR |ISTMP#1|))
                            (SETQ |args| (CDR |ISTMP#1|))
                            T)))))
               (RETURN NIL))
              (T (SETQ |st| (APPLY |op| |args|)) (RPLACA |x| (CAR |st|))
               (RPLACD |x| (CDR |st|)))))
            (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))))))

(DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|)))

(DEFUN |bMap1| (|f| |x|)
  (COND ((|bStreamNull| |x|) |$bStreamNil|)
        (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|))))))

(DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|)))

(DEFUN |bAppend| (|x| |y|) (|bDelay| #'|bAppend1| (LIST |x| |y|)))

(DEFUN |bAppend1| (|x| |y|)
  (COND
   ((|bStreamNull| |x|)
    (COND ((|bStreamNull| |y|) (LIST '|nullstream|)) (T |y|)))
   (T (CONS (CAR |x|) (|bAppend| (CDR |x|) |y|)))))

(DEFUN |bNext| (|f| |s|) (|bDelay| #'|bNext1| (LIST |f| |s|)))

(DEFUN |bNext1| (|f| |s|)
  (PROG (|h|)
    (RETURN
     (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
           (T (SETQ |h| (APPLY |f| (LIST |s|)))
            (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))

(DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|)))

(DEFUN |bRgen1| (|s|)
  (PROG (|a|)
    (RETURN
     (PROGN
      (SETQ |a| (|readLine| |s|))
      (COND ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|)))
            (T (LIST '|nullstream|)))))))

(DEFUN |bIgen| (|n|) (|bDelay| #'|bIgen1| (LIST |n|)))

(DEFUN |bIgen1| (|n|) (PROGN (SETQ |n| (+ |n| 1)) (CONS |n| (|bIgen| |n|))))

(DEFUN |bAddLineNumber| (|f1| |f2|)
  (|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|)))

(DEFUN |bAddLineNumber1| (|f1| |f2|)
  (COND ((|bStreamNull| |f1|) (LIST '|nullstream|))
        ((|bStreamNull| |f2|) (LIST '|nullstream|))
        (T
         (CONS (CONS (CAR |f1|) (CAR |f2|))
               (|bAddLineNumber| (CDR |f1|) (CDR |f2|))))))

(DEFUN |shoePrefixLisp| (|x|) (CONCAT ")lisp" |x|))

(DEFUN |shoePrefixLine| (|x|) (CONCAT ")line" |x|))

(DEFUN |shoePrefix?| (|prefix| |whole|)
  (PROG (|good|)
    (RETURN
     (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
           (T (SETQ |good| T)
            (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0))
              (LOOP
               (COND ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL))
                     (T
                      (SETQ |good|
                              (CHAR= (SCHAR |prefix| |i|)
                                     (SCHAR |whole| |j|)))))
               (SETQ |i| (+ |i| 1))
               (SETQ |j| (+ |j| 1))))
            (COND (|good| (|subString| |whole| (LENGTH |prefix|)))
                  (T |good|)))))))

(DEFUN |shoePlainLine?| (|s|)
  (COND ((EQL (LENGTH |s|) 0) T) (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|))))))

(DEFUN |shoeSay?| (|s|) (|shoePrefix?| ")say" |s|))

(DEFUN |shoeEval?| (|s|) (|shoePrefix?| ")eval" |s|))

(DEFUN |shoeFin?| (|s|) (|shoePrefix?| ")fin" |s|))

(DEFUN |shoeIf?| (|s|) (|shoePrefix?| ")if" |s|))

(DEFUN |shoeEndIf?| (|s|) (|shoePrefix?| ")endif" |s|))

(DEFUN |shoeElse?| (|s|) (|shoePrefix?| ")else" |s|))

(DEFUN |shoeElseIf?| (|s|) (|shoePrefix?| ")elseif" |s|))

(DEFUN |shoeLisp?| (|s|) (|shoePrefix?| ")lisp" |s|))

(DEFUN |shoeLine?| (|s|) (|shoePrefix?| ")line" |s|))

(DEFUN |shoeInclude| (|s|) (|bDelay| #'|shoeInclude1| (LIST |s|)))

(DEFUN |shoeInclude1| (|s|)
  (PROG (|command| |string| |t| |h|)
    (RETURN
     (COND ((|bStreamNull| |s|) |s|)
           (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
            (SETQ |string| (CAR |h|))
            (COND ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|)
                  ((SETQ |command| (|shoeIf?| |string|))
                   (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|))
                  (T
                   (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))

(DEFUN |shoeSimpleLine| (|h|)
  (PROG (|command| |string|)
    (RETURN
     (PROGN
      (SETQ |string| (CAR |h|))
      (COND ((|shoePlainLine?| |string|) (LIST |h|))
            ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
            ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
            ((SETQ |command| (|shoeSay?| |string|)) (|shoeConsole| |command|)
             NIL)
            ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) NIL)
            (T (|shoeLineSyntaxError| |h|) NIL))))))

(DEFUN |shoeThen| (|keep| |b| |s|)
  (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|)))

(DEFUN |shoeThen1| (|keep| |b| |s|)
  (PROG (|b1| |keep1| |command| |string| |t| |h|)
    (RETURN
     (COND ((|bPremStreamNull| |s|) |s|)
           (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
            (SETQ |string| (CAR |h|))
            (COND
             ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
             (T (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|))
              (COND
               ((SETQ |command| (|shoeIf?| |string|))
                (COND
                 ((AND |keep1| |b1|)
                  (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
                              |t|))
                 (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
               ((SETQ |command| (|shoeElseIf?| |string|))
                (COND
                 ((AND |keep1| (NOT |b1|))
                  (|shoeThen| (CONS T (CDR |keep|))
                              (CONS (STTOMC |command|) (CDR |b|)) |t|))
                 (T
                  (|shoeThen| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
                              |t|))))
               ((SETQ |command| (|shoeElse?| |string|))
                (COND
                 ((AND |keep1| (NOT |b1|))
                  (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|)) |t|))
                 (T
                  (|shoeElse| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
                              |t|))))
               ((SETQ |command| (|shoeEndIf?| |string|))
                (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
                      (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
               ((AND |keep1| |b1|)
                (|bAppend| (|shoeSimpleLine| |h|) (|shoeThen| |keep| |b| |t|)))
               (T (|shoeThen| |keep| |b| |t|))))))))))

(DEFUN |shoeElse| (|keep| |b| |s|)
  (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))

(DEFUN |shoeElse1| (|keep| |b| |s|)
  (PROG (|keep1| |b1| |command| |string| |t| |h|)
    (RETURN
     (COND ((|bPremStreamNull| |s|) |s|)
           (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
            (SETQ |string| (CAR |h|))
            (COND
             ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
             (T (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|))
              (COND
               ((SETQ |command| (|shoeIf?| |string|))
                (COND
                 ((AND |keep1| |b1|)
                  (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
                              |t|))
                 (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
               ((SETQ |command| (|shoeEndIf?| |string|))
                (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
                      (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
               ((AND |keep1| |b1|)
                (|bAppend| (|shoeSimpleLine| |h|) (|shoeElse| |keep| |b| |t|)))
               (T (|shoeElse| |keep| |b| |t|))))))))))

(DEFUN |shoeLineSyntaxError| (|h|)
  (PROGN
   (|shoeConsole|
    (CONCAT "INCLUSION SYNTAX ERROR IN LINE " (WRITE-TO-STRING (CDR |h|))))
   (|shoeConsole| (CAR |h|))
   (|shoeConsole| "LINE IGNORED")))

(DEFUN |bPremStreamNil| (|h|)
  (PROGN
   (|shoeConsole|
    (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|))))
   (|shoeConsole| (CAR |h|))
   (|shoeConsole| "REST OF FILE IGNORED")
   |$bStreamNil|))

(DEFUN |bPremStreamNull| (|s|)
  (COND ((|bStreamNull| |s|) (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
        (T NIL)))