1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32
33)package "BOOT"
34
35-- Dequeue functions
36
37-- dqUnit makes a unit dq i.e. a dq with one item, from the item
38
39-- dqAppend appends 2 dq's, destroying the first
40
41-- dqConcat concatenates a list of dq's, destroying all but the last
42
43-- dqToList transforms a dq to a list
44
45dqUnit s==(a:=[s];CONS(a,a))
46
47dqAppend(x,y)==
48    if null x
49    then y
50    else if null y
51         then x
52         else
53              RPLACD(CDR x, first y)
54              RPLACD (x,    CDR y)
55              x
56
57dqConcat ld==
58    if null ld
59    then nil
60    else if null rest ld
61         then first ld
62         else dqAppend(first ld,dqConcat rest ld)
63
64dqToList s == if null s then nil else first s
65
66-- Pile functions
67
68-- insertpiles converts a line-list to a line-forest where
69
70-- a line is a token-dequeue and has a column which is an integer.
71-- an A-forest is an A-tree-list
72-- an A-tree has a root which is an A, and subtrees which is an A-forest.
73
74-- A forest with more than one tree corresponds to a Scratchpad pile
75-- structure (t1;t2;t3;...;tn), and a tree corresponds to a pile item.
76-- The ( ; and ) tokens are inserted into a >1-forest, otherwise
77-- the root of the first tree is concatenated with its forest.
78-- column t is the number of spaces before the first non-space in line t
79
80pileColumn t == rest tokPosn CAAR t
81pileComment t== EQ(tokType CAAR t,"negcomment")
82pilePlusComment t== EQ(tokType CAAR t,"comment")
83
84-- insertpile is used by next so s is non-null
85-- bite off a line-tree, return it and the remaining line-list.
86
87countParens(s, opar, cpar) ==
88   ress := 0
89   for stok in dqToList s repeat
90      t := tokPart stok
91      if EQ(CAAR stok,"key") and EQ(t, opar) then
92          ress := ress + 1
93      if EQ(CAAR stok,"key") and EQ(t, cpar) then
94          ress := ress - 1
95   ress
96
97nopile (s, opar, cpar) ==
98   -- SAY("nopile")
99   if npNull s
100   then [false,0,[],s]
101   else
102      [h,t]:=[car s,cdr s]
103      h := car h
104      ress := h
105      balance := countParens(h, opar, cpar)
106      -- SAY("balance = ", balance)
107      while not npNull t and balance > 0 repeat
108         h := car (car t)
109         t := cdr t
110         ress := dqAppend(ress, h)
111         balance := balance + countParens(h, opar, cpar)
112         -- SAY("balance = ", balance)
113      -- SAY("ress=", ress)
114      -- FIXME: we should return a pair [deque, stream], but
115      -- now we return nil instead of a stream
116      cons([[ress]], t)
117
118DEFPARAMETER($nopiles, false)
119
120setNopiles (t) ==
121    $nopiles := t
122
123piles () ==
124    $nopiles := false
125
126insertpile (s)==
127     $nopiles = "{" => nopile (s, "{", "}")
128     $nopiles = "(" => nopile (s, "(", ")")
129     if npNull s
130     then [false,0,[],s]
131     else
132       [h,t]:=[car s,cdr s]
133       if pilePlusComment h
134       then
135          [h1,t1]:=pilePlusComments s
136          a:=pileTree(-1,t1)
137          cons([pileCforest [:h1,a.2]],a.3)
138       else
139         stream:=CADAR s
140         a:=pileTree(-1,s)
141         cons([[a.2,stream]],a.3)
142
143pilePlusComments s==
144      if npNull s
145      then [[],s]
146      else
147       [h,t]:=[car s,cdr s]
148       if pilePlusComment h
149       then
150         [h1,t1]:=pilePlusComments t
151         [cons(h,h1),t1]
152       else [[],s]
153
154pileTree(n,s)==
155    if npNull s
156    then [false,n,[],s]
157    else
158        [h,t]:=[car s,cdr s]
159        hh := pileColumn first h
160        if hh > n
161        then pileForests(first h, hh, t)
162        else [false,n,[],s]
163
164eqpileTree(n,s)==
165    if npNull s
166    then [false,n,[],s]
167    else
168        [h,t]:=[car s,cdr s]
169        hh := pileColumn first h
170        if hh = n
171        then pileForests(first h, hh, t)
172        else [false,n,[],s]
173
174pileForest(n,s)==
175     [b,hh,h,t]:= pileTree(n,s)
176     if b
177     then
178       [h1,t1]:=pileForest1(hh,t)
179       [cons(h,h1),t1]
180     else [[],s]
181
182pileForest1(n,s)==
183     [b,n1,h,t]:= eqpileTree(n,s)
184     if b
185     then
186       [h1,t1]:=pileForest1(n,t)
187       [cons(h,h1),t1]
188     else [[],s]
189
190pileForests(h,n,s)==
191      [h1,t1]:=pileForest(n,s)
192      if npNull h1
193      then [true,n,h,s]
194      else pileForests(pileCtree(h,h1),n,t1)
195
196pileCtree(x,y)==dqAppend(x,pileCforest y)
197
198-- only enpiles forests with >=2 trees
199
200first_tok(t) == CAAR t
201last_tok(t) == CADR t
202
203pileCforest x==
204   if null x
205   then []
206   else if null cdr x
207        then
208           f:= car x
209           if EQ(tokPart first_tok(f),"if")
210           then enPile f
211           else f
212        else enPile separatePiles x
213
214firstTokPosn t== tokPosn first_tok(t)
215lastTokPosn  t== tokPosn last_tok(t)
216
217separatePiles x==
218  if null x
219  then []
220  else if null cdr x
221       then car x
222       else
223         a:=car x
224         lta := tokPart(last_tok(a))
225         ftb := tokPart(first_tok(car(cdr x)))
226         EQ(lta, ":") or EQ(lta, ";") or EQ(lta, "(") or
227           EQ(lta, "[") or EQ(lta, "{") or EQ(ftb, "in") or
228             EQ(ftb, "then") or EQ(ftb, "else") or EQ(ftb, ")") or
229               EQ(ftb, "]") or EQ(ftb, "}") =>
230                   dqConcat [a, separatePiles cdr x]
231         semicolon:=dqUnit tokConstruct("key", "BACKSET",lastTokPosn a)
232         dqConcat [a,semicolon,separatePiles cdr x]
233
234enPile x==
235   dqConcat [dqUnit tokConstruct("key","SETTAB",firstTokPosn x),
236             x, _
237             dqUnit tokConstruct("key","BACKTAB",lastTokPosn  x)]
238