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--% Utilities
36
37DEFPARAMETER($locVars, nil)
38DEFPARAMETER($PrettyPrint, false)
39DEFPARAMETER($COMPILE, true)
40
41flattenCOND body ==
42  -- transforms nested COND clauses to flat ones, if possible
43  body isnt ['COND,:.] => body
44  ['COND,:extractCONDClauses body]
45
46extractCONDClauses clauses ==
47  -- extracts nested COND clauses into a flat structure
48  clauses is ['COND, [pred1,:act1],:restClauses] =>
49    if act1 is [['PROGN,:acts]] then act1 := acts
50    restClauses is [[''T,restCond]] =>
51      [[pred1,:act1],:extractCONDClauses restCond]
52    [[pred1,:act1],:restClauses]
53  [[''T,clauses]]
54
55-- from comp.lisp
56
57)if false
58
59PURPOSE: Comp is a modified version of Compile which is a preprocessor for
60         calls to Lisp Compile.  It searches for variable assignments of
61         form (SPADLET a b). It allows you to create local variables without
62         declaring them local by moving them into a PROG variable list.
63
64         Comp recognizes as new lambda types the forms SPADSLAM, SLAM,
65         and entries on $clamList.  These cache results.  ("Saving LAMbda".)
66         If the function is called with EQUAL arguments, returns the previous
67         result computed.
68
69         Comp expands iteration constructs (REPEAT, COLLECT, ...).
70
71         The package also causes traced things which are recompiled to
72         become untraced.
73
74         This code was used for Boot, but now is only used on output
75         of Spad and interpreter compilers.
76)endif
77
78COMP_1(x) ==
79  [fname, lamex, :.] := x
80  $FUNNAME : local := fname
81  $CLOSEDFNS : local := nil
82  lamex := compTran lamex
83  compNewnam lamex
84  if FBOUNDP(fname) then
85      FORMAT(true, '"~&~%;;;     ***       ~S REDEFINED~%", fname)
86  [[fname, lamex], :$CLOSEDFNS]
87
88COMP_2(args) ==
89    [name, [type, argl, :bodyl], :junk] := args
90    junk => MOAN (FORMAT(nil, '"******pren error in (~S (~S ...) ...)",_
91                         name, type))
92    type is "SLAM" => BREAK()
93    type is 'domain_functor =>
94        compHash(name, argl, bodyl, "$ConstructorCache", 'domainEqualList)
95    type is 'category_functor => compSPADSLAM(name, argl, bodyl)
96    if type = 'mutable_domain_functor then
97        type := 'LAMBDA
98    bodyl := [name, [type, argl, :bodyl]]
99    if $PrettyPrint then PPRINT(bodyl)
100    if NULL($COMPILE) then
101      SAY '"No Compilation"
102    else
103      COMP370(bodyl)
104    name
105
106COMP(fun) == [COMP_2 nf for nf in COMP_1(fun)]
107
108maybe_devaluate(a, ca) ==
109    ca => ["devaluate", a]
110    a
111
112compSPADSLAM(name, argl, bodyl) ==
113    al := INTERNL1(name, '";AL")
114    auxfn := INTERNL1(name, '";")
115    if argl then
116        g2 := GENSYM()
117        g3 := GENSYM()
118        argtran :=
119            -- we call 'devaluate' only on domains
120            not(rest(argl)) =>
121                maybe_devaluate(first(argl), first($functor_cosig1))
122            ["LIST", :[maybe_devaluate(g1, c1) for g1 in argl
123                                               for c1 in $functor_cosig1]]
124        app :=
125            not(rest(argl)) => [auxfn, g3]
126            ["APPLY", ["FUNCTION", auxfn], g3]
127        la1 := [["SETQ", g2, ["assoc", g3, al]], ["CDR", g2]]
128        la2 := [true, ["SETQ", al,
129                           ["cons5",
130                                ["CONS", g3, ["SETQ", g2, app]], al]],
131                            g2]
132        lamex := ["LAMBDA", argl,
133                    ["LET", [g2, [g3, argtran]],
134                      ["COND", la1, la2]]]
135    else
136        lamex := ["LAMBDA", [],
137                    ["COND", [al], [true, ["SETQ", al, [auxfn]]]]]
138
139    output_lisp_defparameter(al, nil)
140    u := [name,lamex]
141    if $PrettyPrint then PRETTYPRINT(u)
142    COMP370(u)
143    u := [auxfn, ["LAMBDA", argl, :bodyl]]
144    if $PrettyPrint then PRETTYPRINT(u)
145    COMP370(u)
146    name
147
148makeClosedfnName() ==
149    INTERN(CONCAT($FUNNAME, '"!", STRINGIMAGE(LENGTH($CLOSEDFNS))))
150
151lambdaHelper1(y) ==
152    NOT(MEMQ(y, $locVars)) =>
153        $locVars := [y, :$locVars]
154        $newBindings := [y, :$newBindings]
155
156lambdaHelper2(y) == MEMQ(y, $newBindings)
157
158compTran1(x) ==
159    ATOM(x) => nil
160    u := first(x)
161    u = "QUOTE" => nil
162    u = "MAKEPROP" => BREAK()
163    MEMQ(u, '(SPADLET SETQ LET)) =>
164        RPLACA(x, "LETT")
165        compTran1(CDDR x)
166        NOT(u = "SETQ") =>
167            IDENTP(CADR(x)) => PUSHLOCVAR(CADR(x))
168            EQCAR(CADR(x), "FLUID") => BREAK()
169            BREAK()
170            MAPC(FUNCTION PUSHLOCVAR, LISTOFATOMS(CADR x))
171    MEMQ(u, '(PROG LAMBDA)) =>
172        $newBindings : local := nil
173        MAPCAR(FUNCTION lambdaHelper1, x.1)
174        res := compTran1(CDDR(x))
175        $locVars := REMOVE_-IF(FUNCTION lambdaHelper2, $locVars)
176        [u, CADR(x), :res]
177    compTran1 u
178    compTran1(rest x)
179
180compTranDryRun(x) ==
181    $insideCapsuleFunctionIfTrue : local := false
182    compTran(x)
183
184compTran(x) ==
185    $locVars : local := nil
186    [x1, x2, :xl3] := comp_expand(x)
187    compTran1 (xl3)
188    [x3, :xlt3] := xl3
189    x3 :=
190        NULL(xlt3) and (ATOM(x3) or _
191                            first(x3) = "SEQ" or _
192                            not(CONTAINED("EXIT", x3))) => x3
193        ["SEQ", :xl3]
194    $locVars := set_difference(REMDUP(NREVERSE($locVars)),
195                               LISTOFATOMS (x2))
196    lvars := $locVars
197    x3 :=
198        lvars or CONTAINED("RETURN", x3) =>
199            ["SPROG", compSpadProg(lvars), x3]
200        x3
201    x2 := addTypesToArgs(x2)
202    [x1, x2, x3]
203
204addTypesToArgs(args) ==
205    $insideCapsuleFunctionIfTrue =>
206        sig := $signatureOfForm
207        spadTypes := [(ATOM(t) => [t]; t) for t in [:rest(sig), first(sig)]]
208        [[a, :t] for a in args for t in spadTypes]
209    args
210
211addNilTypesToArgs(args) ==
212    $insideCapsuleFunctionIfTrue =>
213        [[arg, nil] for arg in args]
214    args
215
216compSpadProg(lvars) ==
217    lvarTypes := ($insideCapsuleFunctionIfTrue => $locVarsTypes; nil)
218    types := []
219    for lvar in lvars repeat
220        x := ASSOC(lvar, lvarTypes)
221        types := [[lvar, (x => rest(x); nil)], :types]
222    NREVERSE(types)
223
224compNewnam(x) ==
225    ATOM(x) => nil
226    y := first(x)
227    ATOM(y) =>
228        if not(y = "QUOTE") then compNewnam(rest(x))
229        if y = "CLOSEDFN" and BOUNDP('$CLOSEDFNS) then
230            u := makeClosedfnName()
231            PUSH([u, CADR(x)], $CLOSEDFNS)
232            RPLACA(x, "FUNCTION")
233            RPLACA(rest(x), u)
234    compNewnam(first(x))
235    compNewnam(rest(x))
236
237PUSHLOCVAR(x) ==
238    x ~= "$" and SCHAR('"$", 0) = SCHAR(PNAME(x), 0) _
239      and (not(SCHAR('",", 0) = SCHAR(PNAME(x), 1)) or BREAK())
240      and not(DIGITP (SCHAR(PNAME(x), 1))) => nil
241    PUSH(x, $locVars)
242
243comp_expand(x) ==
244    ATOM(x) => x
245    x is ["QUOTE",:.] => x
246    x is ["SPADREDUCE", op, axis, body] => BREAK()
247    x is ["REPEAT", :body] => comp_expand(expandREPEAT(body))
248    x is ["COLLECT", :body] => comp_expand(expandCOLLECT(body))
249    x is ["COLLECTV", :body] => comp_expand(expandCOLLECTV(body))
250    x is ["COLLECTVEC", :body] => comp_expand(expandCOLLECTV(body))
251    a := comp_expand (car x)
252    b := comp_expand (cdr x)
253    a = first x and b = rest x => x
254    CONS(a, b)
255
256repeat_tran(l, lp) ==
257    ATOM(l) => ERROR('"REPEAT FORMAT ERROR")
258    IFCAR(IFCAR(l)) in '(EXIT RESET IN ON GSTEP ISTEP STEP
259                     UNTIL WHILE SUCHTHAT) =>
260        repeat_tran(rest(l), [first(l), :lp])
261    [NREVERSE(lp), :MKPF(l, "PROGN")]
262
263expandCOLLECT(l) ==
264    [conds, :body] := repeat_tran(l, [])
265    -- create init of accumulate
266    init := ["SPADLET", G := GENSYM(), []]
267    ASSOC("EXIT", conds) => BREAK()
268    res := ["NREVERSE", G]
269    -- next code to accumulate result
270    acc := ["SETQ", G, ["CONS", body, G]]
271    ["PROGN", init, ["REPEAT", ["EXIT", res], :conds, acc]]
272
273BADDO(OL) == ERROR(FORMAT(nil, '"BAD DO FORMAT~%~A", OL))
274
275expandDO(vl, endtest, exitforms, body_forms) ==
276    vars := []
277    u_vars := []
278    u_vals := []
279    inits := []
280    for vi in vl repeat
281        [v, init] := vi
282        not(IDENTP(v)) => BADDO(OL)
283        vars := [v, :vars]
284        inits := [init, :inits]
285        if vi is [., ., u_val] then
286            u_vars := [v, :u_vars]
287            u_vals := [u_val, :u_vals]
288    if endtest then endtest := ["COND", [endtest, ["GO", "G191"]]]
289    exitforms := ["EXIT", exitforms]
290    u_vars3 := nil
291    for vv in u_vars for uu in u_vals repeat
292        u_vars3 :=
293            NULL(u_vars3) => ["SETQ", vv, uu]
294            ["SETQ", vv, ["PROG1", uu, u_vars3]]
295    lets := [["SPADLET", var, init] for var in vars for init in inits]
296    ["SEQ", :lets, :["G190", endtest, body_forms,
297          u_vars3, ["GO", "G190"], "G191", exitforms]]
298
299seq_opt(seq) ==
300   seq is ["SEQ", ["EXIT", body]] and body is ["SEQ",:.] => body
301   seq
302
303MK_inc_SI(x) ==
304    ATOM(x) => ['inc_SI, x]
305    x is [op, xx, 1] and (op = 'sub_SI or op = "-") => xx
306    ['inc_SI, x]
307
308$TRACELETFLAG := false
309
310expandREPEAT(l) ==
311    [conds, :body] := repeat_tran(l, [])
312    tests := []
313    vl := []
314    result_expr := nil
315    for X in conds repeat
316        ATOM(X) => BREAK()
317        U := rest(X)
318        -- A hack to increase the likelihood of small integers
319        if X is ["STEP", ., i1, i2, :.] and member(i1, '(2 1 0 (One) (Zero)))
320           and member(i2, '(1 (One))) then X := ["ISTEP", :U]
321        op := first(X)
322        op = "GSTEP" =>
323            [var, empty_form, step_form, init_form] := U
324            tests := [["OR", ["SPADCALL", empty_form],
325                             ["PROGN", ["SETQ", var, ["SPADCALL", step_form]],
326                                  nil]], :tests]
327            vl := [[var, init_form], :vl]
328        op = "STEP" =>
329            [var, start, inc, :op_limit] := U
330            -- If not constant compute only once
331            if not(INTEGERP(inc)) then
332                vl := [[(tmp := GENSYM()), inc], :vl]
333                inc := tmp
334            if op_limit then
335                -- If not constant compute only once
336                if not(INTEGERP(final := first(op_limit))) then
337                    vl := [[(tmp := GENSYM()), final], :vl]
338                    final := tmp
339                tests :=
340                  [(INTEGERP(inc) =>
341                     [(MINUSP(inc) => "<" ; ">"), var, final];
342                        ["IF", ["MINUSP", inc],
343                          ["<", var, final],
344                            [">", var, final]]),
345                              :tests]
346            vl := [[var, start, ["+", var, inc]], :vl]
347        op = "ISTEP" =>
348            [var, start, inc, :op_limit] := U
349            -- If not constant compute only once
350            if not(INTEGERP(inc)) then
351                vl := [[(tmp := GENSYM()), inc], :vl]
352                inc := tmp
353            if op_limit then
354                if not(INTEGERP(final := first(op_limit))) then
355                    -- If not constant compute only once
356                    vl := [[(tmp := GENSYM()), final], :vl]
357                    final := tmp
358                tests :=
359                  [(INTEGERP(inc) =>
360                     [(negative?_SI(inc) => "less_SI" ; "greater_SI"),
361                       var, final];
362                        ["IF", ["negative?_SI", inc],
363                          ["less_SI", var, final],
364                            ["greater_SI", var, final]]),
365                              :tests]
366            vl := [[var, start,
367                 (member(inc, '(1 (One))) => MK_inc_SI(first(U));
368                   ["add_SI", var, inc])], :vl]
369        op = "ON" =>
370            tests := [["ATOM", first(U)], :tests]
371            vl := [[first(U), CADR(U), ["CDR", first(U)]], :vl]
372        op = "RESET" => tests := [["PROGN", first(U), nil], :tests]
373        op = "IN" =>
374            tt :=
375                SYMBOLP(first(U)) and SYMBOL_-PACKAGE(first(U))
376                  and $TRACELETFLAG =>
377                    [["/TRACELET-PRINT", first(U), (first U)]]
378                nil
379            tests := [["OR", ["ATOM", (G := GENSYM())],
380                             ["PROGN", ["SETQ", first(U), ["CAR", G]],
381                               :APPEND(tt, [nil])]], :tests]
382            vl := [[G, CADR(U), ["CDR", G]], :vl]
383            vl := [[first(U), nil], :vl]
384        op = "UNTIL" =>
385            G := GENSYM()
386            tests := [G, :tests]
387            vl := [[G, nil, first(U)], :vl]
388        op = "WHILE" => tests := [["NULL", first(U)], :tests]
389        op = "SUCHTHAT" => body := ["COND", [first(U), body]]
390        op = "EXIT" =>
391            result_expr => BREAK()
392            result_expr := first(U)
393        FAIL()
394    expandDO(NREVERSE(vl), MKPF(NREVERSE(tests), "OR"), result_expr,
395             seq_opt(["SEQ", ["EXIT", body]]))
396
397expandCOLLECTV(l) ==
398    -- If we can work out how often we will go round allocate a vector first
399    conds :=  []
400    [body, :iters] := REVERSE(l)
401    counter_var := nil
402    ret_val := nil
403    for iter in iters repeat
404        op := first(iter)
405        op in '(SUCHTHAT WHILE UNTIL GSTEP) =>
406            ret_val := ["LIST2VEC", ["COLLECT", :l]]
407            return nil -- break loop
408        op in '(IN ON) =>
409            conds := [["SIZE", CADDR(iter)], :conds]
410        op in '(STEP ISTEP) =>
411            [., var, start, step, :opt_limit] := iter
412            if start = 0 and step = 1 then
413                counter_var := var
414            -- there may not be a limit
415            if opt_limit then
416                limit := first(opt_limit)
417                cond :=
418                    step = 1 =>
419                        start = 1 => limit
420                        start = 0 => MK_inc_SI(limit)
421                        MK_inc_SI(["-", limit, start])
422                    start = 1 => ["/", limit, step]
423                    start = 0 => ["/", MK_inc_SI(limit), step]
424                    ["/", ["-", MK_inc_SI(limit), start],
425                                            step]
426                conds := [cond, :conds]
427        ERROR('"Cannot handle COLLECTV expansion")
428    ret_val => ret_val
429    if NULL(counter_var) then
430        counter_var := GENSYM()
431        iters := [["ISTEP", counter_var, 0, 1], :iters]
432    lv :=
433        NULL(conds) => FAIL()
434        NULL(rest(conds)) => first(conds)
435        ["MIN", :conds]
436    res := GENSYM()
437    ["PROGN", ["SPADLET", res, ["GETREFV", lv]],
438              ["REPEAT", :iters, ["SETELT", res, counter_var, body]],
439                 res]
440
441DEFPARAMETER($comp370_apply, nil)
442
443COMP370(fn) ==
444    not(fn is [fname, [ltype, args, :body]]) => BREAK()
445    args :=
446        NULL(args) => args
447        LISTP(args) and $insideCapsuleFunctionIfTrue =>
448            [(STRINGP(CAR(arg)) => CONS(GENTEMP(), CDR(arg));
449              not(SYMBOLP(CAR(arg))) => BREAK();
450              arg)
451             for arg in args]
452        SYMBOLP(args) => ["&REST", args]
453        ATOM(args) => BREAK()
454        [(STRINGP(arg) => GENTEMP(); not(SYMBOLP(arg)) => BREAK(); arg)
455            for arg in args]
456    defun := if $insideCapsuleFunctionIfTrue then "SDEFUN" else "DEFUN"
457    nbody := [defun, fname, args, :body]
458    if $comp370_apply then
459        FUNCALL($comp370_apply, fname, nbody)
460
461MKPF(l, op) ==
462    if GET(op, "NARY") then
463        l := MKPFFLATTEN1(l, op, nil)
464    MKPF1(l, op)
465
466MKPFFLATTEN(x, op) ==
467    ATOM(x) => x
468    EQL(first(x), op) => [op, :MKPFFLATTEN1(rest x, op, nil)]
469    [MKPFFLATTEN(first x, op), :MKPFFLATTEN(rest x, op)]
470
471MKPFFLATTEN1(l, op, r) ==
472    NULL(l) => r
473    x := MKPFFLATTEN(first(l), op)
474    MKPFFLATTEN1(rest l, op, APPEND(r, (x is [=op, :r1] => r1; [x])))
475
476MKPF1(l, op) ==
477    op = "PLUS" => BREAK()
478    op = "TIMES" => BREAK()
479    op = "QUOTIENT" => BREAK()
480    op = "MINUS" => BREAK()
481    op = "DIFFERENCE" => BREAK()
482    op = "EXPT" =>
483        l is [x, y] =>
484            EQL(y, 0) => 1
485            EQL(y, 1) => x
486            member(x, '(0 1 (ZERO) (ONE))) => x
487            ["EXPT", :l]
488        FAIL()
489    op = "OR" =>
490        MEMBER(true, l) => ["QUOTE", true]
491        l := REMOVE(false, l)
492        NULL(l) => false
493        rest(l) => ["OR", :l]
494        first(l)
495    op = "or" =>
496        MEMBER(true, l) => true
497        l := REMOVE(false, l)
498        NULL(l) => false
499        rest(l) => ["or", :l]
500        first(l)
501    op = "NULL" =>
502        rest(l) => FAIL()
503        l is [["NULL", :l1]] => first(l1)
504        first(l) = true => false
505        NULL(first(l)) => ["QUOTE", true]
506        ["NULL", :l]
507    op = "and" =>
508        l := REMOVE(true, REMOVE("true", l))
509        NULL(l) => true
510        rest(l) => ["and", :l]
511        first(l)
512    op = "AND" =>
513        l := REMOVE(true, REMOVE("true", l))
514        NULL(l) => ["QUOTE", true]
515        rest(l) => ["AND", :l]
516        first(l)
517    op = "PROGN" =>
518        l := REMOVE(nil, l)
519        NULL(l) => nil
520        rest(l) => ["PROGN", :l]
521        first(l)
522    op = "SEQ" =>
523        l is [["EXIT", :l1], :.] => first(l1)
524        rest(l) => ["SEQ", :l]
525        first(l)
526    op = "LIST" =>
527        l => ["LIST", :l]
528        nil
529    op = "CONS" =>
530        rest(l) => ["CONS", :l]
531        first(l)
532    [op, :l]
533