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