aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap/includer.clisp
blob: e2cf37f214e47e54aa836738163670e89ebc0a2c (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
(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|)
  (LET* (|l|)
    (PROGN
     (SETQ |l| (LENGTH |s|))
     (COND ((NOT (< |n| |l|)) NIL)
           (T
            (READ-FROM-STRING
             (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")")))))))

(DEFUN |shoeConsole| (|line|)
  (DECLARE (SPECIAL |$stdio|))
  (WRITE-LINE |line| |$stdio|))

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

(DEFUN |diagnosticLocation| (|tok|)
  (LET* (|pos|)
    (PROGN
     (SETQ |pos| (|tokenPosition| |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|)))

(DEFSTRUCT (|%SourceLine| (:COPIER |copy%SourceLine|)) |str| |num|)

(DEFMACRO |mk%SourceLine| (|str| |num|)
  (LIST '|MAKE-%SourceLine| :|str| |str| :|num| |num|))

(DEFMACRO |sourceLineString| (|bfVar#1|) (LIST '|%SourceLine-str| |bfVar#1|))

(DEFMACRO |sourceLineNumber| (|bfVar#1|) (LIST '|%SourceLine-num| |bfVar#1|))

(DEFMACRO |makeSourceLine| (|s| |n|) (LIST '|mk%SourceLine| |s| |n|))

(DEFUN |lineNo| (|p|) (|sourceLineNumber| (CAAR |p|)))

(DEFUN |lineString| (|p|) (|sourceLineString| (CAAR |p|)))

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

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

(DEFUN |bStreamNull| (|x|)
  (LET* (|st| |args| |op| |ISTMP#1|)
    (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|)
  (LET* (|h|)
    (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|)
  (LET* (|a|)
    (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 (|makeSourceLine| (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|)
  (LET* (|good|)
    (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|)
  (LET* (|command| |string| |t| |h|)
    (COND ((|bStreamNull| |s|) |s|)
          (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
           (SETQ |string| (|sourceLineString| |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|)
  (LET* (|command| |string|)
    (PROGN
     (SETQ |string| (|sourceLineString| |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|)
  (LET* (|b1| |keep1| |command| |string| |t| |h|)
    (COND ((|bPremStreamNull| |s|) |s|)
          (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
           (SETQ |string| (|sourceLineString| |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|)
  (LET* (|keep1| |b1| |command| |string| |t| |h|)
    (COND ((|bPremStreamNull| |s|) |s|)
          (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
           (SETQ |string| (|sourceLineString| |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 (|sourceLineNumber| |h|))))
   (|shoeConsole| (|sourceLineString| |h|))
   (|shoeConsole| "LINE IGNORED")))

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

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