1)package "BOOT"
2
3flattenSemi(tree) ==
4    not(CONSP(tree)) => tree
5    tree is [";", t1, t2] =>
6        t1 := flattenSemi(t1)
7        t2 := flattenSemi(t2)
8        t1 :=
9            t1 is [";",:rest] => rest
10            [t1]
11        t2 :=
12            t2 is [";",:rest] => rest
13            [t2]
14        [";", :t1, :t2]
15    tree is [";", :.] => BREAK()
16    [flattenSemi(el) for el in tree]
17
18--
19-- Expansion of macros and removal of macrodefinitions
20--
21
22expandMacros(tree) ==
23    ATOM tree =>
24        mdef := HGET($MacroTable, tree)
25        mdef =>
26            repval := first(mdef)
27            null(rest(mdef)) => expandMacros(repval)
28            userError("macro call needs arguments")
29        tree
30    -- floating point numbers
31    [op, :args] := tree
32    EQ(op, ":BF") => tree
33    ATOM(op) =>
34        mdef := HGET($MacroTable, op)
35        mdef =>
36            repval := first(mdef)
37            margs := rest(mdef)
38            null(margs) =>
39                [expandMacros(repval), :[expandMacros(x) for x in args]]
40            args :=
41                args is [[",", :args1]] => postFlatten(first(args), ",")
42                args
43            #args = #margs =>
44                expandMacros(SUBLISLIS(args, margs, repval))
45            userError("invalid macro call, #args ~= #margs")
46        [op, :[expandMacros(x) for x in args]]
47    [expandMacros(x) for x in tree]
48
49--
50--  Handling of extra definitions
51--
52
53replaceArgDef1(args, edef) ==
54    SYMBOLP args =>
55        edef is [":", args, .] => edef
56        BREAK()
57    args is  [",", args1, args2] =>
58        EQ(args2, NTH(1, edef)) => [",", args1, edef]
59        [",", replaceArgDef1(args1, edef), args2]
60    BREAK()
61
62replaceArgDef(h1, edef) ==
63   h1 is [name, args] => [name, replaceArgDef1(args, edef)]
64   BREAK()
65
66replaceArgDefs1(h1, edefs) ==
67    for edef in edefs repeat
68        h1 := replaceArgDef(h1, edef)
69    h1
70
71replaceArgDefs(header, edefs) ==
72    header is [":", h1, type] => [":", replaceArgDefs1(h1, edefs), type]
73    replaceArgDefs1(header, edefs)
74
75----------------------------------------------------------------------
76--
77-- Collect definitions from where list.  Returns list of definitions
78-- which can not be converted to macros
79--
80
81DEFPARAMETER($restore_list, nil)
82
83define_macro(name, def) ==
84    if SYMBOLP(name) then
85        def := [def]
86    else if name is [op, :args] and SYMBOLP(op) then
87        args :=
88            args is [[",", :args1]] => postFlatten(first(args), ",")
89            args
90        name := op
91        def := [def, :args]
92    else
93        SAY([name, def])
94        userError("Invalid macro definition")
95    prev_def := HGET($MacroTable, name)
96    PUSH([name, :prev_def], $restore_list)
97    HPUT($MacroTable, name, def)
98
99do_walk_where_list(tree) ==
100    lastIteration := false
101    ress := nil
102    while not(lastIteration) repeat
103        if tree is [";", tree1, el] then
104            tree := tree1
105        else
106            el := tree
107            lastIteration := true
108        el is ["==>", name, def] => define_macro(name, def)
109        el is ["==", name, def] =>
110            define_macro(name, def)
111        el is [":", ., .] =>
112            ress := [el, :ress]
113        el is [",", pel, item] =>
114            item is [":", sym, type] =>
115                sl := [sym]
116                while pel is [",", pel1, sym] repeat
117                    sl := [sym, :sl]
118                    pel := pel1
119                if not(SYMBOLP pel) then
120                    FORMAT(true, '"strange where |,| item2")
121                    BREAK()
122                sl := [pel, :sl]
123                for sym in sl repeat
124                    ress := [[":", sym, type], :ress]
125            FORMAT(true, '"strange where |,| item1")
126            BREAK()
127        FORMAT(true, '"strange where item: ~S~&", el)
128        BREAK()
129    ress
130
131------------------------------------------------------------------
132--
133-- Remove macros and where parts from global definitions
134--
135
136walkWhereList(name, def, env) ==
137    $restore_list : local := nil
138    edefs := do_walk_where_list env
139    ress := expandMacros(["==", replaceArgDefs(name, edefs), def])
140    for it in $restore_list repeat
141        [op, :def] := it
142        HPUT($MacroTable, op, def)
143    ress
144
145walkForm(tree) ==
146    tree is ["==>", name, def] =>
147        define_macro(name, def)
148        nil
149    tree is ["==", head, def] => expandMacros(tree)
150    tree is ["where", ["==", name, def], env] =>
151        walkWhereList(name, def, env)
152    userError("Parsing error: illegal toplevel form")
153    nil
154
155--------------------------------------------------------------------
156
157isNiladic(head1) ==
158    SYMBOLP head1 => true
159    head1 is [., ["@Tuple"]]
160
161getCon(head1) ==
162    SYMBOLP head1 => head1
163    first head1
164
165processGlobals1() ==
166    for form in $globalDefs repeat
167        [., head, :.] := form
168        head1 :=
169            head is [":", a, .] => a
170            head
171        con := getCon head1
172        -- at this stage distinction between domain and package does
173        -- not matter, so we treat packages as domains
174        if head is [":", ., "Category"] then
175            SETDATABASE(con, 'CONSTRUCTORKIND, "category")
176        else
177            SETDATABASE(con, 'CONSTRUCTORKIND, "domain")
178        SETDATABASE(con, 'NILADIC, isNiladic head1)
179
180processGlobals () ==
181    $InteractiveMode : local := nil
182    $globalDefs := REVERSE $globalDefs
183    processGlobals1()
184    $globalDefs := [parseTransform postTransform x for x in $globalDefs]
185    untypedDefs := []
186    for def in $globalDefs repeat
187        ["DEF", form, sig, sc, body] := def
188        cosig := CONS(nil, [categoryForm? ty for ty in rest(sig)])
189        SETDATABASE(first form, 'COSIG, cosig)
190        if null first(sig) then
191            untypedDefs := [def, :untypedDefs]
192        else
193            handleKind(def)
194
195    for def in untypedDefs repeat
196        ["DEF", form, sig, sc, body] := def
197        nt := computeTargetMode(form, body)
198        if nt then
199            handleKind(["DEF", form, [nt, :rest sig], sc, body])
200        else
201            SAY(["unhandled target", form])
202    boo_comp_cats()
203
204
205handleKind(df is ['DEF,form,sig,sc,body]) ==
206    [op,:argl] := form
207
208    null first(sig) => nil
209    if sig is [["Category"], :.] then
210        if body is ['add,cat,capsule] then
211            body := cat
212        sargl:= TAKE(# argl, $TriangleVariableList)
213        aList:= [[a,:sa] for a in argl for sa in sargl]
214        formalBody:= SUBLIS(aList,body)
215        if (not(opOf(formalBody) = "Join")) and _
216           (not(opOf(formalBody) = "mkCategory")) then
217           formalBody := ['Join, formalBody]
218        signature' := SUBLIS(aList,sig)
219        constructorCategory := formalBody
220    else
221        signature' := sig
222
223    pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList]
224    parSignature:= SUBLIS(pairlis,signature')
225    parForm:= SUBLIS(pairlis,form)
226    constructorModemap := removeZeroOne [[parForm,:parSignature],[true,op]]
227    SETDATABASE(op, 'CONSTRUCTORMODEMAP, constructorModemap)
228    SETDATABASE(op, 'CONSTRUCTORCATEGORY, constructorCategory)
229
230boo_comp_cats() ==
231    $compiler_output_stream := MAKE_-BROADCAST_-STREAM()
232    $bootStrapMode : local := true
233    SAY(["boo_comp_cats"])
234    hcats := []
235    for def in $globalDefs repeat
236        ["DEF", form, sig, sc, body] := def
237        if sig is [["Category"], :.] then
238            SAY(["doing", form, sig])
239            not("and"/[categoryForm? ty for ty in rest(sig)]) =>
240                hcats := cons(def, hcats)
241            boo_comp1(def)
242    for def in hcats repeat boo_comp1(def)
243
244boo_comp1(x) ==
245    $Index : local := 0
246    $MACROASSOC : local := []
247    $compUniquelyIfTrue : local := nil
248    $postStack : local := nil
249    $topOp : local := nil
250    $semanticErrorStack : local := []
251    $warningStack : local := []
252    $exitMode : local := $EmptyMode
253    $exitModeStack : local := []
254    $returnMode : local := $EmptyMode
255    $leaveLevelStack : local := []
256    $CategoryFrame : local := [[[]]]
257    $insideFunctorIfTrue : local := false
258    $insideWhereIfTrue : local := false
259    $insideCategoryIfTrue : local := false
260    $insideCapsuleFunctionIfTrue : local := false
261    $e : local := $EmptyEnvironment
262    $genSDVar : local :=  0
263    $previousTime : local := get_run_time()
264    compTopLevel(x, $EmptyMode,  [[[]]])
265    if $semanticErrorStack then displaySemanticErrors()
266
267-- for domains
268--   $lisplibCategory := modemap.mmTarget
269-- for categories
270--   $lisplibCategory:= formalBody
271
272computeTargetMode(lhs, rhs) ==
273    PRETTYPRINT(["computeTargetMode", lhs])
274    rhs is ['CAPSULE,:.] => MOAN(['"target category of ", lhs,_
275          '" cannot be determined from definition"],nil)
276    rhs is ['SubDomain,D,:.] => computeTargetMode(lhs,D)
277    rhs is ['add,D,['CAPSULE,:.]] => computeTargetMode(lhs,D)
278    rhs is ['Record,:l] => ['RecordCategory,:l]
279    rhs is ['Union,:l] => ['UnionCategory,:l]
280    rhs is ['List,:l] => ['ListCategory,:l]
281    rhs is ['Vector,:l] => ['VectorCategory,:l]
282
283    rhs is [op, :argl] =>
284        modemap := GETDATABASE(op, 'CONSTRUCTORMODEMAP)
285        modemap is [[form, sig, :.], [=true,.]] =>
286            pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList]
287            -- substitute
288            SUBLIS(pairlis, sig)
289        PRETTYPRINT("strange untyped def")
290        PRETTYPRINT([lhs, rhs, modemap])
291        nil
292    BREAK()
293
294)if false
295
296 abbreviation               ; +-
297 ancestors                  ; interp.
298 constructor                ; unused
299 constructorcategory        ; +
300 constructorkind            ; +
301 constructormodemap         ; +- (need to handle untyped definitions)
302 cosig                      ; +
303 defaultdomain              ; + used only in interpreter, values is
304                              computed in daase.lisp, but is unused
305                              (getdatabase returns value from hardcoded list)
306 modemaps                   ; almost unused in the compiler -- used to
307                              invalidate old modemaps when updating
308                              *operation-hash* (which in turn is used
309                              only in interpreter).
310 niladic                    ; +
311 object                     ; +-
312 operationalist             ; interp.
313
314)endif
315
316DEFVAR($PrintOnly, false)
317DEFVAR($RawParseOnly, false)
318DEFVAR($PostTranOnly, false)
319DEFVAR($FlatParseOnly, false)
320DEFVAR($TranslateOnly, false)
321DEFVAR($noEarlyMacroexpand, false)
322DEFVAR($SaveParseOnly, false)
323DEFVAR($globalDefs, nil)
324DEFVAR($MacroTable)
325
326S_process(x) ==
327    $Index : local := 0
328    $MACROASSOC : local := nil
329    $compUniquelyIfTrue : local := false
330    $postStack : local := nil
331    $topOp : local := nil
332    $semanticErrorStack : local := nil
333    $warningStack : local := nil
334    $exitMode : local := $EmptyMode
335    $exitModeStack : local := nil
336    $returnMode : local := $EmptyMode
337    $leaveLevelStack : local := nil
338    $CategoryFrame : local := [[[]]]
339    $insideFunctorIfTrue : local := false
340    $insideWhereIfTrue : local := false
341    $insideCategoryIfTrue : local := false
342    $insideCapsuleFunctionIfTrue : local := false
343    $e : local := $EmptyEnvironment
344    $genSDVar : local := 0
345    $previousTime : local := get_run_time()
346    $s : local := nil
347    $x : local := nil
348    $m : local := nil
349    null(x) => nil
350    $SaveParseOnly =>
351        x := walkForm(x)
352        if x then PUSH(x, $globalDefs)
353    $RawParseOnly => PRETTYPRINT(x)
354    $FlatParseOnly => PRETTYPRINT(flattenSemi x)
355    $PostTranOnly => PRETTYPRINT(postTransform x)
356    nform :=
357        $noEarlyMacroexpand => x
358        walkForm x
359    null(nform) => nil
360    x := parseTransform(postTransform(nform))
361    $TranslateOnly => $Translation := x
362    $postStack =>
363        displayPreCompilationErrors()
364        userError "precompilation failed"
365    $PrintOnly =>
366        FORMAT(true, '"~S   =====>~%", $currentLine)
367        PRETTYPRINT(x)
368    u := compTopLevel(x, $EmptyMode, $InteractiveFrame)
369    if u then $InteractiveFrame := THIRD(u)
370    if $semanticErrorStack then displaySemanticErrors()
371    TERPRI()
372