aboutsummaryrefslogtreecommitdiff
path: root/src/boot/strap/pile.clisp
blob: 5481f2fe107862000c8ed0fce2c5311d01ed9791 (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
(PROVIDE "pile")

(IMPORT-MODULE "includer")

(IMPORT-MODULE "scanner")

(IN-PACKAGE "BOOTTRAN")

(DEFUN |shoeFirstTokPosn| (|t|) (|shoeTokPosn| (CAAR |t|)))

(DEFUN |shoeLastTokPosn| (|t|) (|shoeTokPosn| (CADR |t|)))

(DEFUN |shoePileColumn| (|t|) (CDR (|shoeTokPosn| (CAAR |t|))))

(DEFUN |shoePileInsert| (|s|)
  (PROG (|a| |toktype|)
    (RETURN
      (COND
        ((|bStreamNull| |s|) (CONS NIL |s|))
        (#0='T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
         (COND
           ((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
            (CONS (LIST (CAR |s|)) (CDR |s|)))
           (#0# (SETQ |a| (|shoePileTree| (- 1) |s|))
            (CONS (LIST (ELT |a| 2)) (ELT |a| 3)))))))))

(DEFUN |shoePileTree| (|n| |s|)
  (PROG (|hh| |t| |h| |LETTMP#1|)
    (RETURN
      (COND
        ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
        (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
         (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
         (SETQ |hh| (|shoePileColumn| |h|))
         (COND
           ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
           (#0# (LIST NIL |n| NIL |s|))))))))

(DEFUN |eqshoePileTree| (|n| |s|)
  (PROG (|hh| |t| |h| |LETTMP#1|)
    (RETURN
      (COND
        ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
        (#0='T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
         (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
         (SETQ |hh| (|shoePileColumn| |h|))
         (COND
           ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
           (#0# (LIST NIL |n| NIL |s|))))))))

(DEFUN |shoePileForest| (|n| |s|)
  (PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|)
    (RETURN
      (PROGN
        (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
        (SETQ |b| (CAR |LETTMP#1|))
        (SETQ |hh| (CADR . #0=(|LETTMP#1|)))
        (SETQ |h| (CADDR . #0#))
        (SETQ |t| (CADDDR . #0#))
        (COND
          (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
               (SETQ |h1| (CAR |LETTMP#1|))
               (SETQ |t1| (CADR |LETTMP#1|))
               (LIST (CONS |h| |h1|) |t1|))
          ('T (LIST NIL |s|)))))))

(DEFUN |shoePileForest1| (|n| |s|)
  (PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|)
    (RETURN
      (PROGN
        (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
        (SETQ |b| (CAR |LETTMP#1|))
        (SETQ |n1| (CADR . #0=(|LETTMP#1|)))
        (SETQ |h| (CADDR . #0#))
        (SETQ |t| (CADDDR . #0#))
        (COND
          (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
               (SETQ |h1| (CAR |LETTMP#1|))
               (SETQ |t1| (CADR |LETTMP#1|))
               (LIST (CONS |h| |h1|) |t1|))
          ('T (LIST NIL |s|)))))))

(DEFUN |shoePileForests| (|h| |n| |s|)
  (PROG (|t1| |h1| |LETTMP#1|)
    (RETURN
      (PROGN
        (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
        (SETQ |h1| (CAR |LETTMP#1|))
        (SETQ |t1| (CADR |LETTMP#1|))
        (COND
          ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
          ('T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|)))))))

(DEFUN |shoePileCtree| (|x| |y|)
  (|dqAppend| |x| (|shoePileCforest| |y|)))

(DEFUN |shoePileCforest| (|x|)
  (PROG (|b| |a|)
    (RETURN
      (COND
        ((NULL |x|) NIL)
        ((NULL (CDR |x|)) (CAR |x|))
        (#0='T (SETQ |a| (CAR |x|))
         (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
         (COND
           ((NULL (CDR |b|)) (CAR |b|))
           (#0# (|shoeEnPile| (|shoeSeparatePiles| |b|)))))))))

(DEFUN |shoePileCoagulate| (|a| |b|)
  (PROG (|e| |d| |c|)
    (RETURN
      (COND
        ((NULL |b|) (LIST |a|))
        (#0='T (SETQ |c| (CAR |b|))
         (COND
           ((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
                (EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
            (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
           (#0# (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
            (COND
              ((AND (EQCAR |d| 'KEY)
                    (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
                        (EQ |e| 'SEMICOLON)))
               (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
              (#0# (CONS |a| (|shoePileCoagulate| |c| (CDR |b|))))))))))))

(DEFUN |shoeSeparatePiles| (|x|)
  (PROG (|semicolon| |a|)
    (RETURN
      (COND
        ((NULL |x|) NIL)
        ((NULL (CDR |x|)) (CAR |x|))
        ('T (SETQ |a| (CAR |x|))
         (SETQ |semicolon|
               (|dqUnit|
                   (|shoeTokConstruct| 'KEY 'BACKSET
                       (|shoeLastTokPosn| |a|))))
         (|dqConcat|
             (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))))

(DEFUN |shoeEnPile| (|x|)
  (|dqConcat|
      (LIST (|dqUnit|
                (|shoeTokConstruct| 'KEY 'SETTAB
                    (|shoeFirstTokPosn| |x|)))
            |x|
            (|dqUnit|
                (|shoeTokConstruct| 'KEY 'BACKTAB
                    (|shoeLastTokPosn| |x|))))))