From 0850ca5458cb09b2d04cec162558500e9a05cf4a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Thu, 20 Sep 2007 14:50:49 +0000 Subject: Revert commits to the wrong tree. --- src/interp/Makefile.in | 174 +- src/interp/Makefile.pamphlet | 168 +- src/interp/axext_l.lisp | 201 -- src/interp/axext_l.lisp.pamphlet | 230 ++ src/interp/bc-matrix.boot | 153 -- src/interp/bc-matrix.boot.pamphlet | 175 ++ src/interp/bc-misc.boot | 924 ------- src/interp/bc-misc.boot.pamphlet | 946 +++++++ src/interp/bc-solve.boot | 362 --- src/interp/bc-solve.boot.pamphlet | 384 +++ src/interp/bc-util.boot | 125 - src/interp/bc-util.boot.pamphlet | 147 ++ src/interp/br-con.boot | 1381 ----------- src/interp/br-con.boot.pamphlet | 1407 +++++++++++ src/interp/br-data.boot | 783 ------ src/interp/br-data.boot.pamphlet | 809 ++++++ src/interp/br-op1.boot | 1135 --------- src/interp/br-op1.boot.pamphlet | 1161 +++++++++ src/interp/br-op2.boot | 764 ------ src/interp/br-op2.boot.pamphlet | 790 ++++++ src/interp/br-prof.boot | 265 -- src/interp/br-prof.boot.pamphlet | 288 +++ src/interp/br-saturn.boot | 1890 -------------- src/interp/br-saturn.boot.pamphlet | 1916 ++++++++++++++ src/interp/br-search.boot | 1014 -------- src/interp/br-search.boot.pamphlet | 1040 ++++++++ src/interp/br-util.boot | 712 ------ src/interp/br-util.boot.pamphlet | 738 ++++++ src/interp/buildom.boot | 364 --- src/interp/buildom.boot.pamphlet | 386 +++ src/interp/c-doc.boot | 1272 ---------- src/interp/c-doc.boot.pamphlet | 1298 ++++++++++ src/interp/cattable.boot | 501 ---- src/interp/cattable.boot.pamphlet | 527 ++++ src/interp/cfuns.lisp | 101 - src/interp/cfuns.lisp.pamphlet | 123 + src/interp/clam.boot | 702 ------ src/interp/clam.boot.pamphlet | 729 ++++++ src/interp/clammed.boot | 207 -- src/interp/clammed.boot.pamphlet | 229 ++ src/interp/compress.boot | 67 - src/interp/compress.boot.pamphlet | 89 + src/interp/cstream.boot | 111 - src/interp/cstream.boot.pamphlet | 147 ++ src/interp/database.boot | 671 ----- src/interp/database.boot.pamphlet | 697 ++++++ src/interp/domain.lisp.pamphlet | 247 ++ src/interp/fnewmeta.lisp | 740 ------ src/interp/fnewmeta.lisp.pamphlet | 1012 ++++++++ src/interp/format.boot | 780 ------ src/interp/format.boot.pamphlet | 802 ++++++ src/interp/fortcall.boot | 798 ------ src/interp/fortcall.boot.pamphlet | 820 ++++++ src/interp/functor.boot | 983 -------- src/interp/functor.boot.pamphlet | 1009 ++++++++ src/interp/g-boot.boot | 459 ---- src/interp/g-boot.boot.pamphlet | 485 ++++ src/interp/g-cndata.boot | 240 -- src/interp/g-cndata.boot.pamphlet | 262 ++ src/interp/g-error.boot | 199 -- src/interp/g-error.boot.pamphlet | 224 ++ src/interp/g-opt.boot | 399 --- src/interp/g-opt.boot.pamphlet | 421 ++++ src/interp/g-timer.boot | 270 -- src/interp/g-timer.boot.pamphlet | 292 +++ src/interp/g-util.boot | 635 ----- src/interp/g-util.boot.pamphlet | 663 +++++ src/interp/guess.boot | 347 --- src/interp/guess.boot.pamphlet | 369 +++ src/interp/hash.lisp | 121 - src/interp/hash.lisp.pamphlet | 147 ++ src/interp/hashcode.boot | 109 - src/interp/hashcode.boot.pamphlet | 131 + src/interp/ht-root.boot | 289 --- src/interp/ht-root.boot.pamphlet | 311 +++ src/interp/ht-util.boot.pamphlet | 753 ++++++ src/interp/htcheck.boot | 127 - src/interp/htcheck.boot.pamphlet | 153 ++ src/interp/htsetvar.boot | 478 ---- src/interp/htsetvar.boot.pamphlet | 500 ++++ src/interp/hypertex.boot | 120 - src/interp/hypertex.boot.pamphlet | 142 ++ src/interp/i-analy.boot | 810 ------ src/interp/i-analy.boot.pamphlet | 832 +++++++ src/interp/i-code.boot | 142 -- src/interp/i-code.boot.pamphlet | 164 ++ src/interp/i-eval.boot | 452 ---- src/interp/i-eval.boot.pamphlet | 474 ++++ src/interp/i-map.boot | 1159 --------- src/interp/i-map.boot.pamphlet | 1185 +++++++++ src/interp/interop.boot | 906 ------- src/interp/interop.boot.pamphlet | 933 +++++++ src/interp/interp-fix.boot | 77 - src/interp/interp-fix.boot.pamphlet | 99 + src/interp/interp-proclaims.lisp | 3391 +++++++++++++++++++++++++ src/interp/intfile.boot | 61 - src/interp/intfile.boot.pamphlet | 83 + src/interp/intint.lisp | 146 -- src/interp/intint.lisp.pamphlet | 168 ++ src/interp/iterator.boot | 293 --- src/interp/iterator.boot.pamphlet | 319 +++ src/interp/lisplib.boot | 686 ----- src/interp/lisplib.boot.pamphlet | 712 ++++++ src/interp/macex.boot | 189 -- src/interp/macex.boot.pamphlet | 211 ++ src/interp/match.boot | 220 -- src/interp/match.boot.pamphlet | 242 ++ src/interp/modemap.boot | 353 --- src/interp/modemap.boot.pamphlet | 379 +++ src/interp/msg.boot | 551 ---- src/interp/msg.boot.pamphlet | 577 +++++ src/interp/nag-c02.boot | 294 --- src/interp/nag-c02.boot.pamphlet | 316 +++ src/interp/nag-c05.boot | 402 --- src/interp/nag-c05.boot.pamphlet | 424 ++++ src/interp/nag-c06.boot | 1832 -------------- src/interp/nag-c06.boot.pamphlet | 1854 ++++++++++++++ src/interp/nag-d01.boot | 1337 ---------- src/interp/nag-d01.boot.pamphlet | 1359 ++++++++++ src/interp/nag-d02.boot | 2146 ---------------- src/interp/nag-d02.boot.pamphlet | 2168 ++++++++++++++++ src/interp/nag-d03.boot | 639 ----- src/interp/nag-d03.boot.pamphlet | 661 +++++ src/interp/nag-e01.boot | 1758 ------------- src/interp/nag-e01.boot.pamphlet | 1780 +++++++++++++ src/interp/nag-e02.boot | 4671 ---------------------------------- src/interp/nag-e02.boot.pamphlet | 4693 +++++++++++++++++++++++++++++++++++ src/interp/nag-e02b.boot | 1735 ------------- src/interp/nag-e02b.boot.pamphlet | 1757 +++++++++++++ src/interp/nag-e04.boot | 2498 ------------------- src/interp/nag-e04.boot.pamphlet | 2520 +++++++++++++++++++ src/interp/nag-f01.boot | 2230 ----------------- src/interp/nag-f01.boot.pamphlet | 2252 +++++++++++++++++ src/interp/nag-f02.boot | 2733 -------------------- src/interp/nag-f02.boot.pamphlet | 2755 ++++++++++++++++++++ src/interp/nag-f04.boot | 2309 ----------------- src/interp/nag-f04.boot.pamphlet | 2331 +++++++++++++++++ src/interp/nag-f07.boot | 704 ------ src/interp/nag-f07.boot.pamphlet | 726 ++++++ src/interp/nag-s.boot | 1582 ------------ src/interp/nag-s.boot.pamphlet | 1604 ++++++++++++ src/interp/newfort.boot | 945 ------- src/interp/newfort.boot.pamphlet | 967 ++++++++ src/interp/nhyper.boot | 119 - src/interp/nhyper.boot.pamphlet | 141 ++ src/interp/nruncomp.boot | 743 ------ src/interp/nruncomp.boot.pamphlet | 769 ++++++ src/interp/nrunfast.boot | 670 ----- src/interp/nrunfast.boot.pamphlet | 692 ++++++ src/interp/nrungo.boot | 395 --- src/interp/nrungo.boot.pamphlet | 417 ++++ src/interp/nrunopt.boot | 903 ------- src/interp/nrunopt.boot.pamphlet | 929 +++++++ src/interp/nruntime.boot | 58 - src/interp/nruntime.boot.pamphlet | 80 + src/interp/osyscmd.boot | 53 - src/interp/osyscmd.boot.pamphlet | 75 + src/interp/package.boot | 274 -- src/interp/package.boot.pamphlet | 300 +++ src/interp/packtran.boot | 60 - src/interp/packtran.boot.pamphlet | 86 + src/interp/pathname.boot | 143 -- src/interp/pathname.boot.pamphlet | 165 ++ src/interp/pf2atree.boot | 553 ----- src/interp/pf2atree.boot.pamphlet | 575 +++++ src/interp/pf2sex.boot | 461 ---- src/interp/pf2sex.boot.pamphlet | 526 ++++ src/interp/postpar.boot | 529 ---- src/interp/postpar.boot.pamphlet | 555 +++++ src/interp/profile.boot | 89 - src/interp/profile.boot.pamphlet | 111 + src/interp/pspad1.boot | 741 ------ src/interp/pspad1.boot.pamphlet | 767 ++++++ src/interp/pspad2.boot | 661 ----- src/interp/pspad2.boot.pamphlet | 683 +++++ src/interp/redefs.boot.pamphlet | 92 + src/interp/rulesets.boot | 303 --- src/interp/rulesets.boot.pamphlet | 325 +++ src/interp/server.boot | 218 -- src/interp/server.boot.pamphlet | 240 ++ src/interp/setq.lisp | 468 ---- src/interp/setq.lisp.pamphlet | 496 ++++ src/interp/sfsfun-l.lisp | 69 - src/interp/sfsfun-l.lisp.pamphlet | 91 + src/interp/showimp.boot | 252 -- src/interp/showimp.boot.pamphlet | 278 +++ src/interp/simpbool.boot | 203 -- src/interp/simpbool.boot.pamphlet | 225 ++ src/interp/slam.boot | 335 --- src/interp/slam.boot.pamphlet | 359 +++ src/interp/sockio.lisp | 241 -- src/interp/sockio.lisp.pamphlet | 263 ++ src/interp/spad.lisp | 596 ----- src/interp/spad.lisp.pamphlet | 626 +++++ src/interp/spaderror.lisp | 113 - src/interp/spaderror.lisp.pamphlet | 141 ++ src/interp/topics.boot | 9 +- src/interp/topics.boot.pamphlet | 263 ++ src/interp/util.lisp.pamphlet | 7 +- src/interp/wi1.boot | 1261 ---------- src/interp/wi1.boot.pamphlet | 1287 ++++++++++ src/interp/wi2.boot | 1229 --------- src/interp/wi2.boot.pamphlet | 1255 ++++++++++ src/interp/word.boot | 400 --- src/interp/word.boot.pamphlet | 422 ++++ 205 files changed, 74351 insertions(+), 66975 deletions(-) delete mode 100644 src/interp/axext_l.lisp create mode 100644 src/interp/axext_l.lisp.pamphlet delete mode 100644 src/interp/bc-matrix.boot create mode 100644 src/interp/bc-matrix.boot.pamphlet delete mode 100644 src/interp/bc-misc.boot create mode 100644 src/interp/bc-misc.boot.pamphlet delete mode 100644 src/interp/bc-solve.boot create mode 100644 src/interp/bc-solve.boot.pamphlet delete mode 100644 src/interp/bc-util.boot create mode 100644 src/interp/bc-util.boot.pamphlet delete mode 100644 src/interp/br-con.boot create mode 100644 src/interp/br-con.boot.pamphlet delete mode 100644 src/interp/br-data.boot create mode 100644 src/interp/br-data.boot.pamphlet delete mode 100644 src/interp/br-op1.boot create mode 100644 src/interp/br-op1.boot.pamphlet delete mode 100644 src/interp/br-op2.boot create mode 100644 src/interp/br-op2.boot.pamphlet delete mode 100644 src/interp/br-prof.boot create mode 100644 src/interp/br-prof.boot.pamphlet delete mode 100644 src/interp/br-saturn.boot create mode 100644 src/interp/br-saturn.boot.pamphlet delete mode 100644 src/interp/br-search.boot create mode 100644 src/interp/br-search.boot.pamphlet delete mode 100644 src/interp/br-util.boot create mode 100644 src/interp/br-util.boot.pamphlet delete mode 100644 src/interp/buildom.boot create mode 100644 src/interp/buildom.boot.pamphlet delete mode 100644 src/interp/c-doc.boot create mode 100644 src/interp/c-doc.boot.pamphlet delete mode 100644 src/interp/cattable.boot create mode 100644 src/interp/cattable.boot.pamphlet delete mode 100644 src/interp/cfuns.lisp create mode 100644 src/interp/cfuns.lisp.pamphlet delete mode 100644 src/interp/clam.boot create mode 100644 src/interp/clam.boot.pamphlet delete mode 100644 src/interp/clammed.boot create mode 100644 src/interp/clammed.boot.pamphlet delete mode 100644 src/interp/compress.boot create mode 100644 src/interp/compress.boot.pamphlet delete mode 100644 src/interp/cstream.boot create mode 100644 src/interp/cstream.boot.pamphlet delete mode 100644 src/interp/database.boot create mode 100644 src/interp/database.boot.pamphlet create mode 100644 src/interp/domain.lisp.pamphlet delete mode 100644 src/interp/fnewmeta.lisp create mode 100644 src/interp/fnewmeta.lisp.pamphlet delete mode 100644 src/interp/format.boot create mode 100644 src/interp/format.boot.pamphlet delete mode 100644 src/interp/fortcall.boot create mode 100644 src/interp/fortcall.boot.pamphlet delete mode 100644 src/interp/functor.boot create mode 100644 src/interp/functor.boot.pamphlet delete mode 100644 src/interp/g-boot.boot create mode 100644 src/interp/g-boot.boot.pamphlet delete mode 100644 src/interp/g-cndata.boot create mode 100644 src/interp/g-cndata.boot.pamphlet delete mode 100644 src/interp/g-error.boot create mode 100644 src/interp/g-error.boot.pamphlet delete mode 100644 src/interp/g-opt.boot create mode 100644 src/interp/g-opt.boot.pamphlet delete mode 100644 src/interp/g-timer.boot create mode 100644 src/interp/g-timer.boot.pamphlet delete mode 100644 src/interp/g-util.boot create mode 100644 src/interp/g-util.boot.pamphlet delete mode 100644 src/interp/guess.boot create mode 100644 src/interp/guess.boot.pamphlet delete mode 100644 src/interp/hash.lisp create mode 100644 src/interp/hash.lisp.pamphlet delete mode 100644 src/interp/hashcode.boot create mode 100644 src/interp/hashcode.boot.pamphlet delete mode 100644 src/interp/ht-root.boot create mode 100644 src/interp/ht-root.boot.pamphlet create mode 100644 src/interp/ht-util.boot.pamphlet delete mode 100644 src/interp/htcheck.boot create mode 100644 src/interp/htcheck.boot.pamphlet delete mode 100644 src/interp/htsetvar.boot create mode 100644 src/interp/htsetvar.boot.pamphlet delete mode 100644 src/interp/hypertex.boot create mode 100644 src/interp/hypertex.boot.pamphlet delete mode 100644 src/interp/i-analy.boot create mode 100644 src/interp/i-analy.boot.pamphlet delete mode 100644 src/interp/i-code.boot create mode 100644 src/interp/i-code.boot.pamphlet delete mode 100644 src/interp/i-eval.boot create mode 100644 src/interp/i-eval.boot.pamphlet delete mode 100644 src/interp/i-map.boot create mode 100644 src/interp/i-map.boot.pamphlet delete mode 100644 src/interp/interop.boot create mode 100644 src/interp/interop.boot.pamphlet delete mode 100644 src/interp/interp-fix.boot create mode 100644 src/interp/interp-fix.boot.pamphlet create mode 100644 src/interp/interp-proclaims.lisp delete mode 100644 src/interp/intfile.boot create mode 100644 src/interp/intfile.boot.pamphlet delete mode 100644 src/interp/intint.lisp create mode 100644 src/interp/intint.lisp.pamphlet delete mode 100644 src/interp/iterator.boot create mode 100644 src/interp/iterator.boot.pamphlet delete mode 100644 src/interp/lisplib.boot create mode 100644 src/interp/lisplib.boot.pamphlet delete mode 100644 src/interp/macex.boot create mode 100644 src/interp/macex.boot.pamphlet delete mode 100644 src/interp/match.boot create mode 100644 src/interp/match.boot.pamphlet delete mode 100644 src/interp/modemap.boot create mode 100644 src/interp/modemap.boot.pamphlet delete mode 100644 src/interp/msg.boot create mode 100644 src/interp/msg.boot.pamphlet delete mode 100644 src/interp/nag-c02.boot create mode 100644 src/interp/nag-c02.boot.pamphlet delete mode 100644 src/interp/nag-c05.boot create mode 100644 src/interp/nag-c05.boot.pamphlet delete mode 100644 src/interp/nag-c06.boot create mode 100644 src/interp/nag-c06.boot.pamphlet delete mode 100644 src/interp/nag-d01.boot create mode 100644 src/interp/nag-d01.boot.pamphlet delete mode 100644 src/interp/nag-d02.boot create mode 100644 src/interp/nag-d02.boot.pamphlet delete mode 100644 src/interp/nag-d03.boot create mode 100644 src/interp/nag-d03.boot.pamphlet delete mode 100644 src/interp/nag-e01.boot create mode 100644 src/interp/nag-e01.boot.pamphlet delete mode 100644 src/interp/nag-e02.boot create mode 100644 src/interp/nag-e02.boot.pamphlet delete mode 100644 src/interp/nag-e02b.boot create mode 100644 src/interp/nag-e02b.boot.pamphlet delete mode 100644 src/interp/nag-e04.boot create mode 100644 src/interp/nag-e04.boot.pamphlet delete mode 100644 src/interp/nag-f01.boot create mode 100644 src/interp/nag-f01.boot.pamphlet delete mode 100644 src/interp/nag-f02.boot create mode 100644 src/interp/nag-f02.boot.pamphlet delete mode 100644 src/interp/nag-f04.boot create mode 100644 src/interp/nag-f04.boot.pamphlet delete mode 100644 src/interp/nag-f07.boot create mode 100644 src/interp/nag-f07.boot.pamphlet delete mode 100644 src/interp/nag-s.boot create mode 100644 src/interp/nag-s.boot.pamphlet delete mode 100644 src/interp/newfort.boot create mode 100644 src/interp/newfort.boot.pamphlet delete mode 100644 src/interp/nhyper.boot create mode 100644 src/interp/nhyper.boot.pamphlet delete mode 100644 src/interp/nruncomp.boot create mode 100644 src/interp/nruncomp.boot.pamphlet delete mode 100644 src/interp/nrunfast.boot create mode 100644 src/interp/nrunfast.boot.pamphlet delete mode 100644 src/interp/nrungo.boot create mode 100644 src/interp/nrungo.boot.pamphlet delete mode 100644 src/interp/nrunopt.boot create mode 100644 src/interp/nrunopt.boot.pamphlet delete mode 100644 src/interp/nruntime.boot create mode 100644 src/interp/nruntime.boot.pamphlet delete mode 100644 src/interp/osyscmd.boot create mode 100644 src/interp/osyscmd.boot.pamphlet delete mode 100644 src/interp/package.boot create mode 100644 src/interp/package.boot.pamphlet delete mode 100644 src/interp/packtran.boot create mode 100644 src/interp/packtran.boot.pamphlet delete mode 100644 src/interp/pathname.boot create mode 100644 src/interp/pathname.boot.pamphlet delete mode 100644 src/interp/pf2atree.boot create mode 100644 src/interp/pf2atree.boot.pamphlet delete mode 100644 src/interp/pf2sex.boot create mode 100644 src/interp/pf2sex.boot.pamphlet delete mode 100644 src/interp/postpar.boot create mode 100644 src/interp/postpar.boot.pamphlet delete mode 100644 src/interp/profile.boot create mode 100644 src/interp/profile.boot.pamphlet delete mode 100644 src/interp/pspad1.boot create mode 100644 src/interp/pspad1.boot.pamphlet delete mode 100644 src/interp/pspad2.boot create mode 100644 src/interp/pspad2.boot.pamphlet create mode 100644 src/interp/redefs.boot.pamphlet delete mode 100644 src/interp/rulesets.boot create mode 100644 src/interp/rulesets.boot.pamphlet delete mode 100644 src/interp/server.boot create mode 100644 src/interp/server.boot.pamphlet delete mode 100644 src/interp/setq.lisp create mode 100644 src/interp/setq.lisp.pamphlet delete mode 100644 src/interp/sfsfun-l.lisp create mode 100644 src/interp/sfsfun-l.lisp.pamphlet delete mode 100644 src/interp/showimp.boot create mode 100644 src/interp/showimp.boot.pamphlet delete mode 100644 src/interp/simpbool.boot create mode 100644 src/interp/simpbool.boot.pamphlet delete mode 100644 src/interp/slam.boot create mode 100644 src/interp/slam.boot.pamphlet delete mode 100644 src/interp/sockio.lisp create mode 100644 src/interp/sockio.lisp.pamphlet delete mode 100644 src/interp/spad.lisp create mode 100644 src/interp/spad.lisp.pamphlet delete mode 100644 src/interp/spaderror.lisp create mode 100644 src/interp/spaderror.lisp.pamphlet create mode 100644 src/interp/topics.boot.pamphlet delete mode 100644 src/interp/wi1.boot create mode 100644 src/interp/wi1.boot.pamphlet delete mode 100644 src/interp/wi2.boot create mode 100644 src/interp/wi2.boot.pamphlet delete mode 100644 src/interp/word.boot create mode 100644 src/interp/word.boot.pamphlet (limited to 'src/interp') diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index c908ae52..ab300b8b 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -30,11 +30,11 @@ depsys_lisp_sources = $(depsys_lisp_noncompiled_sources) \ depsys_boot_sources = postpar.boot parse.boot clam.boot slam.boot \ g-boot.boot g-error.boot c-util.boot g-util.boot -DEP= $(srcdir)/spaderror.lisp debug.lisp \ - $(srcdir)/spad.lisp \ - $(srcdir)/setq.lisp property.lisp \ +DEP= spaderror.lisp debug.lisp \ + spad.lisp \ + setq.lisp property.lisp \ unlisp.lisp foam_l.lisp \ - $(srcdir)/axext_l.lisp + axext_l.lisp depsys_lisp_macro_sources = vmlisp.lisp ggreater.lisp hash.lisp \ union.lisp nlib.lisp macros.lisp \ @@ -349,7 +349,7 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ bookvol5.$(FASLEXT)\ util.$(FASLEXT) \ postpar.$(FASLEXT) \ - parse.$(FASLEXT) \ + parse.clisp \ parsing.$(FASLEXT) \ metalex.$(FASLEXT) \ bootlex.$(FASLEXT) \ @@ -378,9 +378,10 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ @ echo '(|importModule| "util")' >> makedep.lisp @ echo '(in-package "BOOT")' >> makedep.lisp @ echo '(build-depsys (quote ($(patsubst %, "%", ${DEP}))) "${AXIOM}")' >> makedep.lisp + @ echo '(unless (probe-file "parse.$(FASLEXT)") (|compileLispFile| "parse.clisp" "parse.$(FASLEXT)"))' >> makedep.lisp @ echo '(in-package "AxiomCore")' >> makedep.lisp @ echo '(|importModule| "newaux")' >> makedep.lisp - @ echo '(|importModule| "parse")' >> makedep.lisp + @ echo '(load "parse")' >> makedep.lisp @ echo '(|importModule| "metalex")' >> makedep.lisp @ echo '(|importModule| "parsing")' >> makedep.lisp @ echo '(|importModule| "fnewmeta")' >> makedep.lisp @@ -405,7 +406,8 @@ ${DEPSYS}: vmlisp.$(FASLEXT) \ ../lisp/base-lisp$(EXEEXT) -- --make --output=$@ \ --load-directory=. makedep.lisp @rm $(addsuffix .$(FASLEXT), \ - clam slam g-error g-boot c-util g-util) + parse clam slam g-error \ + g-boot c-util g-util) @ echo 4 ${DEPSYS} created @@ -580,86 +582,86 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp as.clisp: as.boot @ echo 417 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "as.boot"))' | ${DEPSYS} ax.clisp: ax.boot @ echo 463 making $@ $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ax.boot"))' | ${DEPSYS} bc-matrix.clisp: bc-matrix.boot @ echo 424 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-matrix.boot"))' | ${DEPSYS} bc-misc.clisp: bc-misc.boot @ echo 428 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-misc.boot"))' | ${DEPSYS} bc-solve.clisp: bc-solve.boot @ echo 432 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-solve.boot"))' | ${DEPSYS} bc-util.clisp: bc-util.boot @ echo 436 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-util.boot"))' | ${DEPSYS} br-con.clisp: br-con.boot @ echo 467 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-con.boot"))' | ${DEPSYS} br-data.clisp: br-data.boot @ echo 483 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-data.boot"))' | ${DEPSYS} br-op1.clisp: br-op1.boot @ echo 475 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-op1.boot"))' | ${DEPSYS} br-op2.clisp: br-op2.boot @ echo 479 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-op2.boot"))' | ${DEPSYS} br-prof.clisp: br-prof.boot @ echo 499 making $@ from $< @ ($(axiom_build_document) --tangle --output=br-prof.boot $< ;\ - echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS}; \ + echo '(progn (old-boot::boot "br-prof.boot"))' | ${DEPSYS}; \ rm br-prof.boot ) br-saturn.clisp: br-saturn.boot @ echo 491 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-saturn.boot"))' | ${DEPSYS} br-search.clisp: br-search.boot @ echo 471 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-search.boot"))' | ${DEPSYS} br-util.clisp: br-util.boot @ echo 487 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-util.boot"))' | ${DEPSYS} category.clisp: category.boot @ echo 212 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "category.boot"))' | ${DEPSYS} cattable.clisp: cattable.boot @ echo 215 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "cattable.boot"))' | ${DEPSYS} c-doc.clisp: c-doc.boot @ echo 219 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "c-doc.boot"))' | ${DEPSYS} clammed.clisp: clammed.boot @ echo 226 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "clammed.boot"))' | ${DEPSYS} compat.clisp: compat.boot @ echo 229 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "compat.boot"))' | ${DEPSYS} compiler.clisp: compiler.boot @ echo 233 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "compiler.boot"))' | ${DEPSYS} c-util.${LISP}: $(srcdir)/c-util.boot.pamphlet @ echo 146 making c-util.${LISP} from $(srcdir)/c-util.boot.pamphlet @@ -668,85 +670,85 @@ c-util.${LISP}: $(srcdir)/c-util.boot.pamphlet c-util.clisp: c-util.boot @ echo 148 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "c-util.boot"))' | ${DEPSYS} database.clisp: database.boot @ echo 243 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "database.boot"))' | ${DEPSYS} define.clisp: define.boot @ echo 247 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "define.boot"))' | ${DEPSYS} format.clisp: format.boot @ echo 250 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "format.boot"))' | ${DEPSYS} fortcall.clisp: fortcall.boot @ echo 55 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "fortcall.boot"))' | ${DEPSYS} functor.clisp: functor.boot @ echo 254 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "functor.boot"))' | ${DEPSYS} g-cndata.clisp: g-cndata.boot @ echo 261 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-cndata.boot"))' | ${DEPSYS} g-opt.clisp: g-opt.boot @ echo 267 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-opt.boot"))' | ${DEPSYS} g-timer.clisp: g-timer.boot @ echo 270 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-timer.boot"))' | ${DEPSYS} htcheck.clisp: htcheck.boot @ echo 455 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "htcheck.boot"))' | ${DEPSYS} ht-root.clisp: ht-root.boot @ echo 451 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ht-root.boot"))' | ${DEPSYS} htsetvar.clisp: htsetvar.boot @ echo 444 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "htsetvar.boot"))' | ${DEPSYS} ht-util.clisp: ht-util.boot @ echo 440 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ht-util.boot"))' | ${DEPSYS} hypertex.clisp: hypertex.boot @ echo 277 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "hypertex.boot"))' | ${DEPSYS} i-analy.clisp: i-analy.boot @ echo 280 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-analy.boot"))' | ${DEPSYS} i-code.clisp: i-code.boot @ echo 283 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-code.boot"))' | ${DEPSYS} i-coerce.clisp: i-coerce.boot @ echo 286 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-coerce.boot"))' | ${DEPSYS} i-coerfn.clisp: i-coerfn.boot @ echo 289 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-coerfn.boot"))' | ${DEPSYS} i-eval.clisp: i-eval.boot @ echo 292 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-eval.boot"))' | ${DEPSYS} i-funsel.clisp: i-funsel.boot @ echo 295 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-funsel.boot"))' | ${DEPSYS} bookvol5.lisp: $(srcdir)/bookvol5.pamphlet @ echo 298 making $@ from $< @@ -754,173 +756,173 @@ bookvol5.lisp: $(srcdir)/bookvol5.pamphlet i-intern.clisp: i-intern.boot @ echo 301 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-intern.boot"))' | ${DEPSYS} i-map.clisp: i-map.boot @ echo 304 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-map.boot"))' | ${DEPSYS} info.clisp: info.boot @ echo 329 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "info.boot"))' | ${DEPSYS} i-resolv.clisp: i-resolv.boot @ echo 310 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-resolv.boot"))' | ${DEPSYS} i-spec1.clisp: i-spec1.boot @ echo 313 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-spec1.boot"))' | ${DEPSYS} i-spec2.clisp: i-spec2.boot @ echo 316 making $@ from i-spec2.boot - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-spec2.boot"))' | ${DEPSYS} i-syscmd.clisp: i-syscmd.boot @ echo 319 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-syscmd.boot"))' | ${DEPSYS} iterator.clisp: iterator.boot @ echo 333 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "iterator.boot"))' | ${DEPSYS} i-toplev.clisp: i-toplev.boot @ echo 322 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-toplev.boot"))' | ${DEPSYS} i-util.clisp: i-util.boot @ echo 325 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-util.boot"))' | ${DEPSYS} lisplib.clisp: lisplib.boot @ echo 336 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "lisplib.boot"))' | ${DEPSYS} match.clisp: match.boot @ echo 339 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "match.boot"))' | ${DEPSYS} modemap.clisp: modemap.boot @ echo 343 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "modemap.boot"))' | ${DEPSYS} msgdb.clisp: msgdb.boot @ echo 346 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "msgdb.boot"))' | ${DEPSYS} nag-c02.clisp: nag-c02.boot @ echo 152 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c02.boot"))' | ${DEPSYS} nag-c05.clisp: nag-c05.boot @ echo 156 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c05.boot"))' | ${DEPSYS} nag-c06.clisp: nag-c06.boot @ echo 160 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c06.boot"))' | ${DEPSYS} nag-d01.clisp: nag-d01.boot @ echo 164 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d01.boot"))' | ${DEPSYS} nag-d02.clisp: nag-d02.boot @ echo 168 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d02.boot"))' | ${DEPSYS} nag-d03.clisp: nag-d03.boot @ echo 172 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d03.boot"))' | ${DEPSYS} nag-e01.clisp: nag-e01.boot @ echo 176 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e01.boot"))' | ${DEPSYS} nag-e02.clisp: nag-e02.boot @ echo 184 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e02.boot"))' | ${DEPSYS} nag-e04.clisp: nag-e04.boot @ echo 188 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e04.boot"))' | ${DEPSYS} nag-f01.clisp: nag-f01.boot @ echo 192 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f01.boot"))' | ${DEPSYS} nag-f02.clisp: nag-f02.boot @ echo 196 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f02.boot"))' | ${DEPSYS} nag-f04.clisp: nag-f04.boot @ echo 200 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f04.boot"))' | ${DEPSYS} nag-f07.clisp: nag-f07.boot @ echo 204 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f07.boot"))' | ${DEPSYS} nag-s.clisp: nag-s.boot @ echo 208 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-s.boot"))' | ${DEPSYS} newfort.clisp: newfort.boot @ echo 349 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "newfort.boot"))' | ${DEPSYS} nruncomp.clisp: nruncomp.boot @ echo 353 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nruncomp.boot"))' | ${DEPSYS} nrunfast.clisp: nrunfast.boot @ echo 356 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrunfast.boot"))' | ${DEPSYS} nrungo.clisp: nrungo.boot @ echo 359 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrungo.boot"))' | ${DEPSYS} nruntime.clisp: nruntime.boot @ echo 362 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nruntime.boot"))' | ${DEPSYS} nrunopt.clisp: nrunopt.boot @ echo 365 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrunopt.boot"))' | ${DEPSYS} profile.clisp: profile.boot @ echo 237 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "profile.boot"))' | ${DEPSYS} record.clisp: record.boot @ echo 447 making $@ $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "record.boot"))' | ${DEPSYS} rulesets.clisp: rulesets.boot @ echo 388 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "rulesets.boot"))' | ${DEPSYS} server.clisp: server.boot @ echo 391 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "server.boot"))' | ${DEPSYS} setvart.clisp: setvart.boot @ echo 398 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "setvart.boot"))' | ${DEPSYS} ../algebra/warm.data: $(srcdir)/Makefile.pamphlet @ echo 2 building warm.data diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 2bd94433..d540e5b1 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -268,11 +268,11 @@ We do, however, care about the macros as these will be expanded in later compiles. All macros are assumed to be in this list of files. <>= -DEP= $(srcdir)/spaderror.lisp debug.lisp \ - $(srcdir)/spad.lisp \ - $(srcdir)/setq.lisp property.lisp \ +DEP= spaderror.lisp debug.lisp \ + spad.lisp \ + setq.lisp property.lisp \ unlisp.lisp foam_l.lisp \ - $(srcdir)/axext_l.lisp + axext_l.lisp depsys_lisp_macro_sources = vmlisp.lisp ggreater.lisp hash.lisp \ union.lisp nlib.lisp macros.lisp \ @@ -1139,7 +1139,7 @@ $(axiom_build_texdir)/diagrams.tex: $(axiom_src_docdir)/diagrams.tex <>= fortcall.clisp: fortcall.boot @ echo 55 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "fortcall.boot"))' | ${DEPSYS} @ @@ -1164,7 +1164,7 @@ c-util.${LISP}: $(srcdir)/c-util.boot.pamphlet <>= c-util.clisp: c-util.boot @ echo 148 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "c-util.boot"))' | ${DEPSYS} @ @@ -1173,7 +1173,7 @@ c-util.clisp: c-util.boot <>= nag-c02.clisp: nag-c02.boot @ echo 152 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c02.boot"))' | ${DEPSYS} @ @@ -1182,7 +1182,7 @@ nag-c02.clisp: nag-c02.boot <>= nag-c05.clisp: nag-c05.boot @ echo 156 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c05.boot"))' | ${DEPSYS} @ @@ -1191,7 +1191,7 @@ nag-c05.clisp: nag-c05.boot <>= nag-c06.clisp: nag-c06.boot @ echo 160 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-c06.boot"))' | ${DEPSYS} @ @@ -1200,7 +1200,7 @@ nag-c06.clisp: nag-c06.boot <>= nag-d01.clisp: nag-d01.boot @ echo 164 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d01.boot"))' | ${DEPSYS} @ @@ -1209,7 +1209,7 @@ nag-d01.clisp: nag-d01.boot <>= nag-d02.clisp: nag-d02.boot @ echo 168 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d02.boot"))' | ${DEPSYS} @ @@ -1218,7 +1218,7 @@ nag-d02.clisp: nag-d02.boot <>= nag-d03.clisp: nag-d03.boot @ echo 172 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-d03.boot"))' | ${DEPSYS} @ @@ -1227,7 +1227,7 @@ nag-d03.clisp: nag-d03.boot <>= nag-e01.clisp: nag-e01.boot @ echo 176 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e01.boot"))' | ${DEPSYS} @ @@ -1236,7 +1236,7 @@ nag-e01.clisp: nag-e01.boot <>= nag-e02.clisp: nag-e02.boot @ echo 184 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e02.boot"))' | ${DEPSYS} @ @@ -1245,7 +1245,7 @@ nag-e02.clisp: nag-e02.boot <>= nag-e04.clisp: nag-e04.boot @ echo 188 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-e04.boot"))' | ${DEPSYS} @ @@ -1254,7 +1254,7 @@ nag-e04.clisp: nag-e04.boot <>= nag-f01.clisp: nag-f01.boot @ echo 192 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f01.boot"))' | ${DEPSYS} @ @@ -1263,7 +1263,7 @@ nag-f01.clisp: nag-f01.boot <>= nag-f02.clisp: nag-f02.boot @ echo 196 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f02.boot"))' | ${DEPSYS} @ @@ -1272,7 +1272,7 @@ nag-f02.clisp: nag-f02.boot <>= nag-f04.clisp: nag-f04.boot @ echo 200 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f04.boot"))' | ${DEPSYS} @ @@ -1281,7 +1281,7 @@ nag-f04.clisp: nag-f04.boot <>= nag-f07.clisp: nag-f07.boot @ echo 204 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-f07.boot"))' | ${DEPSYS} @ @@ -1290,7 +1290,7 @@ nag-f07.clisp: nag-f07.boot <>= nag-s.clisp: nag-s.boot @ echo 208 making $@ from $< - @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (boot::reroot "${AXIOM}") (old-boot::boot "nag-s.boot"))' | ${DEPSYS} @ @@ -1299,7 +1299,7 @@ nag-s.clisp: nag-s.boot <>= category.clisp: category.boot @ echo 212 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "category.boot"))' | ${DEPSYS} @ \subsection{cattable.boot \cite{59}} @@ -1307,7 +1307,7 @@ category.clisp: category.boot <>= cattable.clisp: cattable.boot @ echo 215 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "cattable.boot"))' | ${DEPSYS} @ \subsection{c-doc.boot \cite{60}} @@ -1315,7 +1315,7 @@ cattable.clisp: cattable.boot <>= c-doc.clisp: c-doc.boot @ echo 219 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "c-doc.boot"))' | ${DEPSYS} @ @@ -1324,7 +1324,7 @@ c-doc.clisp: c-doc.boot <>= clammed.clisp: clammed.boot @ echo 226 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "clammed.boot"))' | ${DEPSYS} @ \subsection{compat.boot \cite{63}} @@ -1332,7 +1332,7 @@ clammed.clisp: clammed.boot <>= compat.clisp: compat.boot @ echo 229 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "compat.boot"))' | ${DEPSYS} @ \subsection{compiler.boot \cite{64}} @@ -1340,7 +1340,7 @@ compat.clisp: compat.boot <>= compiler.clisp: compiler.boot @ echo 233 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "compiler.boot"))' | ${DEPSYS} @ \subsection{profile.boot \cite{65}} @@ -1348,7 +1348,7 @@ compiler.clisp: compiler.boot <>= profile.clisp: profile.boot @ echo 237 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "profile.boot"))' | ${DEPSYS} @ \subsection{database.boot \cite{67}} @@ -1356,7 +1356,7 @@ profile.clisp: profile.boot <>= database.clisp: database.boot @ echo 243 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "database.boot"))' | ${DEPSYS} @ \subsection{define.boot} @@ -1364,7 +1364,7 @@ database.clisp: database.boot <>= define.clisp: define.boot @ echo 247 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "define.boot"))' | ${DEPSYS} @ \subsection{format.boot} @@ -1372,7 +1372,7 @@ define.clisp: define.boot <>= format.clisp: format.boot @ echo 250 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "format.boot"))' | ${DEPSYS} @ \subsection{functor.boot} @@ -1380,7 +1380,7 @@ format.clisp: format.boot <>= functor.clisp: functor.boot @ echo 254 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "functor.boot"))' | ${DEPSYS} @ \subsection{g-cndata.boot} @@ -1388,7 +1388,7 @@ functor.clisp: functor.boot <>= g-cndata.clisp: g-cndata.boot @ echo 261 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-cndata.boot"))' | ${DEPSYS} @ \subsection{g-opt.boot} @@ -1396,7 +1396,7 @@ g-cndata.clisp: g-cndata.boot <>= g-opt.clisp: g-opt.boot @ echo 267 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-opt.boot"))' | ${DEPSYS} @ \subsection{g-timer.boot} @@ -1404,7 +1404,7 @@ g-opt.clisp: g-opt.boot <>= g-timer.clisp: g-timer.boot @ echo 270 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "g-timer.boot"))' | ${DEPSYS} @ @@ -1413,7 +1413,7 @@ g-timer.clisp: g-timer.boot <>= hypertex.clisp: hypertex.boot @ echo 277 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "hypertex.boot"))' | ${DEPSYS} @ \subsection{i-analy.boot} @@ -1421,7 +1421,7 @@ hypertex.clisp: hypertex.boot <>= i-analy.clisp: i-analy.boot @ echo 280 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-analy.boot"))' | ${DEPSYS} @ \subsection{i-code.boot} @@ -1429,7 +1429,7 @@ i-analy.clisp: i-analy.boot <>= i-code.clisp: i-code.boot @ echo 283 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-code.boot"))' | ${DEPSYS} @ \subsection{i-coerce.boot} @@ -1437,7 +1437,7 @@ i-code.clisp: i-code.boot <>= i-coerce.clisp: i-coerce.boot @ echo 286 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-coerce.boot"))' | ${DEPSYS} @ \subsection{i-coerfn.boot} @@ -1445,7 +1445,7 @@ i-coerce.clisp: i-coerce.boot <>= i-coerfn.clisp: i-coerfn.boot @ echo 289 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-coerfn.boot"))' | ${DEPSYS} @ \subsection{i-eval.boot} @@ -1453,7 +1453,7 @@ i-coerfn.clisp: i-coerfn.boot <>= i-eval.clisp: i-eval.boot @ echo 292 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-eval.boot"))' | ${DEPSYS} @ \subsection{i-funsel.boot} @@ -1461,7 +1461,7 @@ i-eval.clisp: i-eval.boot <>= i-funsel.clisp: i-funsel.boot @ echo 295 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-funsel.boot"))' | ${DEPSYS} @ \subsection{bookvol5.lsp} @@ -1478,7 +1478,7 @@ bookvol5.lisp: $(srcdir)/bookvol5.pamphlet <>= i-intern.clisp: i-intern.boot @ echo 301 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-intern.boot"))' | ${DEPSYS} @ \subsection{i-map.boot} @@ -1486,7 +1486,7 @@ i-intern.clisp: i-intern.boot <>= i-map.clisp: i-map.boot @ echo 304 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-map.boot"))' | ${DEPSYS} @ \subsection{i-resolv.boot} @@ -1494,7 +1494,7 @@ i-map.clisp: i-map.boot <>= i-resolv.clisp: i-resolv.boot @ echo 310 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-resolv.boot"))' | ${DEPSYS} @ \subsection{i-spec1.boot} @@ -1502,7 +1502,7 @@ i-resolv.clisp: i-resolv.boot <>= i-spec1.clisp: i-spec1.boot @ echo 313 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-spec1.boot"))' | ${DEPSYS} @ \subsection{i-spec2.boot} @@ -1510,7 +1510,7 @@ i-spec1.clisp: i-spec1.boot <>= i-spec2.clisp: i-spec2.boot @ echo 316 making $@ from i-spec2.boot - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-spec2.boot"))' | ${DEPSYS} @ \subsection{i-syscmd.boot} @@ -1518,7 +1518,7 @@ i-spec2.clisp: i-spec2.boot <>= i-syscmd.clisp: i-syscmd.boot @ echo 319 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-syscmd.boot"))' | ${DEPSYS} @ \subsection{i-toplev.boot} @@ -1526,7 +1526,7 @@ i-syscmd.clisp: i-syscmd.boot <>= i-toplev.clisp: i-toplev.boot @ echo 322 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-toplev.boot"))' | ${DEPSYS} @ \subsection{i-util.boot} @@ -1534,7 +1534,7 @@ i-toplev.clisp: i-toplev.boot <>= i-util.clisp: i-util.boot @ echo 325 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "i-util.boot"))' | ${DEPSYS} @ \subsection{info.boot} @@ -1542,7 +1542,7 @@ i-util.clisp: i-util.boot <>= info.clisp: info.boot @ echo 329 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "info.boot"))' | ${DEPSYS} @ \subsection{iterator.boot} @@ -1550,7 +1550,7 @@ info.clisp: info.boot <>= iterator.clisp: iterator.boot @ echo 333 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "iterator.boot"))' | ${DEPSYS} @ \subsection{lisplib.boot} @@ -1558,7 +1558,7 @@ iterator.clisp: iterator.boot <>= lisplib.clisp: lisplib.boot @ echo 336 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "lisplib.boot"))' | ${DEPSYS} @ \subsection{match.boot} @@ -1566,7 +1566,7 @@ lisplib.clisp: lisplib.boot <>= match.clisp: match.boot @ echo 339 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "match.boot"))' | ${DEPSYS} @ \subsection{modemap.boot} @@ -1574,7 +1574,7 @@ match.clisp: match.boot <>= modemap.clisp: modemap.boot @ echo 343 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "modemap.boot"))' | ${DEPSYS} @ \subsection{msgdb.boot} @@ -1582,7 +1582,7 @@ modemap.clisp: modemap.boot <>= msgdb.clisp: msgdb.boot @ echo 346 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "msgdb.boot"))' | ${DEPSYS} @ \subsection{newfort.boot} @@ -1590,7 +1590,7 @@ msgdb.clisp: msgdb.boot <>= newfort.clisp: newfort.boot @ echo 349 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "newfort.boot"))' | ${DEPSYS} @ \subsection{nruncomp.boot} @@ -1598,7 +1598,7 @@ newfort.clisp: newfort.boot <>= nruncomp.clisp: nruncomp.boot @ echo 353 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nruncomp.boot"))' | ${DEPSYS} @ \subsection{nrunfast.boot} @@ -1606,7 +1606,7 @@ nruncomp.clisp: nruncomp.boot <>= nrunfast.clisp: nrunfast.boot @ echo 356 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrunfast.boot"))' | ${DEPSYS} @ \subsection{nrungo.boot} @@ -1614,7 +1614,7 @@ nrunfast.clisp: nrunfast.boot <>= nrungo.clisp: nrungo.boot @ echo 359 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrungo.boot"))' | ${DEPSYS} @ \subsection{nruntime.boot} @@ -1622,7 +1622,7 @@ nrungo.clisp: nrungo.boot <>= nruntime.clisp: nruntime.boot @ echo 362 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nruntime.boot"))' | ${DEPSYS} @ \subsection{nrunopt.boot} @@ -1630,7 +1630,7 @@ nruntime.clisp: nruntime.boot <>= nrunopt.clisp: nrunopt.boot @ echo 365 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "nrunopt.boot"))' | ${DEPSYS} @ @@ -1649,7 +1649,7 @@ to a new platform. <>= pathname.clisp: pathname.boot @ echo 380 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "pathname.boot"))' | ${DEPSYS} @ \subsection{postpar.boot} @@ -1667,7 +1667,7 @@ to a new platform. <>= rulesets.clisp: rulesets.boot @ echo 388 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "rulesets.boot"))' | ${DEPSYS} @ \subsection{server.boot} @@ -1675,7 +1675,7 @@ rulesets.clisp: rulesets.boot <>= server.clisp: server.boot @ echo 391 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "server.boot"))' | ${DEPSYS} @ @@ -1684,7 +1684,7 @@ server.clisp: server.boot <>= setvart.clisp: setvart.boot @ echo 398 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "setvart.boot"))' | ${DEPSYS} @ \subsection{as.boot} @@ -1692,7 +1692,7 @@ setvart.clisp: setvart.boot <>= as.clisp: as.boot @ echo 417 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "as.boot"))' | ${DEPSYS} @ \subsection{bc-matrix.boot} @@ -1700,7 +1700,7 @@ as.clisp: as.boot <>= bc-matrix.clisp: bc-matrix.boot @ echo 424 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-matrix.boot"))' | ${DEPSYS} @ \subsection{bc-misc.boot} @@ -1708,7 +1708,7 @@ bc-matrix.clisp: bc-matrix.boot <>= bc-misc.clisp: bc-misc.boot @ echo 428 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-misc.boot"))' | ${DEPSYS} @ \subsection{bc-solve.boot} @@ -1716,7 +1716,7 @@ bc-misc.clisp: bc-misc.boot <>= bc-solve.clisp: bc-solve.boot @ echo 432 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-solve.boot"))' | ${DEPSYS} @ \subsection{bc-util.boot} @@ -1724,7 +1724,7 @@ bc-solve.clisp: bc-solve.boot <>= bc-util.clisp: bc-util.boot @ echo 436 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "bc-util.boot"))' | ${DEPSYS} @ \subsection{ht-util.boot} @@ -1732,7 +1732,7 @@ bc-util.clisp: bc-util.boot <>= ht-util.clisp: ht-util.boot @ echo 440 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ht-util.boot"))' | ${DEPSYS} @ \subsection{htsetvar.boot} @@ -1740,7 +1740,7 @@ ht-util.clisp: ht-util.boot <>= htsetvar.clisp: htsetvar.boot @ echo 444 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "htsetvar.boot"))' | ${DEPSYS} @ \subsection{record.boot} @@ -1748,7 +1748,7 @@ htsetvar.clisp: htsetvar.boot <>= record.clisp: record.boot @ echo 447 making $@ $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "record.boot"))' | ${DEPSYS} @ \subsection{ht-root.boot} @@ -1756,7 +1756,7 @@ record.clisp: record.boot <>= ht-root.clisp: ht-root.boot @ echo 451 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ht-root.boot"))' | ${DEPSYS} @ \subsection{htcheck.boot} @@ -1764,7 +1764,7 @@ ht-root.clisp: ht-root.boot <>= htcheck.clisp: htcheck.boot @ echo 455 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "htcheck.boot"))' | ${DEPSYS} @ \subsection{ax.boot} @@ -1772,7 +1772,7 @@ htcheck.clisp: htcheck.boot <>= ax.clisp: ax.boot @ echo 463 making $@ $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "ax.boot"))' | ${DEPSYS} @ \subsection{br-con.boot} @@ -1780,7 +1780,7 @@ ax.clisp: ax.boot <>= br-con.clisp: br-con.boot @ echo 467 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-con.boot"))' | ${DEPSYS} @ \subsection{br-search.boot} @@ -1788,7 +1788,7 @@ br-con.clisp: br-con.boot <>= br-search.clisp: br-search.boot @ echo 471 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-search.boot"))' | ${DEPSYS} @ \subsection{br-op1.boot} @@ -1796,7 +1796,7 @@ br-search.clisp: br-search.boot <>= br-op1.clisp: br-op1.boot @ echo 475 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-op1.boot"))' | ${DEPSYS} @ \subsection{br-op2.boot} @@ -1804,7 +1804,7 @@ br-op1.clisp: br-op1.boot <>= br-op2.clisp: br-op2.boot @ echo 479 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-op2.boot"))' | ${DEPSYS} @ \subsection{br-data.boot} @@ -1812,7 +1812,7 @@ br-op2.clisp: br-op2.boot <>= br-data.clisp: br-data.boot @ echo 483 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-data.boot"))' | ${DEPSYS} @ \subsection{br-util.boot} @@ -1820,7 +1820,7 @@ br-data.clisp: br-data.boot <>= br-util.clisp: br-util.boot @ echo 487 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-util.boot"))' | ${DEPSYS} @ \subsection{br-saturn.boot} @@ -1828,7 +1828,7 @@ br-util.clisp: br-util.boot <>= br-saturn.clisp: br-saturn.boot @ echo 491 making $@ from $< - @ echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS} + @ echo '(progn (old-boot::boot "br-saturn.boot"))' | ${DEPSYS} @ \subsection{br-prof.boot} @@ -1837,7 +1837,7 @@ br-saturn.clisp: br-saturn.boot br-prof.clisp: br-prof.boot @ echo 499 making $@ from $< @ ($(axiom_build_document) --tangle --output=br-prof.boot $< ;\ - echo '(progn (old-boot::boot "$<" "$@"))' | ${DEPSYS}; \ + echo '(progn (old-boot::boot "br-prof.boot"))' | ${DEPSYS}; \ rm br-prof.boot ) @ diff --git a/src/interp/axext_l.lisp b/src/interp/axext_l.lisp deleted file mode 100644 index 7663eff6..00000000 --- a/src/interp/axext_l.lisp +++ /dev/null @@ -1,201 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -;; File containing primitives needed by exextend in order to interop with axiom -;; This file could do with some declares - -(in-package "FOAM-USER") - -;; tacky but means we can run programs - -(defun H-integer (l e) - (|AXL-LiteralToInteger| l)) - -(defun H-string (l e) - (|AXL-LiteralToString| l)) - -(defun H-error (l e) - (|AXL-error| l)) - -(eval-when (load eval) - (defconstant |G-axclique_string_305639517| (cons #'H-String nil)) - (defconstant |G-axclique_integer_685864888| (cons #'H-integer nil)) - (defconstant |G-axclique_error_011667951| (cons #'H-error nil))) - -;; Literals should be null-terminated strings - -;; SingleInteger - -(defmacro |AXL-LiteralToSingleInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToInteger| (l) - `(parse-integer ,l :junk-allowed t)) - -(defmacro |AXL-LiteralToDoubleFloat| (l) - `(read-from-string ,l nil (|DFlo0|) - :preserve-whitespace t)) - -(defmacro |AXL-LiteralToString| (l) - `(subseq ,l 0 (- (length ,l) 1))) - -(defmacro |AXL-SingleIntegerToInteger| (si) - `(coerce (the |SInt| ,si) |BInt|)) - -(defmacro |AXL-StringToFloat| (s) - `(boot::|string2Float| ,s)) - -(defmacro |AXL-IntegerIsNonNegative| (i) - `(not (< ,i 0))) - -(defmacro |AXL-IntegerIsPositive| (i) - `(< 0 (the |BInt| ,i))) - -(defmacro |AXL-plusInteger| (a b) - `(the |BInt| (+ (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-minusInteger| (a b) - `(the |BInt| (- (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-timesInteger| (a b) - `(the |BInt| (* (the |BInt| ,a) - (the |BInt| ,b)))) - -(defmacro |AXL-eqInteger| (a b) - `(= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-ltInteger| (a b) - `(< (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-leInteger| (a b) - `(<= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-gtInteger| (a b) - `(> (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-geInteger| (a b) - `(>= (the |BInt| ,a) - (the |BInt| ,b))) - -(defmacro |AXL-plusSingleInteger| (a b) - `(the |SInt| (+ (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-minusSingleInteger| (a b) - `(the |SInt| (- (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-timesSingleInteger| (a b) - `(the |SInt| (* (the |SInt| ,a) - (the |SInt| ,b)))) - -(defmacro |AXL-eqSingleInteger| (a b) - `(= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-ltSingleInteger| (a b) - `(< (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-leSingleInteger| (a b) - `(<= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-gtSingleInteger| (a b) - `(> (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-geSingleInteger| (a b) - `(>= (the |SInt| ,a) - (the |SInt| ,b))) - -(defmacro |AXL-incSingleInteger| (i) - `(the |SInt| (+ (the |SInt| ,i) 1))) - -(defmacro |AXL-decSingleInteger| (i) - `(- (the |SInt| ,i) - (the |SInt| 1))) - -(defmacro |AXL-onefnSingleInteger| () '(the |SInt| 1)) -(defmacro |AXL-zerofnSingleInteger| () '(the |SInt| 0)) - -(defmacro |AXL-cons| (x y) - `(cons ,x ,y)) - -(defmacro |AXL-nilfn| () nil) - -(defmacro |AXL-car| (x) `(car ,x)) - -(defmacro |AXL-cdr| (x) `(cdr ,x)) - -(defmacro |AXL-null?| (x) `(null ,x)) - -(defmacro |AXL-rplaca| (x y) `(rplaca ,x ,y)) - -(defmacro |AXL-rplacd| (x y) `(rplacd ,x ,y)) - -(defmacro |AXL-error| (msg) `(error ,msg)) - -;; arrays -;; 0 based! -(defmacro |AXL-arrayRef| (arr i) - `(|AElt| ,arr ,i)) - -(defmacro |AXL-arraySet| (arr i v) - `(setf (|AElt| ,arr ,i) ,v)) - -(defmacro |AXL-arrayToList| (x) - `(coerce ,x 'list)) - -(defmacro |AXL-arraySize| (x) - `(length ,x)) - -(defmacro |AXL-arrayNew| (n) - `(make-array ,n)) - -(defmacro |AXL-arrayCopy| (x) - `(copy-seq ,x)) - -;; Vectors - - -;; Testing - -(defun |AXL-spitSInt| (x) - (print x)) - diff --git a/src/interp/axext_l.lisp.pamphlet b/src/interp/axext_l.lisp.pamphlet new file mode 100644 index 00000000..3d03127c --- /dev/null +++ b/src/interp/axext_l.lisp.pamphlet @@ -0,0 +1,230 @@ +%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/axext\_l.lisp} Pamphlet} +\author{Timothy Daly} + +\begin{document} +\maketitle + +\begin{abstract} +\end{abstract} + + +\tableofcontents +\eject + +\section{License} + +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +;; File containing primitives needed by exextend in order to interop with axiom +;; This file could do with some declares + +(in-package "FOAM-USER") + +;; tacky but means we can run programs + +(defun H-integer (l e) + (|AXL-LiteralToInteger| l)) + +(defun H-string (l e) + (|AXL-LiteralToString| l)) + +(defun H-error (l e) + (|AXL-error| l)) + +(eval-when (load eval) + (defconstant |G-axclique_string_305639517| (cons #'H-String nil)) + (defconstant |G-axclique_integer_685864888| (cons #'H-integer nil)) + (defconstant |G-axclique_error_011667951| (cons #'H-error nil))) + +;; Literals should be null-terminated strings + +;; SingleInteger + +(defmacro |AXL-LiteralToSingleInteger| (l) + `(parse-integer ,l :junk-allowed t)) + +(defmacro |AXL-LiteralToInteger| (l) + `(parse-integer ,l :junk-allowed t)) + +(defmacro |AXL-LiteralToDoubleFloat| (l) + `(read-from-string ,l nil (|DFlo0|) + :preserve-whitespace t)) + +(defmacro |AXL-LiteralToString| (l) + `(subseq ,l 0 (- (length ,l) 1))) + +(defmacro |AXL-SingleIntegerToInteger| (si) + `(coerce (the |SInt| ,si) |BInt|)) + +(defmacro |AXL-StringToFloat| (s) + `(boot::|string2Float| ,s)) + +(defmacro |AXL-IntegerIsNonNegative| (i) + `(not (< ,i 0))) + +(defmacro |AXL-IntegerIsPositive| (i) + `(< 0 (the |BInt| ,i))) + +(defmacro |AXL-plusInteger| (a b) + `(the |BInt| (+ (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-minusInteger| (a b) + `(the |BInt| (- (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-timesInteger| (a b) + `(the |BInt| (* (the |BInt| ,a) + (the |BInt| ,b)))) + +(defmacro |AXL-eqInteger| (a b) + `(= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-ltInteger| (a b) + `(< (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-leInteger| (a b) + `(<= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-gtInteger| (a b) + `(> (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-geInteger| (a b) + `(>= (the |BInt| ,a) + (the |BInt| ,b))) + +(defmacro |AXL-plusSingleInteger| (a b) + `(the |SInt| (+ (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-minusSingleInteger| (a b) + `(the |SInt| (- (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-timesSingleInteger| (a b) + `(the |SInt| (* (the |SInt| ,a) + (the |SInt| ,b)))) + +(defmacro |AXL-eqSingleInteger| (a b) + `(= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-ltSingleInteger| (a b) + `(< (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-leSingleInteger| (a b) + `(<= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-gtSingleInteger| (a b) + `(> (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-geSingleInteger| (a b) + `(>= (the |SInt| ,a) + (the |SInt| ,b))) + +(defmacro |AXL-incSingleInteger| (i) + `(the |SInt| (+ (the |SInt| ,i) 1))) + +(defmacro |AXL-decSingleInteger| (i) + `(- (the |SInt| ,i) + (the |SInt| 1))) + +(defmacro |AXL-onefnSingleInteger| () '(the |SInt| 1)) +(defmacro |AXL-zerofnSingleInteger| () '(the |SInt| 0)) + +(defmacro |AXL-cons| (x y) + `(cons ,x ,y)) + +(defmacro |AXL-nilfn| () nil) + +(defmacro |AXL-car| (x) `(car ,x)) + +(defmacro |AXL-cdr| (x) `(cdr ,x)) + +(defmacro |AXL-null?| (x) `(null ,x)) + +(defmacro |AXL-rplaca| (x y) `(rplaca ,x ,y)) + +(defmacro |AXL-rplacd| (x y) `(rplacd ,x ,y)) + +(defmacro |AXL-error| (msg) `(error ,msg)) + +;; arrays +;; 0 based! +(defmacro |AXL-arrayRef| (arr i) + `(|AElt| ,arr ,i)) + +(defmacro |AXL-arraySet| (arr i v) + `(setf (|AElt| ,arr ,i) ,v)) + +(defmacro |AXL-arrayToList| (x) + `(coerce ,x 'list)) + +(defmacro |AXL-arraySize| (x) + `(length ,x)) + +(defmacro |AXL-arrayNew| (n) + `(make-array ,n)) + +(defmacro |AXL-arrayCopy| (x) + `(copy-seq ,x)) + +;; Vectors + + +;; Testing + +(defun |AXL-spitSInt| (x) + (print x)) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/bc-matrix.boot b/src/interp/bc-matrix.boot deleted file mode 100644 index bdfcbb9f..00000000 --- a/src/interp/bc-matrix.boot +++ /dev/null @@ -1,153 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- Basic Command matrix entry - -bcMatrix() == bcReadMatrix nil - -bcReadMatrix exitFunctionOrNil == - page := htInitPage('"Matrix Basic Command", nil) - htpSetProperty(page,'exitFunction,exitFunctionOrNil) - htMakePage - '((domainConditions - (isDomain PI (PositiveInteger))) - (text . "Enter the size of the matrix:") - (inputStrings - ("Number of {\em rows}:\space{3}" "" 5 2 rows PI) - ("Number of {\em columns}: " "" 5 2 cols PI)) - (text . "\blankline ") - (text . "How would you like to enter the matrix?") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{By entering individual entries}" "" bcInputExplicitMatrix explicit)) - (text . "\item ") - (bcLinks ("\menuitemstyle{By formula}" "" bcInputMatrixByFormula formula)) - (text . "\endmenu")) - htShowPage() - -bcInputMatrixByFormula(htPage,junk) == - page := htInitPage('"Basic Matrix Command", htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain S (Symbol)) - (isDomain FE (Expression (Integer)))) - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em row variable}: ") - (text . "\tab{36}") - (bcStrings (6 i rowVar S)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em column variable}: ") - (text . "\tab{36}") - (bcStrings (6 j colVar S)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the general {\em formula} for the entries:") - (text . "\newline\tab{2} ") - (bcStrings (40 "1/(x - i - j - 1)" formula FE))) - htMakeDoneButton('"Continue", 'bcInputMatrixByFormulaGen) - nrows := - null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'rows) - PARSE_-INTEGER htpLabelInputString(htPage,'rows) - ncols := - null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'cols) - PARSE_-INTEGER htpLabelInputString(htPage,'cols) - htpSetProperty(page, 'nrows, nrows) - htpSetProperty(page, 'ncols, ncols) - htShowPage() - -bcInputMatrixByFormulaGen htPage == - fun := htpProperty(htPage,'exitFunction) => FUNCALL(fun, htPage) - formula := htpLabelInputString(htPage,'formula) - rowVar := htpLabelInputString(htPage,'rowVar) - colVar := htpLabelInputString(htPage,'colVar) - nrows := htpProperty(htPage,'nrows) - ncols := htpProperty(htPage,'ncols) - bcGen STRCONC('"matrix([[",formula,'" for ",colVar,'" in 1..", - STRINGIMAGE ncols,'"] for ",rowVar,'" in 1..",STRINGIMAGE nrows,'"])") - -bcInputExplicitMatrix(htPage,junk) == - nrows := - null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'rows) - PARSE_-INTEGER htpLabelInputString(htPage,'rows) - ncols := - null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'cols) - PARSE_-INTEGER htpLabelInputString(htPage,'cols) - cond := nil - k := 0 - wrows := # STRINGIMAGE nrows - wcols := # STRINGIMAGE ncols - labelList := - "append"/[[f for j in 1..ncols] for i in 1..nrows] where f == - rowpart := STRCONC('"{\em Row",htStringPad(i,wrows)) - colpart := STRCONC('", Column",htStringPad(j,wcols),'":}\space{2}") - prefix := STRCONC(rowpart,colpart) - -- name := INTERN STRCONC(htMkName('"row",i),htMkName('"col",j)) - name := INTERN STRINGIMAGE (k := k + 1) - [prefix,'"",30, 0,name,'P] - labelList := - [['domainConditions, '(isDomain P (Polynomial $EmptyMode)), cond], - ['inputStrings, :labelList] ] - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - bcHt '"Enter the entries of the matrix:" - htMakePage labelList - htMakeDoneButton('"Continue", 'bcGenExplicitMatrix) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'ncols,ncols) - htShowPage() - -bcGenExplicitMatrix htPage == - htpSetProperty(htPage,'matrix,htpInputAreaAlist htPage) - fun := htpProperty(htPage,'exitFunction) => FUNCALL(fun, htPage) - bcGen bcMatrixGen htPage - -bcMatrixGen htPage == - nrows := htpProperty(htPage,'nrows) - ncols := htpProperty(htPage,'ncols) - mat := htpProperty(htPage,'matrix) - formula := LASSOC('formula,mat) => - formula := formula.0 - rowVar := LASSOC('rowVar,mat).0 - colVar := LASSOC('colVar,mat).0 - STRCONC('"matrix([[",formula,'" for ",colVar,'" in 1..", - STRINGIMAGE ncols,'"] for ",rowVar,'" in 1..",STRINGIMAGE nrows,'"])") - mat := htpProperty(htPage,'matrix) => - mat := REVERSE mat - k := -1 - matform := [[mat.(k := k + 1).1 - for j in 0..(ncols-1)] for i in 0..(nrows-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - STRCONC('"matrix(",matstring,'")") - systemError nil - diff --git a/src/interp/bc-matrix.boot.pamphlet b/src/interp/bc-matrix.boot.pamphlet new file mode 100644 index 00000000..008722a6 --- /dev/null +++ b/src/interp/bc-matrix.boot.pamphlet @@ -0,0 +1,175 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp bc-matrix.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- Basic Command matrix entry + +bcMatrix() == bcReadMatrix nil + +bcReadMatrix exitFunctionOrNil == + page := htInitPage('"Matrix Basic Command", nil) + htpSetProperty(page,'exitFunction,exitFunctionOrNil) + htMakePage + '((domainConditions + (isDomain PI (PositiveInteger))) + (text . "Enter the size of the matrix:") + (inputStrings + ("Number of {\em rows}:\space{3}" "" 5 2 rows PI) + ("Number of {\em columns}: " "" 5 2 cols PI)) + (text . "\blankline ") + (text . "How would you like to enter the matrix?") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{By entering individual entries}" "" bcInputExplicitMatrix explicit)) + (text . "\item ") + (bcLinks ("\menuitemstyle{By formula}" "" bcInputMatrixByFormula formula)) + (text . "\endmenu")) + htShowPage() + +bcInputMatrixByFormula(htPage,junk) == + page := htInitPage('"Basic Matrix Command", htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain S (Symbol)) + (isDomain FE (Expression (Integer)))) + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em row variable}: ") + (text . "\tab{36}") + (bcStrings (6 i rowVar S)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em column variable}: ") + (text . "\tab{36}") + (bcStrings (6 j colVar S)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the general {\em formula} for the entries:") + (text . "\newline\tab{2} ") + (bcStrings (40 "1/(x - i - j - 1)" formula FE))) + htMakeDoneButton('"Continue", 'bcInputMatrixByFormulaGen) + nrows := + null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'rows) + PARSE_-INTEGER htpLabelInputString(htPage,'rows) + ncols := + null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'cols) + PARSE_-INTEGER htpLabelInputString(htPage,'cols) + htpSetProperty(page, 'nrows, nrows) + htpSetProperty(page, 'ncols, ncols) + htShowPage() + +bcInputMatrixByFormulaGen htPage == + fun := htpProperty(htPage,'exitFunction) => FUNCALL(fun, htPage) + formula := htpLabelInputString(htPage,'formula) + rowVar := htpLabelInputString(htPage,'rowVar) + colVar := htpLabelInputString(htPage,'colVar) + nrows := htpProperty(htPage,'nrows) + ncols := htpProperty(htPage,'ncols) + bcGen STRCONC('"matrix([[",formula,'" for ",colVar,'" in 1..", + STRINGIMAGE ncols,'"] for ",rowVar,'" in 1..",STRINGIMAGE nrows,'"])") + +bcInputExplicitMatrix(htPage,junk) == + nrows := + null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'rows) + PARSE_-INTEGER htpLabelInputString(htPage,'rows) + ncols := + null $bcParseOnly => objValUnwrap htpLabelSpadValue(htPage,'cols) + PARSE_-INTEGER htpLabelInputString(htPage,'cols) + cond := nil + k := 0 + wrows := # STRINGIMAGE nrows + wcols := # STRINGIMAGE ncols + labelList := + "append"/[[f for j in 1..ncols] for i in 1..nrows] where f == + rowpart := STRCONC('"{\em Row",htStringPad(i,wrows)) + colpart := STRCONC('", Column",htStringPad(j,wcols),'":}\space{2}") + prefix := STRCONC(rowpart,colpart) + -- name := INTERN STRCONC(htMkName('"row",i),htMkName('"col",j)) + name := INTERN STRINGIMAGE (k := k + 1) + [prefix,'"",30, 0,name,'P] + labelList := + [['domainConditions, '(isDomain P (Polynomial $EmptyMode)), cond], + ['inputStrings, :labelList] ] + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + bcHt '"Enter the entries of the matrix:" + htMakePage labelList + htMakeDoneButton('"Continue", 'bcGenExplicitMatrix) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'ncols,ncols) + htShowPage() + +bcGenExplicitMatrix htPage == + htpSetProperty(htPage,'matrix,htpInputAreaAlist htPage) + fun := htpProperty(htPage,'exitFunction) => FUNCALL(fun, htPage) + bcGen bcMatrixGen htPage + +bcMatrixGen htPage == + nrows := htpProperty(htPage,'nrows) + ncols := htpProperty(htPage,'ncols) + mat := htpProperty(htPage,'matrix) + formula := LASSOC('formula,mat) => + formula := formula.0 + rowVar := LASSOC('rowVar,mat).0 + colVar := LASSOC('colVar,mat).0 + STRCONC('"matrix([[",formula,'" for ",colVar,'" in 1..", + STRINGIMAGE ncols,'"] for ",rowVar,'" in 1..",STRINGIMAGE nrows,'"])") + mat := htpProperty(htPage,'matrix) => + mat := REVERSE mat + k := -1 + matform := [[mat.(k := k + 1).1 + for j in 0..(ncols-1)] for i in 0..(nrows-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + STRCONC('"matrix(",matstring,'")") + systemError nil + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/bc-misc.boot b/src/interp/bc-misc.boot deleted file mode 100644 index 9a39697c..00000000 --- a/src/interp/bc-misc.boot +++ /dev/null @@ -1,924 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---Hypertex commands other than solve and matrix - -bcDrawIt2(ind,a,b) == STRCONC('"{}",ind,'"=",a,'"{}..",b,'"{}") - -bcIndefiniteIntegrate() == - htInitPage("Indefinite Integration Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to integrate:") - (text . "\newline\tab{2} ") - (bcStrings (45 "1/(x**2 + 6)" integrand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em variable of integration}:") - (text . "\tab{37}") - (bcStrings (10 x symbol SY)) - (doneButton "Continue" bcIndefiniteIntegrateGen)) - htShowPage() - -bcIndefiniteIntegrateGen htPage == - integrand := htpLabelInputString(htPage,'integrand) - var := htpLabelInputString(htPage,'symbol) - bcGen STRCONC('"integrate(",integrand,'",",var,")") - - -bcDefiniteIntegrate() == - htInitPage("Definite Integration Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to integrate:") - (text . "\newline\tab{2} ") - (bcStrings (45 "1/(x**2 + 6)" integrand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em variable of integration}:") - (text . "\tab{37}") - (bcStrings (10 x symbol SY)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Enter {\em lower limit}:") - (radioButtons fromButton - ("" "Minus infinity" minusInfinity) - ("" ( - (text . "A finite point:\tab{15}") - (bcStrings (10 0 from EM . bcOptional))) fromPoint)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\indent{2}\newline Enter {\em upper limit}:") - (radioButtons toButton - ("" "Plus infinity" plusInfinity) - ("" ( - (text "A finite point:\tab{15}") - (bcStrings (10 y to EM . bcOptional))) toPoint)) - (doneButton "Continue" bcDefiniteIntegrateGen)) - htShowPage() - -bcDefiniteIntegrateGen htPage == - integrand := htpLabelInputString(htPage,'integrand) - var := htpLabelInputString(htPage,'symbol) - lowerLimit := - htpButtonValue(htPage,'fromButton) = 'fromPoint => - htpLabelInputString(htPage,'from) - '"%minusInfinity" - upperLimit := - htpButtonValue(htPage,'toButton) = 'toPoint => - htpLabelInputString(htPage,'to) - '"%plusInfinity" - varpart := STRCONC(var,'" = ",lowerLimit,'"..",upperLimit) - bcGen - STRCONC('"integrate(",integrand,'",",varpart,'")") - -bcSum() == - htInitPage("Sum Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you would like to sum:") - (text . "\newline\tab{2} ") - (bcStrings (44 "i**3" summand EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em summation index}:") - (text . "\tab{36}") - (bcStrings (10 i index SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the limits of the sum:") - (text . "\newline\tab{10}{\em From:}") - (bcStrings (10 1 first S)) - (text . "\tab{32}{\em To:}") - (text . "\tab{36}") - (bcStrings (10 n last S)) - (doneButton "Continue" bcSumGen)) - htShowPage() - -bcSumGen htPage == - mand := htpLabelInputString(htPage,'summand) - index := htpLabelInputString(htPage,'index) - first := htpLabelInputString(htPage,'first) - last := htpLabelInputString(htPage,'last) - bcGen STRCONC('"sum(",mand,'",",index,'" = ",first,'"..",last,'")") - -bcProduct() == - htInitPage("Product Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "Enter the {\em function} you would like to compute the product of:") - (inputStrings ("" "" 45 "i**2" mand EM)) - (text . "\vspace{1}\newline") - (inputStrings ("Enter the {\em index of the product}:" "" 5 i index SY)) - (text . "\vspace{1}\newline Enter the limits of the index:") - (inputStrings - ("\newline{\em From:}" "" 10 "1" first EM) - ("{\em To:}\space{2}" "" 10 "n" last EM)) - (doneButton "Continue" bcProductGen)) - htShowPage() - -bcProductGen htPage == - mand := htpLabelInputString(htPage,'mand) - index := htpLabelInputString(htPage,'index) - first := htpLabelInputString(htPage,'first) - last := htpLabelInputString(htPage,'last) - bcGen STRCONC('"product(",mand,'",",index,'",",first,'",",last,'")") - -bcDifferentiate() == - htInitPage("Differentiate Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to differentiate:") - (text . "\newline\tab{2} ") - (bcStrings (55 "sin(x*y)" diffand EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline List the {\em variables} you want to differentiate with respect to?") - (text . "\newline\tab{2} ") - (bcStrings (55 "x y" variables S . quoteString)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline List the number of {\em times} you want to differentiate with respect to each variable (leave blank if once for each)") - (text . "\newline\tab{2} ") - (bcStrings (55 "1 2" times S . quoteString))) - htMakeDoneButton('"Continue", 'bcDifferentiateGen) - htShowPage() - -bcDifferentiateGen htPage == - mand := htpLabelInputString(htPage,'diffand) - varlist := bcString2WordList htpLabelInputString(htPage,'variables) - indexList := bcString2WordList htpLabelInputString(htPage,'times) - varpart := - #varlist > 1 => bcwords2liststring varlist - first varlist - indexpart := - null indexList => nil - null rest indexList => first indexList - #indexList = #varlist => bcwords2liststring indexList - bcError '"You must say how many times you want to differentiate with respect to each variable---or leave that entry blank" - lastPart := - indexpart => STRCONC('",",indexpart,'")") - '")" - bcGen STRCONC('"differentiate(",mand,'",",varpart,lastPart) - -bcDraw() == - htInitPage('"Draw Basic Command",nil) - bcHt '"What would you like to draw?" - bcHt '"\newline\centerline{{\em Two Dimensional Plots}}\newline" - bcHt '"\lispdownlink{A function of one variable}{(|bcDraw2Dfun|)}" - bcHt '"\space{2}y = f(x)\newline" - bcHt '"\lispdownlink{A parametrically defined curve}{(|bcDraw2Dpar|)}" - bcHt '"\space{2}(x(t), y(t))\newline" - bcHt '"\lispdownlink{A solution to a polynomial equation}{(|bcDraw2DSolve|)}" - bcHt '"\space{2} p(x,y) = 0\newline" - bcHt '"\vspace{1}\newline " - bcHt '"\centerline{{\em Three Dimensional Surfaces}}\newline\newline" - bcHt '"\lispdownlink{A function of two variables}{(|bcDraw3Dfun|)}" - bcHt '"\space{2} z = f(x,y)\newline" - bcHt '"\lispdownlink{A parametrically defined tube}{(|bcDraw3Dpar|)}" - bcHt '"\space{2}(x(t), y(t), z(t))\newline" - bcHt '"\lispdownlink{A parameterically defined surface}{(|bcDraw3Dpar1|)}" - bcHt '"\space{2}(x(u,v), y(u,v), z(u,v))\newline" - htShowPage() - - -bcDraw2Dfun() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing {\em y = f(x)}}\newline " - "\centerline{where {\em y} is the dependent variable and}\newline " - "\centerline{where {\em x} is the independent variable}\vspace{1}\newline " - "\menuitemstyle{}\tab{2}What {\em function} f would you like to draw?\newline\tab{2}") - (bcStrings (55 "x*cos(x)" function EM)) - (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") - (bcStrings (6 y dependent SY)) - (text . "\newline\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}Enter {\em independent} variable and {\em range}:\newline\tab{2} ") - (text . "{\em Variable:}") - (bcStrings (6 x ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 0 from1 F)) - (text . "{\em to:}") - (bcStrings (9 30 to1 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your curve:" - ) - (bcStrings (15 "y = x*cos(x)" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw2DfunGen) - (text . "{}")) - htShowPage() - -bcDraw2DfunGen htPage == - fun := htpLabelInputString(htPage,'function) - dep := htpLabelInputString(htPage,'dependent) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - if (title ^= '"") then - titlePart := STRCONC('"{}",'"title ==_"",title,'"_"") - bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1),titlePart) - else - bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1)) - - -bcDraw2Dpar() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined curve:}\newline " - "\centerline{{\em ( f1(t), f2(t) )}}\newline " - "\centerline{in terms of two functions {\em f1} and {\em f2}}" - "\centerline{and an independent variable {\em t}}\vspace{1}\newline" - "\menuitemstyle{}\tab{2}Enter the two {\em functions:}") - (text . "\newline\tab{2}{\em Function 1:}") - (bcStrings (44 "-9*sin(4*t/5)" function1 EM)) - (text . "\newline\tab{2}{\em Function 2:}") - (bcStrings (44 "8*sin(t)" function2 EM)) - (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") - (text . "{\em Variable:}") - (bcStrings (6 t ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-5*\%pi" from1 F)) - (text . "{\em to:}") - (bcStrings (9 "5*\%pi" to1 F)) - (text - "\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Optionally enter a {\em title} for your curve:") - (bcStrings (15 "Lissajous" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw2DparGen)) - htShowPage() - -bcDraw2DparGen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'")") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),titlePart) - else - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1)) - -bcDraw2DSolve() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Plotting the solution to {\em p(x,y) = 0}, where} " - "\centerline{{\em p} is a polynomial in two variables {\em x} and {\em y}}" - "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em polynomial} p:" - "\newline\tab{2}") - (bcStrings (40 "y**2+7*x*y-(x**3+16*x)" function EM)) - (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em variables}:") - (text . "\newline\tab{2}{\em Variable 1:} ") - (bcStrings (4 x independent1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -15 from1 F)) - (text . "{\em to:}") - (bcStrings (9 10 to1 F)) - (text . "\newline\tab{2}{\em Variable 2:} ") - (bcStrings (4 y independent2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -10 from2 F)) - (text . "{\em to:}") - (bcStrings (9 50 to2 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your curve:") - (bcStrings (15 "" title S)) - (text . "\indent{0}")) - htMakeDoneButton('"Continue",'bcDraw2DSolveGen) - htShowPage() - -bcDraw2DSolveGen htPage == - fun := htpLabelInputString(htPage,'function) - ind1 := htpLabelInputString(htPage,'independent1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'independent2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - clipPart := STRCONC('"{}",'"range==[{}",from1,'"..",to1,",{}",from2,'"..",to2,'"]") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart,titlePart) - else - bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart) - -bcDraw3Dfun() == - htInitPage('"Three Dimensional Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing {\em z = f(x,y)}}\newline " - "\centerline{where {\em z} is the dependent variable and}\newline " - "\centerline{where {\em x, y} are the independent variables}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "What {\em function} f which you like to draw?\newline\tab{2}") - (bcStrings (55 "exp(cos(x-y)-sin(x*y))-2" function EM)) - (text . "\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") - (bcStrings (6 z dependent SY)) - (text - "\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Enter {\em independent} variables and ranges:\newline\tab{2} " - "{\em Variable:}") - (bcStrings (6 x independent1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -5 from1 F)) - (text . "{\em to:}") - (bcStrings (9 5 to1 F)) - (text . "\newline\tab{2}{\em Variable:}") - (bcStrings (6 y independent2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 -5 from2 F)) - (text . "{\em to:}") - (bcStrings (9 5 to2 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw3DfunGen)) - htShowPage() - -bcDraw3DfunGen htPage == - fun := htpLabelInputString(htPage,'function) - dep := htpLabelInputString(htPage,'dependent) - ind1 := htpLabelInputString(htPage,'independent1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'independent2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - if (title ^= '"") then - titlePart := (title = '"" => nil;STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2),titlePart) - else - bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2)) - -bcDraw3Dpar() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined curve:" - "{\em ( f1(t), f2(t), f3(t) )}}\newline " - "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " - "\centerline{and an independent variable {\em t}}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Enter the three {\em functions} of the independent variable:") - (text . "\newline\tab{2}{\em Function f1:}") - (bcStrings (42 "1.3*cos(2*t)*cos(4*t) + sin(4*t)*cos(t)" function1 EM)) - (text . "\newline\tab{2}{\em Function f2:}") - (bcStrings (42 "1.3*sin(2*t)*cos(4*t) - sin(4*t)*sin(t)" function2 EM)) - (text . "\newline\tab{2}{\em Function f3:}") - (bcStrings (42 "2.5*cos(4*t)" function3 EM)) - (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") - (text ."{\em Variable:}") - (bcStrings (6 t ind SY)) - (text . "ranges {\em from:}") - (bcStrings (9 0 from1 F)) - (text "{\em to:}") - (bcStrings (9 "4*\%pi" to1 F)) - (text - "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "knot" title S)) - (text . "\indent{0}") - (doneButton "Continue" bcDraw3DparGen)) - htShowPage() - -bcDraw3DparGen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - fun3 := htpLabelInputString(htPage,'function3) - ind := htpLabelInputString(htPage,'ind) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - title := htpLabelInputString(htPage,'title) - curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") - tubePart := '"{}tubeRadius==.25,{}tubePoints==16" - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart,titlePart) - else - bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart) - -bcDraw3Dpar1() == - htInitPage('"Draw Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text - "\centerline{Drawing a parametrically defined surface:}\newline " - "\centerline{{\em ( f1(u,v), f2(u,v), f3(u,v) )}}\newline " - "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " - "\centerline{and two independent variables {\em u} and {\em v}}\vspace{1}\newline\menuitemstyle{}\tab{2}" - "Enter the three {\em functions} of the independent variables:") - (text . "\newline\tab{2}") - (text . "{\em Function f1:}") - (bcStrings (43 "u*sin(v)" function1 EM)) - (text . "\newline\tab{2}") - (text . "{\em Function f2:}") - (bcStrings (43 "v*cos(u)" function2 EM)) - (text . "\newline\tab{2}") - (text . "{\em Function f3:}") - (bcStrings (43 "u*cos(v)" function3 EM)) - (text . "\newline\menuitemstyle{}\tab{2}Enter independent {\em variables} and ranges:") - (text . "\newline\tab{2}") - (text . "{\em Variable 1:}") - (bcStrings (5 u ind1 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-\%pi" from1 F)) - (text . "{\em to:}") - (bcStrings (9 "\%pi" to1 F)) - (text . "\newline\tab{2}") - (text . "{\em Variable 2:}") - (bcStrings (5 v ind2 SY)) - (text . "ranges {\em from:}") - (bcStrings (9 "-\%pi/2" from2 F)) - (text . "{\em to:}") - (bcStrings (9 "\%pi/2" to2 F)) - (text - "\indent{0}\newline\menuitemstyle{}\tab{2} " - "Optionally enter a {\em title} for your surface:") - (bcStrings (15 "surface" title S)) - (text . "\indent{0}")) - htMakeDoneButton ('"Continue",'bcDraw3Dpar1Gen) - htShowPage() - -bcDraw3Dpar1Gen htPage == - fun1 := htpLabelInputString(htPage,'function1) - fun2 := htpLabelInputString(htPage,'function2) - fun3 := htpLabelInputString(htPage,'function3) - ind1 := htpLabelInputString(htPage,'ind1) - from1 := htpLabelInputString(htPage,'from1) - to1 := htpLabelInputString(htPage,'to1) - ind2 := htpLabelInputString(htPage,'ind2) - from2 := htpLabelInputString(htPage,'from2) - to2 := htpLabelInputString(htPage,'to2) - title := htpLabelInputString(htPage,'title) - r1 := bcDrawIt2(ind1,from1,to1) - r2 := bcDrawIt2(ind2,from2,to2) - surfacePart := STRCONC('"surface(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") - if (title ^= '"") then - titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) - bcFinish('"draw",surfacePart,r1,r2,titlePart) - else - bcFinish('"draw",surfacePart,r1,r2) - -bcSeries() == - htInitPage('"Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "Create a series by: ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Expansion}" "" bcSeriesExpansion NILl)) - (text . "\tab{11}Expand a function in a series around a point") - (text . "\item ") - (bcLinks ("\menuitemstyle{Formula}" "" bcSeriesByFormula NIL)) - (text . "\tab{11}Give a formula for the {\em i}'th coefficient") - (text . "\endmenu")) - htShowPage() - -bcSeriesExpansion(a,b) == - htInitPage('"Series Expansion Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to expand in a power series") - (text . "\newline\tab{2} ") - (bcStrings (55 "log(cot(x))" function EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 "\%pi/2" point EM))) - htMakeDoneButton('"Continue",'bcSeriesExpansionGen) - htShowPage() - -bcSeriesExpansionGen htPage == - fun := htpLabelInputString(htPage,'function) - var := htpLabelInputString(htPage,'variable) - point := htpLabelInputString(htPage,'point) - terms := htpLabelInputString(htPage,'numberOfTerms) - bcFinish("series",fun,STRCONC(var,'" = ",point)) - -bcSeriesByFormula(a,b) == - htInitPage('"Power Series Basic Command",nil) - htMakePage '( - (text . "Select the kind of power series you want to create:") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Taylor Series}" "" bcTaylorSeries taylor)) - (text . "\newline Series where the exponent ranges over the integers from a {\em non-negative integer} value to plus infinity by an arbitrary {\em positive integer} step size") - (text . "\item ") - (bcLinks ("\menuitemstyle{Laurent Series}" "" bcLaurentSeries laurent)) - (text . "\newline Series where the exponent ranges from an arbitrary {\em integer} value to plus infinity by an arbitrary {\em positive integer} step size") - (text . "\item ") - (bcLinks ("\menuitemstyle{Puiseux Series}" "" bcPuiseuxSeries puiseux)) - (text . "\newline Series where the exponent ranges from an arbitrary {\em rational value} to plus infinity by an arbitrary {\em positive rational number} step size") - (text . "\endmenu")) - htShowPage() - -bcTaylorSeries(a,b) == - htInitPage('"Taylor Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the formula for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings (55 "1/factorial(i)" formula EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 i index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point EM)) - (text . "\blankline ") - (text ."For Taylor Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary non-negative integer, to plus infinity; the {\em step size} is any positive integer.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of the index (an integer)") - (text . "\tab{49}") - (bcStrings (8 "0" min I)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive integer)") - (text . "\tab{49}") - (bcStrings (8 "1" step PI)) - (doneButton "Continue" bcTaylorSeriesGen)) - htShowPage() - -bcSeriesByFormulaGen htPage == bcNotReady() - -bcLaurentSeries(a,b) == - htInitPage('"Laurent Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain I (Integer)) - (isDomain PI (PositiveInteger)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the formula for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings (55 "(-1)**(n - 1)/(n + 2)" formula EM)) - (text . "\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 n index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point F)) - (text . "\blankline") - (text . "\newline For Laurent Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary integer value, to plus infinity; the {\em step size} is any positive integer.") - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of the index (an integer)") - (text . "\tab{49}") - (bcStrings (8 "-1" min I)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive integer)") - (text . "\tab{49}") - (bcStrings (8 "1" step PI)) - (doneButton "Continue" bcLaurentSeriesGen)) - htShowPage() - -bcPuiseuxSeries(a,b) == - htInitPage('"Puiseux Series Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain EEM (Expression $EmptyMode)) - (isDomain S (String)) - (isDomain I (Integer)) - (isDomain PI (PositiveInteger)) - (isDOmain RN (Fraction (Integer))) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text ."Enter the {\em formula} for the general coefficient of the series") - (text . "\newline\tab{2} ") - (bcStrings(55 "(-1)**((3*n - 4)/6)/factorial(n - 1/3)" formula EM)) - (text . "\vspace{1}\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em index variable} for your formula") - (text . "\tab{49}") - (bcStrings (8 n index SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em power series variable}") - (text . "\tab{49}") - (bcStrings (8 x variable SY)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em point} about which you want to expand") - (text . "\tab{49}") - (bcStrings (8 0 point F)) - (text . "\blankline ") - (text . "For Puiseux Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitary rational number, to plus infinity; the {\em step size} is an any positive rational number.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em initial value} of index (a rational number)") - (text . "\tab{51}") - (bcStrings (6 "4/3" min RN)) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em step size} (a positive rational number)") - (text . "\tab{51}") - (bcStrings (6 "2" step RN)) - (doneButton "Continue" bcPuiseuxSeriesGen)) - htShowPage() - -bcTaylorSeriesGen htPage == bcSeriesGen(htPage) - -bcLaurentSeriesGen htPage == - bcSeriesGen(htPage) - -bcPuiseuxSeriesGen htPage == - bcSeriesGen(htPage) - -bcSeriesGen(htPage) == - step:= htpLabelInputString(htPage,'step) - min := htpLabelInputString(htPage,'min) - formula := htpLabelInputString(htPage,'formula) - index := htpLabelInputString(htPage,'index) - var := htpLabelInputString(htPage,'variable) - point := htpLabelInputString(htPage,'point) - varPart := STRCONC(var,'" = ",point) - minPart := STRCONC(min,'"..") - bcFinish('"series",STRCONC(index,'" +-> ",formula),varPart,minPart,step) - -bcLimit() == - htInitPage('"Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain SY (Symbol))) - (text . "What kind of limit do you want to compute? ") - (text . "\blankline ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{A real limit?}" "" bcRealLimit real)) - (text . "\indentrel{17}\tab{0}") - (text . "The limit as the variable approaches a {\em real} value along the real axis") - (text . "\indentrel{-17}") - (text . "\item ") - (text . "\blankline ") - (bcLinks ("\menuitemstyle{A complex limit?}" "" bcComplexLimit complex)) - (text . "\indentrel{17}\tab{0}") - (text . "The limit as the variable approaches a {\em complex} value along any path in the complex plane") - (text . "\indentrel{-17}") - (text . "\endmenu") - ) - htShowPage() - -bcRealLimit(a,b) == - htInitPage('"Real Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to compute the limit of:") - (text . "\newline\tab{2} ") - (bcStrings (45 "x*sin(1/x)" expression EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the name of the {\em variable}: ") - (text . "\tab{41}") - (bcStrings (6 x variable SY)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Compute the limit at") - (radioButtons location - ("A finite point:" ( - (text . "\tab{33}") - (bcStrings (6 0 point F))) finitePoint) - ("Plus infinity" "" plusInfinity) - ("Minus infinity" "" minusInfinity)) - (doneButton "Continue" bcRealLimitGen)) - htShowPage() - -bcRealLimitGen htPage == - (p := htpButtonValue(htPage,'location)) ^= 'finitePoint => - fun := htpLabelInputString(htPage,'expression) - var := htpLabelInputString(htPage,'variable) - loc := - p = 'plusInfinity => '"%plusInfinity" - '"%minusInfinity" - bcFinish('"limit",fun,STRCONC(var,'" = ",loc)) - page := htInitPage('"Real Limit Basic Command",nil) - htMakePage '( - (text . "Compute the limit") - (lispLinks - ("\menuitemstyle{From both directions}" "" bcRealLimitGen1 both) - ("\menuitemstyle{From the right}" "" bcRealLimitGen1 right) - ("\menuitemstyle{From the left}" "" bcRealLimitGen1 left))) - htpSetProperty(page,'fun,htpLabelInputString(htPage,'expression)) - htpSetProperty(page,'var,htpLabelInputString(htPage,'variable)) - htpSetProperty(page,'loc,htpLabelInputString(htPage,'point)) - htShowPage() - -bcRealLimitGen1(htPage,key) == - direction := - key = 'right => '"_"right_"" - key = 'left => '"_"left_"" - nil - fun := htpProperty(htPage,'fun) - var := htpProperty(htPage,'var) - loc := htpProperty(htPage,'loc) - varPart := STRCONC(var,'" = ",loc) - bcFinish('"limit",fun,varPart,direction) - -bcComplexLimit(a,b) == - htInitPage('"Complex Limit Basic Command",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain SY (Symbol))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the {\em function} you want to compute the limit of:") - (text . "\newline\tab{2} ") - (bcStrings (40 "sin(a*x)/tan(b*x)" expression EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the name of the {\em variable}: ") - (text . "\tab{37}") - (bcStrings (5 x variable SY)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Compute the limit at") - (radioButtons location - ("A finite point:" ( - (text . "\newline\space{0}Real part:\space{3}") - (bcStrings (20 0 real F)) - (text . "\newline Complex part:") - (bcStrings (20 0 complex F))) finitePoint) - ("Complex infinity" "" complexInfinity)) - (doneButton "Continue" bcComplexLimitGen)) - htShowPage() - -bcComplexLimitGen htPage == - fun := htpLabelInputString(htPage,'expression) - var := htpLabelInputString(htPage,'variable) - loc := - (p := htpButtonValue(htPage,'location)) = 'finitePoint => - real := htpLabelInputString(htPage,'real) - comp := htpLabelInputString(htPage,'complex) - complexPart := - comp = '"0" => '"" - comp = '"1" => '"%i" - STRCONC(comp,'"*%i") - real = '"0" => - complexPart = '"" => "0" - complexPart - complexPart = '"" => real - STRCONC(real,'" + ",complexPart) - '"%infinity" - varPart := STRCONC(var,'" = ",loc) - bcFinish('"complexLimit",fun,varPart) - - diff --git a/src/interp/bc-misc.boot.pamphlet b/src/interp/bc-misc.boot.pamphlet new file mode 100644 index 00000000..8e879add --- /dev/null +++ b/src/interp/bc-misc.boot.pamphlet @@ -0,0 +1,946 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp bc-misc.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--Hypertex commands other than solve and matrix + +bcDrawIt2(ind,a,b) == STRCONC('"{}",ind,'"=",a,'"{}..",b,'"{}") + +bcIndefiniteIntegrate() == + htInitPage("Indefinite Integration Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to integrate:") + (text . "\newline\tab{2} ") + (bcStrings (45 "1/(x**2 + 6)" integrand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em variable of integration}:") + (text . "\tab{37}") + (bcStrings (10 x symbol SY)) + (doneButton "Continue" bcIndefiniteIntegrateGen)) + htShowPage() + +bcIndefiniteIntegrateGen htPage == + integrand := htpLabelInputString(htPage,'integrand) + var := htpLabelInputString(htPage,'symbol) + bcGen STRCONC('"integrate(",integrand,'",",var,")") + + +bcDefiniteIntegrate() == + htInitPage("Definite Integration Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to integrate:") + (text . "\newline\tab{2} ") + (bcStrings (45 "1/(x**2 + 6)" integrand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em variable of integration}:") + (text . "\tab{37}") + (bcStrings (10 x symbol SY)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Enter {\em lower limit}:") + (radioButtons fromButton + ("" "Minus infinity" minusInfinity) + ("" ( + (text . "A finite point:\tab{15}") + (bcStrings (10 0 from EM . bcOptional))) fromPoint)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\indent{2}\newline Enter {\em upper limit}:") + (radioButtons toButton + ("" "Plus infinity" plusInfinity) + ("" ( + (text "A finite point:\tab{15}") + (bcStrings (10 y to EM . bcOptional))) toPoint)) + (doneButton "Continue" bcDefiniteIntegrateGen)) + htShowPage() + +bcDefiniteIntegrateGen htPage == + integrand := htpLabelInputString(htPage,'integrand) + var := htpLabelInputString(htPage,'symbol) + lowerLimit := + htpButtonValue(htPage,'fromButton) = 'fromPoint => + htpLabelInputString(htPage,'from) + '"%minusInfinity" + upperLimit := + htpButtonValue(htPage,'toButton) = 'toPoint => + htpLabelInputString(htPage,'to) + '"%plusInfinity" + varpart := STRCONC(var,'" = ",lowerLimit,'"..",upperLimit) + bcGen + STRCONC('"integrate(",integrand,'",",varpart,'")") + +bcSum() == + htInitPage("Sum Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you would like to sum:") + (text . "\newline\tab{2} ") + (bcStrings (44 "i**3" summand EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em summation index}:") + (text . "\tab{36}") + (bcStrings (10 i index SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the limits of the sum:") + (text . "\newline\tab{10}{\em From:}") + (bcStrings (10 1 first S)) + (text . "\tab{32}{\em To:}") + (text . "\tab{36}") + (bcStrings (10 n last S)) + (doneButton "Continue" bcSumGen)) + htShowPage() + +bcSumGen htPage == + mand := htpLabelInputString(htPage,'summand) + index := htpLabelInputString(htPage,'index) + first := htpLabelInputString(htPage,'first) + last := htpLabelInputString(htPage,'last) + bcGen STRCONC('"sum(",mand,'",",index,'" = ",first,'"..",last,'")") + +bcProduct() == + htInitPage("Product Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "Enter the {\em function} you would like to compute the product of:") + (inputStrings ("" "" 45 "i**2" mand EM)) + (text . "\vspace{1}\newline") + (inputStrings ("Enter the {\em index of the product}:" "" 5 i index SY)) + (text . "\vspace{1}\newline Enter the limits of the index:") + (inputStrings + ("\newline{\em From:}" "" 10 "1" first EM) + ("{\em To:}\space{2}" "" 10 "n" last EM)) + (doneButton "Continue" bcProductGen)) + htShowPage() + +bcProductGen htPage == + mand := htpLabelInputString(htPage,'mand) + index := htpLabelInputString(htPage,'index) + first := htpLabelInputString(htPage,'first) + last := htpLabelInputString(htPage,'last) + bcGen STRCONC('"product(",mand,'",",index,'",",first,'",",last,'")") + +bcDifferentiate() == + htInitPage("Differentiate Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to differentiate:") + (text . "\newline\tab{2} ") + (bcStrings (55 "sin(x*y)" diffand EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline List the {\em variables} you want to differentiate with respect to?") + (text . "\newline\tab{2} ") + (bcStrings (55 "x y" variables S . quoteString)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline List the number of {\em times} you want to differentiate with respect to each variable (leave blank if once for each)") + (text . "\newline\tab{2} ") + (bcStrings (55 "1 2" times S . quoteString))) + htMakeDoneButton('"Continue", 'bcDifferentiateGen) + htShowPage() + +bcDifferentiateGen htPage == + mand := htpLabelInputString(htPage,'diffand) + varlist := bcString2WordList htpLabelInputString(htPage,'variables) + indexList := bcString2WordList htpLabelInputString(htPage,'times) + varpart := + #varlist > 1 => bcwords2liststring varlist + first varlist + indexpart := + null indexList => nil + null rest indexList => first indexList + #indexList = #varlist => bcwords2liststring indexList + bcError '"You must say how many times you want to differentiate with respect to each variable---or leave that entry blank" + lastPart := + indexpart => STRCONC('",",indexpart,'")") + '")" + bcGen STRCONC('"differentiate(",mand,'",",varpart,lastPart) + +bcDraw() == + htInitPage('"Draw Basic Command",nil) + bcHt '"What would you like to draw?" + bcHt '"\newline\centerline{{\em Two Dimensional Plots}}\newline" + bcHt '"\lispdownlink{A function of one variable}{(|bcDraw2Dfun|)}" + bcHt '"\space{2}y = f(x)\newline" + bcHt '"\lispdownlink{A parametrically defined curve}{(|bcDraw2Dpar|)}" + bcHt '"\space{2}(x(t), y(t))\newline" + bcHt '"\lispdownlink{A solution to a polynomial equation}{(|bcDraw2DSolve|)}" + bcHt '"\space{2} p(x,y) = 0\newline" + bcHt '"\vspace{1}\newline " + bcHt '"\centerline{{\em Three Dimensional Surfaces}}\newline\newline" + bcHt '"\lispdownlink{A function of two variables}{(|bcDraw3Dfun|)}" + bcHt '"\space{2} z = f(x,y)\newline" + bcHt '"\lispdownlink{A parametrically defined tube}{(|bcDraw3Dpar|)}" + bcHt '"\space{2}(x(t), y(t), z(t))\newline" + bcHt '"\lispdownlink{A parameterically defined surface}{(|bcDraw3Dpar1|)}" + bcHt '"\space{2}(x(u,v), y(u,v), z(u,v))\newline" + htShowPage() + + +bcDraw2Dfun() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing {\em y = f(x)}}\newline " + "\centerline{where {\em y} is the dependent variable and}\newline " + "\centerline{where {\em x} is the independent variable}\vspace{1}\newline " + "\menuitemstyle{}\tab{2}What {\em function} f would you like to draw?\newline\tab{2}") + (bcStrings (55 "x*cos(x)" function EM)) + (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") + (bcStrings (6 y dependent SY)) + (text . "\newline\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}Enter {\em independent} variable and {\em range}:\newline\tab{2} ") + (text . "{\em Variable:}") + (bcStrings (6 x ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 0 from1 F)) + (text . "{\em to:}") + (bcStrings (9 30 to1 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your curve:" + ) + (bcStrings (15 "y = x*cos(x)" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw2DfunGen) + (text . "{}")) + htShowPage() + +bcDraw2DfunGen htPage == + fun := htpLabelInputString(htPage,'function) + dep := htpLabelInputString(htPage,'dependent) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + if (title ^= '"") then + titlePart := STRCONC('"{}",'"title ==_"",title,'"_"") + bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1),titlePart) + else + bcFinish('"draw",fun,bcDrawIt2(ind,from1,to1)) + + +bcDraw2Dpar() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined curve:}\newline " + "\centerline{{\em ( f1(t), f2(t) )}}\newline " + "\centerline{in terms of two functions {\em f1} and {\em f2}}" + "\centerline{and an independent variable {\em t}}\vspace{1}\newline" + "\menuitemstyle{}\tab{2}Enter the two {\em functions:}") + (text . "\newline\tab{2}{\em Function 1:}") + (bcStrings (44 "-9*sin(4*t/5)" function1 EM)) + (text . "\newline\tab{2}{\em Function 2:}") + (bcStrings (44 "8*sin(t)" function2 EM)) + (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") + (text . "{\em Variable:}") + (bcStrings (6 t ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-5*\%pi" from1 F)) + (text . "{\em to:}") + (bcStrings (9 "5*\%pi" to1 F)) + (text + "\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Optionally enter a {\em title} for your curve:") + (bcStrings (15 "Lissajous" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw2DparGen)) + htShowPage() + +bcDraw2DparGen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'")") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),titlePart) + else + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1)) + +bcDraw2DSolve() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Plotting the solution to {\em p(x,y) = 0}, where} " + "\centerline{{\em p} is a polynomial in two variables {\em x} and {\em y}}" + "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em polynomial} p:" + "\newline\tab{2}") + (bcStrings (40 "y**2+7*x*y-(x**3+16*x)" function EM)) + (text . "\vspace{1}\newline\menuitemstyle{}\tab{2}Enter the {\em variables}:") + (text . "\newline\tab{2}{\em Variable 1:} ") + (bcStrings (4 x independent1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -15 from1 F)) + (text . "{\em to:}") + (bcStrings (9 10 to1 F)) + (text . "\newline\tab{2}{\em Variable 2:} ") + (bcStrings (4 y independent2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -10 from2 F)) + (text . "{\em to:}") + (bcStrings (9 50 to2 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your curve:") + (bcStrings (15 "" title S)) + (text . "\indent{0}")) + htMakeDoneButton('"Continue",'bcDraw2DSolveGen) + htShowPage() + +bcDraw2DSolveGen htPage == + fun := htpLabelInputString(htPage,'function) + ind1 := htpLabelInputString(htPage,'independent1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'independent2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + clipPart := STRCONC('"{}",'"range==[{}",from1,'"..",to1,",{}",from2,'"..",to2,'"]") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart,titlePart) + else + bcFinish('"draw",STRCONC(fun,'" = 0 "),ind1,ind2,clipPart) + +bcDraw3Dfun() == + htInitPage('"Three Dimensional Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing {\em z = f(x,y)}}\newline " + "\centerline{where {\em z} is the dependent variable and}\newline " + "\centerline{where {\em x, y} are the independent variables}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "What {\em function} f which you like to draw?\newline\tab{2}") + (bcStrings (55 "exp(cos(x-y)-sin(x*y))-2" function EM)) + (text . "\newline\menuitemstyle{}\tab{2}Enter {\em dependent} variable:") + (bcStrings (6 z dependent SY)) + (text + "\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Enter {\em independent} variables and ranges:\newline\tab{2} " + "{\em Variable:}") + (bcStrings (6 x independent1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -5 from1 F)) + (text . "{\em to:}") + (bcStrings (9 5 to1 F)) + (text . "\newline\tab{2}{\em Variable:}") + (bcStrings (6 y independent2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 -5 from2 F)) + (text . "{\em to:}") + (bcStrings (9 5 to2 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw3DfunGen)) + htShowPage() + +bcDraw3DfunGen htPage == + fun := htpLabelInputString(htPage,'function) + dep := htpLabelInputString(htPage,'dependent) + ind1 := htpLabelInputString(htPage,'independent1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'independent2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + if (title ^= '"") then + titlePart := (title = '"" => nil;STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2),titlePart) + else + bcFinish('"draw",fun,bcDrawIt2(ind1,from1,to1),bcDrawIt2(ind2,from2,to2)) + +bcDraw3Dpar() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined curve:" + "{\em ( f1(t), f2(t), f3(t) )}}\newline " + "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " + "\centerline{and an independent variable {\em t}}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Enter the three {\em functions} of the independent variable:") + (text . "\newline\tab{2}{\em Function f1:}") + (bcStrings (42 "1.3*cos(2*t)*cos(4*t) + sin(4*t)*cos(t)" function1 EM)) + (text . "\newline\tab{2}{\em Function f2:}") + (bcStrings (42 "1.3*sin(2*t)*cos(4*t) - sin(4*t)*sin(t)" function2 EM)) + (text . "\newline\tab{2}{\em Function f3:}") + (bcStrings (42 "2.5*cos(4*t)" function3 EM)) + (text ."\vspace{1}\newline\menuitemstyle{}\tab{2}Enter {\em independent} variable and range:\newline\tab{2} ") + (text ."{\em Variable:}") + (bcStrings (6 t ind SY)) + (text . "ranges {\em from:}") + (bcStrings (9 0 from1 F)) + (text "{\em to:}") + (bcStrings (9 "4*\%pi" to1 F)) + (text + "\indent{0}\vspace{1}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "knot" title S)) + (text . "\indent{0}") + (doneButton "Continue" bcDraw3DparGen)) + htShowPage() + +bcDraw3DparGen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + fun3 := htpLabelInputString(htPage,'function3) + ind := htpLabelInputString(htPage,'ind) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + title := htpLabelInputString(htPage,'title) + curvePart := STRCONC('"curve(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") + tubePart := '"{}tubeRadius==.25,{}tubePoints==16" + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart,titlePart) + else + bcFinish('"draw",curvePart,bcDrawIt2(ind,from1,to1),tubePart) + +bcDraw3Dpar1() == + htInitPage('"Draw Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text + "\centerline{Drawing a parametrically defined surface:}\newline " + "\centerline{{\em ( f1(u,v), f2(u,v), f3(u,v) )}}\newline " + "\centerline{in terms of three functions {\em f1}, {\em f2}, and {\em f3}}\newline " + "\centerline{and two independent variables {\em u} and {\em v}}\vspace{1}\newline\menuitemstyle{}\tab{2}" + "Enter the three {\em functions} of the independent variables:") + (text . "\newline\tab{2}") + (text . "{\em Function f1:}") + (bcStrings (43 "u*sin(v)" function1 EM)) + (text . "\newline\tab{2}") + (text . "{\em Function f2:}") + (bcStrings (43 "v*cos(u)" function2 EM)) + (text . "\newline\tab{2}") + (text . "{\em Function f3:}") + (bcStrings (43 "u*cos(v)" function3 EM)) + (text . "\newline\menuitemstyle{}\tab{2}Enter independent {\em variables} and ranges:") + (text . "\newline\tab{2}") + (text . "{\em Variable 1:}") + (bcStrings (5 u ind1 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-\%pi" from1 F)) + (text . "{\em to:}") + (bcStrings (9 "\%pi" to1 F)) + (text . "\newline\tab{2}") + (text . "{\em Variable 2:}") + (bcStrings (5 v ind2 SY)) + (text . "ranges {\em from:}") + (bcStrings (9 "-\%pi/2" from2 F)) + (text . "{\em to:}") + (bcStrings (9 "\%pi/2" to2 F)) + (text + "\indent{0}\newline\menuitemstyle{}\tab{2} " + "Optionally enter a {\em title} for your surface:") + (bcStrings (15 "surface" title S)) + (text . "\indent{0}")) + htMakeDoneButton ('"Continue",'bcDraw3Dpar1Gen) + htShowPage() + +bcDraw3Dpar1Gen htPage == + fun1 := htpLabelInputString(htPage,'function1) + fun2 := htpLabelInputString(htPage,'function2) + fun3 := htpLabelInputString(htPage,'function3) + ind1 := htpLabelInputString(htPage,'ind1) + from1 := htpLabelInputString(htPage,'from1) + to1 := htpLabelInputString(htPage,'to1) + ind2 := htpLabelInputString(htPage,'ind2) + from2 := htpLabelInputString(htPage,'from2) + to2 := htpLabelInputString(htPage,'to2) + title := htpLabelInputString(htPage,'title) + r1 := bcDrawIt2(ind1,from1,to1) + r2 := bcDrawIt2(ind2,from2,to2) + surfacePart := STRCONC('"surface(",'"{}",fun1,'",{}",fun2,'",{}",fun3,'")") + if (title ^= '"") then + titlePart := (title = '"" => nil; STRCONC('"{}",'"title ==_"",title,'"_"")) + bcFinish('"draw",surfacePart,r1,r2,titlePart) + else + bcFinish('"draw",surfacePart,r1,r2) + +bcSeries() == + htInitPage('"Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "Create a series by: ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Expansion}" "" bcSeriesExpansion NILl)) + (text . "\tab{11}Expand a function in a series around a point") + (text . "\item ") + (bcLinks ("\menuitemstyle{Formula}" "" bcSeriesByFormula NIL)) + (text . "\tab{11}Give a formula for the {\em i}'th coefficient") + (text . "\endmenu")) + htShowPage() + +bcSeriesExpansion(a,b) == + htInitPage('"Series Expansion Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to expand in a power series") + (text . "\newline\tab{2} ") + (bcStrings (55 "log(cot(x))" function EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 "\%pi/2" point EM))) + htMakeDoneButton('"Continue",'bcSeriesExpansionGen) + htShowPage() + +bcSeriesExpansionGen htPage == + fun := htpLabelInputString(htPage,'function) + var := htpLabelInputString(htPage,'variable) + point := htpLabelInputString(htPage,'point) + terms := htpLabelInputString(htPage,'numberOfTerms) + bcFinish("series",fun,STRCONC(var,'" = ",point)) + +bcSeriesByFormula(a,b) == + htInitPage('"Power Series Basic Command",nil) + htMakePage '( + (text . "Select the kind of power series you want to create:") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Taylor Series}" "" bcTaylorSeries taylor)) + (text . "\newline Series where the exponent ranges over the integers from a {\em non-negative integer} value to plus infinity by an arbitrary {\em positive integer} step size") + (text . "\item ") + (bcLinks ("\menuitemstyle{Laurent Series}" "" bcLaurentSeries laurent)) + (text . "\newline Series where the exponent ranges from an arbitrary {\em integer} value to plus infinity by an arbitrary {\em positive integer} step size") + (text . "\item ") + (bcLinks ("\menuitemstyle{Puiseux Series}" "" bcPuiseuxSeries puiseux)) + (text . "\newline Series where the exponent ranges from an arbitrary {\em rational value} to plus infinity by an arbitrary {\em positive rational number} step size") + (text . "\endmenu")) + htShowPage() + +bcTaylorSeries(a,b) == + htInitPage('"Taylor Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the formula for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings (55 "1/factorial(i)" formula EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 i index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point EM)) + (text . "\blankline ") + (text ."For Taylor Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary non-negative integer, to plus infinity; the {\em step size} is any positive integer.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of the index (an integer)") + (text . "\tab{49}") + (bcStrings (8 "0" min I)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive integer)") + (text . "\tab{49}") + (bcStrings (8 "1" step PI)) + (doneButton "Continue" bcTaylorSeriesGen)) + htShowPage() + +bcSeriesByFormulaGen htPage == bcNotReady() + +bcLaurentSeries(a,b) == + htInitPage('"Laurent Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain I (Integer)) + (isDomain PI (PositiveInteger)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the formula for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings (55 "(-1)**(n - 1)/(n + 2)" formula EM)) + (text . "\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 n index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point F)) + (text . "\blankline") + (text . "\newline For Laurent Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitrary integer value, to plus infinity; the {\em step size} is any positive integer.") + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of the index (an integer)") + (text . "\tab{49}") + (bcStrings (8 "-1" min I)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive integer)") + (text . "\tab{49}") + (bcStrings (8 "1" step PI)) + (doneButton "Continue" bcLaurentSeriesGen)) + htShowPage() + +bcPuiseuxSeries(a,b) == + htInitPage('"Puiseux Series Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain EEM (Expression $EmptyMode)) + (isDomain S (String)) + (isDomain I (Integer)) + (isDomain PI (PositiveInteger)) + (isDOmain RN (Fraction (Integer))) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text ."Enter the {\em formula} for the general coefficient of the series") + (text . "\newline\tab{2} ") + (bcStrings(55 "(-1)**((3*n - 4)/6)/factorial(n - 1/3)" formula EM)) + (text . "\vspace{1}\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em index variable} for your formula") + (text . "\tab{49}") + (bcStrings (8 n index SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em power series variable}") + (text . "\tab{49}") + (bcStrings (8 x variable SY)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em point} about which you want to expand") + (text . "\tab{49}") + (bcStrings (8 0 point F)) + (text . "\blankline ") + (text . "For Puiseux Series, the exponent of the power series variable ranges from an {\em initial value}, an arbitary rational number, to plus infinity; the {\em step size} is an any positive rational number.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em initial value} of index (a rational number)") + (text . "\tab{51}") + (bcStrings (6 "4/3" min RN)) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em step size} (a positive rational number)") + (text . "\tab{51}") + (bcStrings (6 "2" step RN)) + (doneButton "Continue" bcPuiseuxSeriesGen)) + htShowPage() + +bcTaylorSeriesGen htPage == bcSeriesGen(htPage) + +bcLaurentSeriesGen htPage == + bcSeriesGen(htPage) + +bcPuiseuxSeriesGen htPage == + bcSeriesGen(htPage) + +bcSeriesGen(htPage) == + step:= htpLabelInputString(htPage,'step) + min := htpLabelInputString(htPage,'min) + formula := htpLabelInputString(htPage,'formula) + index := htpLabelInputString(htPage,'index) + var := htpLabelInputString(htPage,'variable) + point := htpLabelInputString(htPage,'point) + varPart := STRCONC(var,'" = ",point) + minPart := STRCONC(min,'"..") + bcFinish('"series",STRCONC(index,'" +-> ",formula),varPart,minPart,step) + +bcLimit() == + htInitPage('"Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain SY (Symbol))) + (text . "What kind of limit do you want to compute? ") + (text . "\blankline ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{A real limit?}" "" bcRealLimit real)) + (text . "\indentrel{17}\tab{0}") + (text . "The limit as the variable approaches a {\em real} value along the real axis") + (text . "\indentrel{-17}") + (text . "\item ") + (text . "\blankline ") + (bcLinks ("\menuitemstyle{A complex limit?}" "" bcComplexLimit complex)) + (text . "\indentrel{17}\tab{0}") + (text . "The limit as the variable approaches a {\em complex} value along any path in the complex plane") + (text . "\indentrel{-17}") + (text . "\endmenu") + ) + htShowPage() + +bcRealLimit(a,b) == + htInitPage('"Real Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to compute the limit of:") + (text . "\newline\tab{2} ") + (bcStrings (45 "x*sin(1/x)" expression EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the name of the {\em variable}: ") + (text . "\tab{41}") + (bcStrings (6 x variable SY)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Compute the limit at") + (radioButtons location + ("A finite point:" ( + (text . "\tab{33}") + (bcStrings (6 0 point F))) finitePoint) + ("Plus infinity" "" plusInfinity) + ("Minus infinity" "" minusInfinity)) + (doneButton "Continue" bcRealLimitGen)) + htShowPage() + +bcRealLimitGen htPage == + (p := htpButtonValue(htPage,'location)) ^= 'finitePoint => + fun := htpLabelInputString(htPage,'expression) + var := htpLabelInputString(htPage,'variable) + loc := + p = 'plusInfinity => '"%plusInfinity" + '"%minusInfinity" + bcFinish('"limit",fun,STRCONC(var,'" = ",loc)) + page := htInitPage('"Real Limit Basic Command",nil) + htMakePage '( + (text . "Compute the limit") + (lispLinks + ("\menuitemstyle{From both directions}" "" bcRealLimitGen1 both) + ("\menuitemstyle{From the right}" "" bcRealLimitGen1 right) + ("\menuitemstyle{From the left}" "" bcRealLimitGen1 left))) + htpSetProperty(page,'fun,htpLabelInputString(htPage,'expression)) + htpSetProperty(page,'var,htpLabelInputString(htPage,'variable)) + htpSetProperty(page,'loc,htpLabelInputString(htPage,'point)) + htShowPage() + +bcRealLimitGen1(htPage,key) == + direction := + key = 'right => '"_"right_"" + key = 'left => '"_"left_"" + nil + fun := htpProperty(htPage,'fun) + var := htpProperty(htPage,'var) + loc := htpProperty(htPage,'loc) + varPart := STRCONC(var,'" = ",loc) + bcFinish('"limit",fun,varPart,direction) + +bcComplexLimit(a,b) == + htInitPage('"Complex Limit Basic Command",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain SY (Symbol))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the {\em function} you want to compute the limit of:") + (text . "\newline\tab{2} ") + (bcStrings (40 "sin(a*x)/tan(b*x)" expression EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the name of the {\em variable}: ") + (text . "\tab{37}") + (bcStrings (5 x variable SY)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Compute the limit at") + (radioButtons location + ("A finite point:" ( + (text . "\newline\space{0}Real part:\space{3}") + (bcStrings (20 0 real F)) + (text . "\newline Complex part:") + (bcStrings (20 0 complex F))) finitePoint) + ("Complex infinity" "" complexInfinity)) + (doneButton "Continue" bcComplexLimitGen)) + htShowPage() + +bcComplexLimitGen htPage == + fun := htpLabelInputString(htPage,'expression) + var := htpLabelInputString(htPage,'variable) + loc := + (p := htpButtonValue(htPage,'location)) = 'finitePoint => + real := htpLabelInputString(htPage,'real) + comp := htpLabelInputString(htPage,'complex) + complexPart := + comp = '"0" => '"" + comp = '"1" => '"%i" + STRCONC(comp,'"*%i") + real = '"0" => + complexPart = '"" => "0" + complexPart + complexPart = '"" => real + STRCONC(real,'" + ",complexPart) + '"%infinity" + varPart := STRCONC(var,'" = ",loc) + bcFinish('"complexLimit",fun,varPart) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/bc-solve.boot b/src/interp/bc-solve.boot deleted file mode 100644 index e3f6f99b..00000000 --- a/src/interp/bc-solve.boot +++ /dev/null @@ -1,362 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - - -- HyperTeX basic Solve Command -$systemType := nil -$numberOfEquations := 0 -$solutionMethod := nil - -bcSolve() == - htInitPage('"Solve Basic Command", nil) - htMakePage '( - (text . "What do you want to solve? ") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{A System Of Linear Equations}" "" bcLinearSolve linear)) - (text . "\item ") - (bcLinks ("\menuitemstyle{A System of Polynomial Equations}" "" bcSystemSolve polynomial)) - (text . "\item ") - (bcLinks ("\menuitemstyle{A Single Polynomial Equation}" "" bcSolveSingle onePolynomial)) - (text . "\endmenu")) - htShowPage() - -bcLinearSolve(p,nn) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (text . "How do you want to enter the equations?") - (text . "\beginmenu") - (text . "\item ") - (text . "\newline ") - (bcLinks ("\menuitemstyle{Directly as equations}" "" bcLinearSolveEqns equations)) - (text . "\item ") - (text . "\newline ") - (bcLinks ("\menuitemstyle{In matrix form}" "" bcLinearSolveMatrix matrix)) - (text . "\indentrel{16}\tab{0}") - (text . " \spad{AX = B}, where \spad{A} is a matrix of coefficients and \spad{B} is a vector" ) - (text . "\indentrel{-16}\item ") - (text . "\endmenu")) - htShowPage() - -bcLinearSolveEqns(htPage, p) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (inputStrings - ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) - htMakeDoneButton('"Continue", 'bcLinearSolveEqns1) - htShowPage() - -bcSystemSolve(htPage, p) == - htInitPage('"Basic Solve Command", nil) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (inputStrings - ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) - htMakeDoneButton('"Continue", 'bcSystemSolveEqns1) - htShowPage() - -bcSolveSingle(htPage,p) == - htpSetProperty(htPage,'systemType, 'onePolynomial) - htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) - bcInputEquations(htPage,'exact) - -bcSystemSolveEqns1 htPage == - htpSetProperty(htPage,'systemType,'polynomial) - htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) - bcInputEquations(htPage,'exact) - -bcLinearSolveEqns1 htPage == - htpSetProperty(htPage,'systemType,'linear) - htpSetProperty(htPage,'exitFunction,'bcLinearSolveEqnsGen) - bcInputEquations(htPage,'exact) - -bcInputSolveInfo htPage == - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htpSetProperty(page,'numberOfEquations,htpProperty(htPage,'numberOfEquations)) - htpSetProperty(page,'inputArea,htpInputAreaAlist htPage) - htMakePage '( - (domainConditions (isDomain PI (PositiveInteger))) - (text . "What would you like?") - (text . "\beginmenu") - (text . "\item ") - (bcLinks ("\menuitemstyle{Exact Solutions}" "" bcSolveEquations exact)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of {\em roots} of irreducible polynomials") - (text . "\indentrel{-18}") - (text . "\item ") - (bcLinks ("\menuitemstyle{Numeric Solutions}" "" bcSolveEquationsNumerically numeric)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of approximate real or complex {\em numbers}") - (text . "\indentrel{-18}") - (text . "\item ") - (bcLinks ("\menuitemstyle{Radical Solutions}" "" bcSolveEquations radical)) - (text . "\indentrel{18}\tab{0} ") - (text . "Solutions expressed in terms of {\em radicals} if it is possible") - (text . "\indentrel{-18}") - (text . "\endmenu")) - htShowPage() - -bcInputEquations(htPage,solutionMethod) == - numEqs := - htpProperty(htPage, 'systemType) = 'onePolynomial => 1 - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage,'numberOfEquations) - objValUnwrap htpLabelSpadValue(htPage, 'numberOfEquations) - linearPred := htpProperty(htPage,'systemType) = 'linear - labelList := - numEqs = 1 => '( - (bcStrings (42 "x^2+1" l1 P)) - (text . " = ") - (bcStrings (6 0 r1 P))) - "append"/[f(i,numEqs,linearPred) for i in 1..numEqs] where f(i,n,linearp) == - spacer := (i > 99 => 0; i > 9 => 1; 2) - prefix := STRCONC('"\newline\tab{2}{\em Equation ",STRINGIMAGE i,'":}") - prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") - lnam := INTERN STRCONC('"l",STRINGIMAGE i) - rnam := INTERN STRCONC('"r",STRINGIMAGE i) - var:= - linearp => bcMakeLinearEquations(i,n) - bcMakeEquations(i,n) - [['text,:prefix],['bcStrings,[30,var,lnam,'P]],'(text . " = "),['bcStrings,[5,"0",rnam,'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htpSetProperty(page, 'numberOfEquations, numEqs) - htpSetProperty(page, 'solutionMethod,solutionMethod) - htSay '"\newline\menuitemstyle{}\tab{2}" - htSay - numEqs = 1 => '"Enter the {\em Equation}:" - '"Enter the {\em Equations}:" - htSay '"\newline\tab{2}" - htMakePage equationPart - bcHt '"\blankline " - htSay '"\newline\menuitemstyle{}\tab{2}" - htMakePage - numEqs = 1 => '( - (text ."Enter the {\em unknown} (leave blank if implied): ") - (text . "\tab{48}") - (bcStrings (6 "x" unknowns S . quoteString))) - ['(text . "Enter the unknowns (leave blank if implied):"), - '(text . "\tab{44}"), - ['bcStrings, [10,bcMakeUnknowns(numEqs),'unknowns,'P]]] - htMakeDoneButton('"Continue", 'bcInputEquationsEnd) - htShowPage() - -bcCreateVariableString(i) == - STRCONC('"x",STRINGIMAGE i) - -bcMakeUnknowns(number)== - APPLY('CONCAT,[STRCONC(bcCreateVariableString(i)," ") for i in 1..number]) - -bcMakeEquations(i,number)== - number =1 => STRCONC(bcCreateVariableString(1),"^2+1") - bcCreateVariableString(i) - STRCONC( - STRCONC( - APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), - STRCONC("-2*",STRCONC(bcCreateVariableString(i),"^2"))) - - -bcMakeLinearEquations(i,number)== - number = 1 => bcCreateVariableString(1) - number = 2 => - i=1 => STRCONC(bcCreateVariableString(1),STRCONC("+",bcCreateVariableString(2))) - STRCONC(bcCreateVariableString(1),STRCONC("-",bcCreateVariableString(2))) - STRCONC( - STRCONC( - APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), - STRCONC("-2*",bcCreateVariableString(i))) - - -bcInputEquationsEnd htPage == - fun := htpProperty(htPage, 'exitFunction) => FUNCALL(fun,htPage) - systemError nil - -bcSolveEquationsNumerically(htPage,p) == - page := htInitPage('"Solve Basic Command", htpPropertyList htPage) - htMakePage '( - (text . "What would you like?") - (radioButtons choice - ("Real roots expressed as rational numbers" "" rr) - ("Real roots expressed as floats" "" rf) - ("Complex roots expressed as rational numbers" "" cr) - ("Complex roots expressed as floats" "" cf)) - (text . "\vspace{1}\newline") - (inputStrings - ("Enter the number of desired {\em digits} of accuracy" "" 5 20 acc PI))) - htMakeDoneButton('"Continue", 'bcSolveNumerically1) - htShowPage() - -bcSolveNumerically1(htPage) == - bcSolveEquations(htPage,'numeric) - ---bcSolveNumerically1(htPage,kind) == --- htpSetProperty(htPage,'kind,kind) --- bcSolveEquations(htPage,'numeric) - -bcSolveEquations(htPage,solutionMethod) == - if solutionMethod = 'numeric then - digits := htpLabelInputString(htPage,'acc) - kind := htpButtonValue(htPage,'choice) - accString := - kind in '(rf cf) => STRCONC('"1.e-",digits) - STRCONC('"1/10**",digits) - alist := htpProperty(htPage,'inputArea) - [[.,varpart,:.],:r] := alist - varlist := bcString2WordList varpart - varString := (rest varlist => bcwords2liststring varlist; first varlist) - eqnString := bcGenEquations r - solutionMethod = 'numeric => - name := - kind in '(rf rr) => '"solve" - '"complexSolve" - bcFinish(name,eqnString,accString) - name := - solutionMethod = 'radical => '"radicalSolve" - '"solve" - bcFinish(name,eqnString,varString,accString) - -bcLinearSolveMatrix(htPage,junk) == - bcReadMatrix 'bcLinearSolveMatrix1 - -bcLinearSolveMatrix1 htPage == - page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) - htpSetProperty(page,'matrix,bcLinearExtractMatrix htPage) - htMakePage '( - (text . "The right side vector B is:") - (lispLinks - ("Zero:" "the system is homogeneous" bcLinearSolveMatrixHomo homo) - ("Not zero:" "the system is not homogeneous" bcLinearSolveMatrixInhomo nothomo))) - htShowPage() - -bcLinearExtractMatrix htPage == REVERSE htpInputAreaAlist htPage - -bcLinearSolveMatrixInhomo(htPage,junk) == - nrows := htpProperty(htPage,'nrows) - ncols := htpProperty(htPage,'ncols) - labelList := - [f(i) for i in 1..ncols] where f(i) == - spacer := (i > 99 => 0; i > 9 => 1; 2) - prefix := STRCONC('"{\em Coefficient ",STRINGIMAGE i,'":}") - if spacer ^= 0 then - prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") - name := INTERN STRCONC('"c",STRINGIMAGE i) - [prefix,"",30, 0,name, 'P] - page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) - htpSetProperty(page,'matrix,htpProperty(htPage,'matrix)) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'ncols,ncols) - htMakePage [ - '(domainConditions (isDomain P (Polynomial $EmptyMode))), - '(text . "Enter the right side vector B:"), - ['inputStrings, :labelList], - '(text . "\vspace{1}\newline Do you want:" ), - '(lispLinks - ("All the solutions?" "" bcLinearSolveMatrixInhomoGen all) - ("A particular solution?" "" bcLinearSolveMatrixInhomoGen particular))] - htShowPage() - -bcLinearSolveMatrixInhomoGen(htPage,key) == bcLinearMatrixGen(htPage,key) - -bcLinearSolveMatrixHomo(htPage,key) == bcLinearMatrixGen(htPage,'homo) - -bcLinearMatrixGen(htPage,key) == - matform := bcMatrixGen htPage - key = 'homo => bcFinish('"nullSpace",matform) - vector := [x.1 for x in REVERSE htpInputAreaAlist htPage] - vecform := bcVectorGen vector - form := bcMkFunction('"solve",matform,[vecform]) - bcGen - key = 'particular => STRCONC(form,'".particular") - form - -linearFinalRequest(nhh,mat,vect) == - sayBrightly '"Do you want more information on the meaning of the output" - sayBrightly '" (1) no " - sayBrightly '" (2) yes " - tt := bcQueryInteger(1,2,true) - tt=1 => sayBrightly '"Bye Bye" - tt=2 => explainLinear(nhh) - -explainLinear(flag) == - flag="notHomogeneous" => - '("solve returns a particular solution and a basis for" - "the vector space of solutions for the homogeneous part." - "The particular solution is _"failed_" if one cannot be found.") - flag= "homogeneous" => - '("solve returns a basis for" - "the vector space of solutions for the homogeneous part") - systemError nil - -finalExactRequest(equations,unknowns) == - sayBrightly '"Do you like:" - sayBrightly '" (1) the solutions how they are displayed" - sayBrightly '" (2) to get ????" - sayBrightly '" (3) more information on the meaning of the output" - tt := bcQueryInteger(1,3,true) - tt=1 => sayBrightly '"Bye Bye" - tt=2 => moreExactSolution(equations,unknowns,flag) - tt=3 => explainExact(equations,unknowns) - -bcLinearSolveEqnsGen htPage == - alist := htpInputAreaAlist htPage - if vars := htpLabelInputString(htPage,'unknowns) then - varlist := bcString2WordList vars - varString := (rest varlist => bcwords2liststring varlist; first varlist) - alist := rest alist --know these are first on the list - eqnString := bcGenEquations alist - bcFinish('"solve",eqnString,varString) - -bcGenEquations alist == - y := alist - while y repeat - right := (first y).1 - y := rest y - left := (first y).1 - y := rest y - eqnlist := [STRCONC(left,'" = ",right),:eqnlist] - rest eqnlist => bcwords2liststring eqnlist - first eqnlist - - - - - - - - - - - diff --git a/src/interp/bc-solve.boot.pamphlet b/src/interp/bc-solve.boot.pamphlet new file mode 100644 index 00000000..56314441 --- /dev/null +++ b/src/interp/bc-solve.boot.pamphlet @@ -0,0 +1,384 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp bc-solve.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + + -- HyperTeX basic Solve Command +$systemType := nil +$numberOfEquations := 0 +$solutionMethod := nil + +bcSolve() == + htInitPage('"Solve Basic Command", nil) + htMakePage '( + (text . "What do you want to solve? ") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{A System Of Linear Equations}" "" bcLinearSolve linear)) + (text . "\item ") + (bcLinks ("\menuitemstyle{A System of Polynomial Equations}" "" bcSystemSolve polynomial)) + (text . "\item ") + (bcLinks ("\menuitemstyle{A Single Polynomial Equation}" "" bcSolveSingle onePolynomial)) + (text . "\endmenu")) + htShowPage() + +bcLinearSolve(p,nn) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (text . "How do you want to enter the equations?") + (text . "\beginmenu") + (text . "\item ") + (text . "\newline ") + (bcLinks ("\menuitemstyle{Directly as equations}" "" bcLinearSolveEqns equations)) + (text . "\item ") + (text . "\newline ") + (bcLinks ("\menuitemstyle{In matrix form}" "" bcLinearSolveMatrix matrix)) + (text . "\indentrel{16}\tab{0}") + (text . " \spad{AX = B}, where \spad{A} is a matrix of coefficients and \spad{B} is a vector" ) + (text . "\indentrel{-16}\item ") + (text . "\endmenu")) + htShowPage() + +bcLinearSolveEqns(htPage, p) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (inputStrings + ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) + htMakeDoneButton('"Continue", 'bcLinearSolveEqns1) + htShowPage() + +bcSystemSolve(htPage, p) == + htInitPage('"Basic Solve Command", nil) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (inputStrings + ("Enter the {\em number} of equations:" "" 5 2 numberOfEquations PI))) + htMakeDoneButton('"Continue", 'bcSystemSolveEqns1) + htShowPage() + +bcSolveSingle(htPage,p) == + htpSetProperty(htPage,'systemType, 'onePolynomial) + htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) + bcInputEquations(htPage,'exact) + +bcSystemSolveEqns1 htPage == + htpSetProperty(htPage,'systemType,'polynomial) + htpSetProperty(htPage,'exitFunction,'bcInputSolveInfo) + bcInputEquations(htPage,'exact) + +bcLinearSolveEqns1 htPage == + htpSetProperty(htPage,'systemType,'linear) + htpSetProperty(htPage,'exitFunction,'bcLinearSolveEqnsGen) + bcInputEquations(htPage,'exact) + +bcInputSolveInfo htPage == + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htpSetProperty(page,'numberOfEquations,htpProperty(htPage,'numberOfEquations)) + htpSetProperty(page,'inputArea,htpInputAreaAlist htPage) + htMakePage '( + (domainConditions (isDomain PI (PositiveInteger))) + (text . "What would you like?") + (text . "\beginmenu") + (text . "\item ") + (bcLinks ("\menuitemstyle{Exact Solutions}" "" bcSolveEquations exact)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of {\em roots} of irreducible polynomials") + (text . "\indentrel{-18}") + (text . "\item ") + (bcLinks ("\menuitemstyle{Numeric Solutions}" "" bcSolveEquationsNumerically numeric)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of approximate real or complex {\em numbers}") + (text . "\indentrel{-18}") + (text . "\item ") + (bcLinks ("\menuitemstyle{Radical Solutions}" "" bcSolveEquations radical)) + (text . "\indentrel{18}\tab{0} ") + (text . "Solutions expressed in terms of {\em radicals} if it is possible") + (text . "\indentrel{-18}") + (text . "\endmenu")) + htShowPage() + +bcInputEquations(htPage,solutionMethod) == + numEqs := + htpProperty(htPage, 'systemType) = 'onePolynomial => 1 + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage,'numberOfEquations) + objValUnwrap htpLabelSpadValue(htPage, 'numberOfEquations) + linearPred := htpProperty(htPage,'systemType) = 'linear + labelList := + numEqs = 1 => '( + (bcStrings (42 "x^2+1" l1 P)) + (text . " = ") + (bcStrings (6 0 r1 P))) + "append"/[f(i,numEqs,linearPred) for i in 1..numEqs] where f(i,n,linearp) == + spacer := (i > 99 => 0; i > 9 => 1; 2) + prefix := STRCONC('"\newline\tab{2}{\em Equation ",STRINGIMAGE i,'":}") + prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") + lnam := INTERN STRCONC('"l",STRINGIMAGE i) + rnam := INTERN STRCONC('"r",STRINGIMAGE i) + var:= + linearp => bcMakeLinearEquations(i,n) + bcMakeEquations(i,n) + [['text,:prefix],['bcStrings,[30,var,lnam,'P]],'(text . " = "),['bcStrings,[5,"0",rnam,'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htpSetProperty(page, 'numberOfEquations, numEqs) + htpSetProperty(page, 'solutionMethod,solutionMethod) + htSay '"\newline\menuitemstyle{}\tab{2}" + htSay + numEqs = 1 => '"Enter the {\em Equation}:" + '"Enter the {\em Equations}:" + htSay '"\newline\tab{2}" + htMakePage equationPart + bcHt '"\blankline " + htSay '"\newline\menuitemstyle{}\tab{2}" + htMakePage + numEqs = 1 => '( + (text ."Enter the {\em unknown} (leave blank if implied): ") + (text . "\tab{48}") + (bcStrings (6 "x" unknowns S . quoteString))) + ['(text . "Enter the unknowns (leave blank if implied):"), + '(text . "\tab{44}"), + ['bcStrings, [10,bcMakeUnknowns(numEqs),'unknowns,'P]]] + htMakeDoneButton('"Continue", 'bcInputEquationsEnd) + htShowPage() + +bcCreateVariableString(i) == + STRCONC('"x",STRINGIMAGE i) + +bcMakeUnknowns(number)== + APPLY('CONCAT,[STRCONC(bcCreateVariableString(i)," ") for i in 1..number]) + +bcMakeEquations(i,number)== + number =1 => STRCONC(bcCreateVariableString(1),"^2+1") + bcCreateVariableString(i) + STRCONC( + STRCONC( + APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), + STRCONC("-2*",STRCONC(bcCreateVariableString(i),"^2"))) + + +bcMakeLinearEquations(i,number)== + number = 1 => bcCreateVariableString(1) + number = 2 => + i=1 => STRCONC(bcCreateVariableString(1),STRCONC("+",bcCreateVariableString(2))) + STRCONC(bcCreateVariableString(1),STRCONC("-",bcCreateVariableString(2))) + STRCONC( + STRCONC( + APPLY('CONCAT,[STRCONC(bcCreateVariableString(j),"+") for j in 1..number]),"1"), + STRCONC("-2*",bcCreateVariableString(i))) + + +bcInputEquationsEnd htPage == + fun := htpProperty(htPage, 'exitFunction) => FUNCALL(fun,htPage) + systemError nil + +bcSolveEquationsNumerically(htPage,p) == + page := htInitPage('"Solve Basic Command", htpPropertyList htPage) + htMakePage '( + (text . "What would you like?") + (radioButtons choice + ("Real roots expressed as rational numbers" "" rr) + ("Real roots expressed as floats" "" rf) + ("Complex roots expressed as rational numbers" "" cr) + ("Complex roots expressed as floats" "" cf)) + (text . "\vspace{1}\newline") + (inputStrings + ("Enter the number of desired {\em digits} of accuracy" "" 5 20 acc PI))) + htMakeDoneButton('"Continue", 'bcSolveNumerically1) + htShowPage() + +bcSolveNumerically1(htPage) == + bcSolveEquations(htPage,'numeric) + +--bcSolveNumerically1(htPage,kind) == +-- htpSetProperty(htPage,'kind,kind) +-- bcSolveEquations(htPage,'numeric) + +bcSolveEquations(htPage,solutionMethod) == + if solutionMethod = 'numeric then + digits := htpLabelInputString(htPage,'acc) + kind := htpButtonValue(htPage,'choice) + accString := + kind in '(rf cf) => STRCONC('"1.e-",digits) + STRCONC('"1/10**",digits) + alist := htpProperty(htPage,'inputArea) + [[.,varpart,:.],:r] := alist + varlist := bcString2WordList varpart + varString := (rest varlist => bcwords2liststring varlist; first varlist) + eqnString := bcGenEquations r + solutionMethod = 'numeric => + name := + kind in '(rf rr) => '"solve" + '"complexSolve" + bcFinish(name,eqnString,accString) + name := + solutionMethod = 'radical => '"radicalSolve" + '"solve" + bcFinish(name,eqnString,varString,accString) + +bcLinearSolveMatrix(htPage,junk) == + bcReadMatrix 'bcLinearSolveMatrix1 + +bcLinearSolveMatrix1 htPage == + page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) + htpSetProperty(page,'matrix,bcLinearExtractMatrix htPage) + htMakePage '( + (text . "The right side vector B is:") + (lispLinks + ("Zero:" "the system is homogeneous" bcLinearSolveMatrixHomo homo) + ("Not zero:" "the system is not homogeneous" bcLinearSolveMatrixInhomo nothomo))) + htShowPage() + +bcLinearExtractMatrix htPage == REVERSE htpInputAreaAlist htPage + +bcLinearSolveMatrixInhomo(htPage,junk) == + nrows := htpProperty(htPage,'nrows) + ncols := htpProperty(htPage,'ncols) + labelList := + [f(i) for i in 1..ncols] where f(i) == + spacer := (i > 99 => 0; i > 9 => 1; 2) + prefix := STRCONC('"{\em Coefficient ",STRINGIMAGE i,'":}") + if spacer ^= 0 then + prefix := STRCONC(prefix,'"\space{",STRINGIMAGE spacer,'"}") + name := INTERN STRCONC('"c",STRINGIMAGE i) + [prefix,"",30, 0,name, 'P] + page := htInitPage('"Linear Solve Basic Command",htpPropertyList htPage) + htpSetProperty(page,'matrix,htpProperty(htPage,'matrix)) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'ncols,ncols) + htMakePage [ + '(domainConditions (isDomain P (Polynomial $EmptyMode))), + '(text . "Enter the right side vector B:"), + ['inputStrings, :labelList], + '(text . "\vspace{1}\newline Do you want:" ), + '(lispLinks + ("All the solutions?" "" bcLinearSolveMatrixInhomoGen all) + ("A particular solution?" "" bcLinearSolveMatrixInhomoGen particular))] + htShowPage() + +bcLinearSolveMatrixInhomoGen(htPage,key) == bcLinearMatrixGen(htPage,key) + +bcLinearSolveMatrixHomo(htPage,key) == bcLinearMatrixGen(htPage,'homo) + +bcLinearMatrixGen(htPage,key) == + matform := bcMatrixGen htPage + key = 'homo => bcFinish('"nullSpace",matform) + vector := [x.1 for x in REVERSE htpInputAreaAlist htPage] + vecform := bcVectorGen vector + form := bcMkFunction('"solve",matform,[vecform]) + bcGen + key = 'particular => STRCONC(form,'".particular") + form + +linearFinalRequest(nhh,mat,vect) == + sayBrightly '"Do you want more information on the meaning of the output" + sayBrightly '" (1) no " + sayBrightly '" (2) yes " + tt := bcQueryInteger(1,2,true) + tt=1 => sayBrightly '"Bye Bye" + tt=2 => explainLinear(nhh) + +explainLinear(flag) == + flag="notHomogeneous" => + '("solve returns a particular solution and a basis for" + "the vector space of solutions for the homogeneous part." + "The particular solution is _"failed_" if one cannot be found.") + flag= "homogeneous" => + '("solve returns a basis for" + "the vector space of solutions for the homogeneous part") + systemError nil + +finalExactRequest(equations,unknowns) == + sayBrightly '"Do you like:" + sayBrightly '" (1) the solutions how they are displayed" + sayBrightly '" (2) to get ????" + sayBrightly '" (3) more information on the meaning of the output" + tt := bcQueryInteger(1,3,true) + tt=1 => sayBrightly '"Bye Bye" + tt=2 => moreExactSolution(equations,unknowns,flag) + tt=3 => explainExact(equations,unknowns) + +bcLinearSolveEqnsGen htPage == + alist := htpInputAreaAlist htPage + if vars := htpLabelInputString(htPage,'unknowns) then + varlist := bcString2WordList vars + varString := (rest varlist => bcwords2liststring varlist; first varlist) + alist := rest alist --know these are first on the list + eqnString := bcGenEquations alist + bcFinish('"solve",eqnString,varString) + +bcGenEquations alist == + y := alist + while y repeat + right := (first y).1 + y := rest y + left := (first y).1 + y := rest y + eqnlist := [STRCONC(left,'" = ",right),:eqnlist] + rest eqnlist => bcwords2liststring eqnlist + first eqnlist + + + + + + + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/bc-util.boot b/src/interp/bc-util.boot deleted file mode 100644 index 211f7cf0..00000000 --- a/src/interp/bc-util.boot +++ /dev/null @@ -1,125 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -bcFinish(name,arg,:args) == bcGen bcMkFunction(name,arg,args) - -bcMkFunction(name,arg,args) == - args := [x for x in args | x] - STRCONC(name,'"(",arg,"STRCONC"/[STRCONC('",", x) for x in args],'")") - -bcString2HyString2 s == - (STRINGP s) and (s.0 = char '_") => - len := #s - STRCONC('"\_"", SUBSTRING(s, 1, len-2), '"\_"") - s - -bcString2HyString s == s - -bcFindString(s,i,n,char) == or/[j for j in i..n | s.j = char] - -bcGen command == - htInitPage('"Basic Command",nil) - string := - #command < 50 => STRCONC('"{\centerline{\tt ",command,'" }}") - STRCONC('"{\tt ",command,'" }") - htMakePage [ - '(text - "{Here is the AXIOM command you could have issued to compute this result:}" - "\vspace{2}\newline "), - ['text,:string]] - htMakeDoitButton('"Do It", command) - htShowPage() - --- bcGen for axiom - nag link -linkGen command == - htInitPage('"AXIOM-Nag Link Command",nil) - string := - #command < 50 => STRCONC('"{\centerline{ ",command,'" }}") - command - htMakePage [ - '(text - "\centerline{{\em Here is the AXIOM command}}" - "\centerline{{\em you could have issued to compute this result:}}" - "\vspace{2}\newline "), - ['text,:string]] - htMakeDoitButton('"Do It", command) - htShowPage() - -bcOptional s == - s = '"" => '"2" - s - -bcvspace() == bcHt '"\vspace{1}\newline " - -bcString2WordList s == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => nil - k := or/[j for j in i..n | s.j ^= char '_ ] - null INTEGERP k => nil - l := bcFindString(s,k + 1,n,char '_ ) - null INTEGERP l => [SUBSTRING(s,k,nil)] - [SUBSTRING(s,k,l-k),:fn(s,l + 1,n)] - - -bcwords2liststring u == - null u => nil - STRCONC('"[",first u,fn rest u) where - fn(u) == - null u => '"]" - STRCONC('", ",first u,fn rest u) - -bcVectorGen vec == bcwords2liststring vec - -bcError string == - sayBrightlyNT '"NOTE: " - sayBrightly string - -bcDrawIt(ind,a,b) == STRCONC(ind,'"=",a,'"..",b) - -bcNotReady htPage == - htInitPage('"Basic Command",nil) - htMakePage '( - (text . - "{\centerline{\em This facility will soon be available}}")) - htShowPage() - -htStringPad(n,w) == - s := STRINGIMAGE n - ws := #s - STRCONC('"\space{",STRINGIMAGE (w - ws + 1),'"}",s) - -stringList2String x == - null x => '"()" - STRCONC('"(",first x,"STRCONC"/[STRCONC('",",y) for y in rest x],'")") - -htMkName(s,n) == STRCONC(s,STRINGIMAGE n) - diff --git a/src/interp/bc-util.boot.pamphlet b/src/interp/bc-util.boot.pamphlet new file mode 100644 index 00000000..56287145 --- /dev/null +++ b/src/interp/bc-util.boot.pamphlet @@ -0,0 +1,147 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp bc-util.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +bcFinish(name,arg,:args) == bcGen bcMkFunction(name,arg,args) + +bcMkFunction(name,arg,args) == + args := [x for x in args | x] + STRCONC(name,'"(",arg,"STRCONC"/[STRCONC('",", x) for x in args],'")") + +bcString2HyString2 s == + (STRINGP s) and (s.0 = char '_") => + len := #s + STRCONC('"\_"", SUBSTRING(s, 1, len-2), '"\_"") + s + +bcString2HyString s == s + +bcFindString(s,i,n,char) == or/[j for j in i..n | s.j = char] + +bcGen command == + htInitPage('"Basic Command",nil) + string := + #command < 50 => STRCONC('"{\centerline{\tt ",command,'" }}") + STRCONC('"{\tt ",command,'" }") + htMakePage [ + '(text + "{Here is the AXIOM command you could have issued to compute this result:}" + "\vspace{2}\newline "), + ['text,:string]] + htMakeDoitButton('"Do It", command) + htShowPage() + +-- bcGen for axiom - nag link +linkGen command == + htInitPage('"AXIOM-Nag Link Command",nil) + string := + #command < 50 => STRCONC('"{\centerline{ ",command,'" }}") + command + htMakePage [ + '(text + "\centerline{{\em Here is the AXIOM command}}" + "\centerline{{\em you could have issued to compute this result:}}" + "\vspace{2}\newline "), + ['text,:string]] + htMakeDoitButton('"Do It", command) + htShowPage() + +bcOptional s == + s = '"" => '"2" + s + +bcvspace() == bcHt '"\vspace{1}\newline " + +bcString2WordList s == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => nil + k := or/[j for j in i..n | s.j ^= char '_ ] + null INTEGERP k => nil + l := bcFindString(s,k + 1,n,char '_ ) + null INTEGERP l => [SUBSTRING(s,k,nil)] + [SUBSTRING(s,k,l-k),:fn(s,l + 1,n)] + + +bcwords2liststring u == + null u => nil + STRCONC('"[",first u,fn rest u) where + fn(u) == + null u => '"]" + STRCONC('", ",first u,fn rest u) + +bcVectorGen vec == bcwords2liststring vec + +bcError string == + sayBrightlyNT '"NOTE: " + sayBrightly string + +bcDrawIt(ind,a,b) == STRCONC(ind,'"=",a,'"..",b) + +bcNotReady htPage == + htInitPage('"Basic Command",nil) + htMakePage '( + (text . + "{\centerline{\em This facility will soon be available}}")) + htShowPage() + +htStringPad(n,w) == + s := STRINGIMAGE n + ws := #s + STRCONC('"\space{",STRINGIMAGE (w - ws + 1),'"}",s) + +stringList2String x == + null x => '"()" + STRCONC('"(",first x,"STRCONC"/[STRCONC('",",y) for y in rest x],'")") + +htMkName(s,n) == STRCONC(s,STRINGIMAGE n) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot deleted file mode 100644 index 6add1a9a..00000000 --- a/src/interp/br-con.boot +++ /dev/null @@ -1,1381 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-con.boot <================================ - ---======================================================================= --- Pages Initiated from HyperDoc Pages ---======================================================================= ---NOTE: This duplicate version was discovered 3/20/94 in br-search.boot ---called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon ---conPage(a,:b) == --- --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) --- $conArgstrings: local := --- atom a => b --- a := conform2OutputForm a --- [mathform2HtString x for x in rest a] --- if not atom a then a := first a --- da := DOWNCASE a --- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => --- downlink pageName --special jump out for primitive domains --- line := conPageFastPath a => kPage line --lower case name of cons? --- line := conPageFastPath UPCASE a => kPage line --upper case an abbr? --- ySearch a --slow search (include default packages) --- - ---called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon -conPage(a,:b) == - --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) - form := - atom a => [a,:b] - a - $conArgstrings: local := [form2HtString x for x in KDR a] - if not atom a then a := first a - da := DOWNCASE a - pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => - downlink pageName --special jump out for primitive domains - line := conPageFastPath da => kPage(line,form) --lower case name of cons? - line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr? - ySearch a --slow search (include default packages) - -conPageFastPath x == --called by conPage and constructorSearch ---gets line quickly for constructor name or abbreviation - s := STRINGIMAGE x - charPosition(char '_*,s,0) < #s => nil --quit if name has * in it - name := (STRINGP x => INTERN x; x) - entry := HGET($lowerCaseConTb,name) or return nil - lineNumber := LASSQ('dbLineNumber,CDDR entry) => - --'dbLineNumbers property is set by function dbAugmentConstructorDataTable - dbRead lineNumber --read record for constructor from libdb.text - conPageConEntry first entry - -conPageConEntry entry == - $conname: local := nil - $conform: local := nil - $exposed?:local := nil - $doc: local := nil - $kind: local := nil - buildLibdbConEntry entry - ---======================================================================= --- Constructor Page ---======================================================================= --- in br-saturn.boot now ---% kPage(line,:options) == --any cat, dom, package, default package ---% --constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) ---% ------------------> BRANCH OUT FOR SATURN ---% true => kPageSaturn(line,options) ---% parts := dbXParts(line,7,1) ---% [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts ---% form := IFCAR options ---% isFile := null kind ---% kind := kind or '"package" ---% RPLACA(parts,kind) ---% conform := mkConform(kind,name,args) ---% conname := opOf conform ---% capitalKind := capitalize kind ---% signature := ncParseFromString sig ---% sourceFileName := dbSourceFile INTERN name ---% constrings := ---% KDR form => dbConformGenUnder form ---% [STRCONC(name,args)] ---% emString := ['"{\sf ",:constrings,'"}"] ---% heading := [capitalKind,'" ",:emString] ---% if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] ---% if name=abbrev then abbrev := asyAbbreviation(conname,nargs) ---% page := htInitPage(heading,nil) ---% htpSetProperty(page,'isFile,true) ---% htpSetProperty(page,'parts,parts) ---% htpSetProperty(page,'heading,heading) ---% htpSetProperty(page,'kind,kind) ---% if asharpConstructorName? conname then ---% htpSetProperty(page,'isAsharpConstructor,true) ---% htpSetProperty(page,'conform,conform) ---% htpSetProperty(page,'signature,signature) ---% kdPageInfo(name,abbrev,nargs,conform,signature,isFile) ---% htSayStandard '"\newline" ---% htBeginMenu(3) ---% htSayStandard '"\item " ---% htMakePage [['bcLinks,['"\menuitemstyle{Description}", ---% [['text,'"\tab{19}",'"General description"]],'kiPage,nil]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Operations}", ---% [['text,'"\tab{19}All exported operations"]],'koPage,'"operation"]]] ---% if not asharpConstructorName? conname then ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Attributes}", ---% [['text,'"\tab{19}All exported attributes"]],'koPage,'"attribute"]]] ---% if kind ^= 'category and (pathname := dbHasExamplePage conname) then ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Examples}", ---% [['text,'"\tab{19}Examples illustrating use"]],'kxPage,pathname]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Exports}", ---% [['text,'"\tab{19}Explicit categories and operations"]],'kePage,nil]]] ---% satBreak() ---% htMakePage [['bcLinks,['"\menuitemstyle{Cross Reference}", ---% [['text,'"\tab{19}Hierarchy and usage information"]],'kcPage,nil]]] ---% htEndMenu(3) ---% if kind ^= 'category and nargs > 0 then addParameterTemplates conform ---% htShowPage() ---% -conform2String u == - x := form2String u - atom x => STRINGIMAGE x - "STRCONC"/[STRINGIMAGE y for y in x] - -kxPage(htPage,name) == downlink name - -kdPageInfo(name,abbrev,nargs,conform,signature,file?) == - htSay("{\sf ",name,'"}") - if abbrev ^= name then bcHt [" has abbreviation ",abbrev] - if file? then bcHt ['" is a source file."] - if nargs = 0 then (if abbrev ^= name then bcHt '".") - else - if abbrev ^= name then bcHt '" and" - bcHt - nargs = 1 => '" takes one argument:" - [" takes ",STRINGIMAGE nargs," arguments:"] - htSaturnBreak() - htSayStandard '"\indentrel{2}" - if nargs > 0 then kPageArgs(conform,signature) - htSayStandard '"\indentrel{-2}" - if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) ---sourceFileName := dbSourceFile INTERN name - sourceFileName := GETDATABASE(INTERN name,'SOURCEFILE) - filename := extractFileNameFromPath sourceFileName - if filename ^= '"" then - htSayStandard '"\newline{}" - htSay('"The source code for the constructor is found in ") - htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", - sourceFileName, '" ", name, '"}"]] - if nargs ^= 0 then htSay '"." - htSaturnBreak() - -kPageArgs([op,:args],[.,.,:source]) == -------------------> OBSELETE - firstTime := true - coSig := rest GETDATABASE(op,'COSIG) - for x in args for t in source for pred in coSig repeat - if not firstTime then htSay '", and" - htSay('"\newline ") - typeForm := (t is [":",.,t1] => t1; t) - if pred = true - then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] - else htSay('"{\em ",x,'"}") - htSay( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") - htSay - pred => '"a domain of category " - '"an element of the domain " - bcConform(typeForm,true) - -kArgPage(htPage,arg) == - [op,:args] := conform := htpProperty(htPage,'conform) - domname := htpProperty(htPage,'domname) - heading := htpProperty(htPage,'heading) - source := CDDAR getConstructorModemap op - n := position(arg,args) - typeForm := sublisFormal(args,source . n) - domTypeForm := mkDomTypeForm(typeForm,conform,domname) - descendants := domainDescendantsOf(typeForm,domTypeForm) - htpSetProperty(htPage,'cAlist,descendants) - rank := - n > 4 => nil - ('(First Second Third Fourth Fifth)).n - htpSetProperty(htPage,'rank,rank) - htpSetProperty(htPage,'thing,'"argument") ---htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) - dbShowCons(htPage,'names) - -reportCategory(conform,typeForm,arg) == - htSay('"Argument {\em ",arg,'"}") - [conlist,attrlist,:oplist] := categoryParts(conform,typeForm,true) - htSay '" must " - if conlist then - htSay '"belong to " - if conlist is [u] then - htSay('"category ") - bcConform first u - bcPred rest u - else - htSay('"categories:") - bcConPredTable(conlist,opOf conform) - htSay '"\newline " - if attrlist then - if conlist then htSay '" and " - reportAO('"attribute",attrlist) - htSay '"\newline " - if oplist then - if conlist or attrlist then htSay '" and " - reportAO('"operation",oplist) - -reportAO(kind,oplist) == - htSay('"have ",kind,'":") - for [op,sig,:pred] in oplist repeat - htSay '"\newline " - if #oplist = 1 then htSay '"\centerline{" - if kind = '"attribute" then - attr := form2String [op,:sig] - satDownLink(attr,['"(|attrPage| '|",attr,'"|)"]) - else - ops := escapeSpecialChars STRINGIMAGE op - sigs := form2HtString ['Mapping,:sig] - satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) - htSay '": " - bcConform ['Mapping,:sig] - if #oplist = 1 then htSay '"}" - htSay '"\newline " - -mkDomTypeForm(typeForm,conform,domname) == --called by kargPage - domname => SUBLISLIS(rest domname,rest conform,typeForm) - typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] - null hasIdent typeForm => typeForm - nil - -domainDescendantsOf(conform,domform) == main where --called by kargPage - main == - conform is [op,:r] => - op = 'Join => jfn(delete('(Type Object),r),delete('(Type Object),IFCDR domform)) - op = 'CATEGORY => nil - domainsOf(conform,domform) - domainsOf(conform,domform) - jfn([y,:r],domlist) == --keep only those domains that appear in ALL parts of Join - alist := domainsOf(y,IFCAR domlist) - for x in r repeat - domlist := IFCDR domlist - x is ['CATEGORY,.,:r] => alist := catScreen(r,alist) - keepList := nil - for [item,:pred] in domainsOf(x,IFCAR domlist) repeat - u := ASSOC(item,alist) => - keepList := [[item,:quickAnd(CDR u,pred)],:keepList] - alist := keepList - for pair in alist repeat RPLACD(pair,simpHasPred CDR pair) - listSort(function GLESSEQP, alist) - catScreen(r,alist) == - for x in r repeat - x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x - alist := [[item,:npred] for [item,:pred] in alist | - (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))] - alist - ---======================================================================= --- Branches of Constructor Page ---======================================================================= - -kiPage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conform := mkConform(kind,name,args) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] - page := htInitPage(heading,htCopyProplist htPage) - $conformsAreDomains := domname - dbShowConsDoc1(htPage,conform,nil) - htShowPage() - -kePage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - constring := STRCONC(name,args) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - htpSetProperty(htPage,'domname,domname) - $conformsAreDomains: local := domname - conform := mkConform(kind,name,args) - conname := opOf conform - heading := [capitalize kind,'" {\sf ", - (domname => form2HtString(domname,nil,true); constring),'"}"] - data := sublisFormal(IFCDR domname or rest conform, - getConstructorExports((domname or conform),true)) - [conlist,attrlist,:oplist] := data - if domname then - for x in conlist repeat RPLAC(CDR x,simpHasPred CDR x) - for x in attrlist repeat RPLAC(CDDR x,simpHasPred CDDR x) - for x in oplist repeat RPLAC(CDDR x,simpHasPred CDDR x) - prefix := pluralSay(#conlist + #attrlist + #oplist,'"Export",'"Exports") - page := htInitPage([:prefix,'" of ",:heading],htCopyProplist htPage) - htSayStandard '"\beginmenu " - htpSetProperty(page,'data,data) - if conlist then - htMakePage [['bcLinks,[menuButton(),'"",'dbShowCons1,conlist,'names]]] - htSayStandard '"\tab{2}" - htSay '"All attributes and operations from:" - bcConPredTable(conlist,opOf conform,rest conform) - if attrlist then - if conlist then htBigSkip() - kePageDisplay(page,'"attribute",kePageOpAlist attrlist) - if oplist then - if conlist or attrlist then htBigSkip() - kePageDisplay(page,'"operation",kePageOpAlist oplist) - htSayStandard '" \endmenu " - htShowPage() - -kePageOpAlist oplist == - opAlist := nil - for [op,sig,:pred] in oplist repeat - u := LASSOC(op,opAlist) ---was --- opAlist := insertAlist(op,[[sig,pred],:u],opAlist) - opAlist := insertAlist(zeroOneConvert op,[[sig,pred],:u],opAlist) - opAlist - -kePageDisplay(htPage,which,opAlist) == - count := #opAlist - total := +/[#(rest entry) for entry in opAlist] - count = 0 => nil - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'lists) --mark as unexpanded - htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,'names]]] - htSayStandard '"\tab{2}" - if count ^= total then - if count = 1 - then htSay('"1 name for ") - else htSay(STRINGIMAGE count,'" names for ") - if total > 1 - then htSay(STRINGIMAGE total,'" ",pluralize which,'" are explicitly exported:") - else htSay('"1 ",which,'" is explicitly exported:") - htSaySaturn '"\\" - data := dbGatherData(htPage,opAlist,which,'names) - dbShowOpItems(which,data,false) - -ksPage(htPage,junk) == - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - if domname then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - domain := (kind = '"category" => nil; EVAL domname) - conform:= htpProperty(htPage,'conform) - page := htInitPageNoScroll(htCopyProplist htPage, - ['"Search order for ",:heading]) - htSay '"When an operation is not defined by the domain, the following domains are searched in order for a _"default definition" - htSayStandard '"\beginscroll " - u := dbSearchOrder(conform,domname,domain) - htpSetProperty(htPage,'cAlist,u) - htpSetProperty(htPage,'thing,'"constructor") - dbShowCons(htPage,'names) - -dbSearchOrder(conform,domname,$domain) == --domain = nil or set to live domain - conform := domname or conform - name:= opOf conform - $infovec: local := dbInfovec name or return nil --exit for categories - u := $infovec.3 - $predvec:= - $domain => $domain . 3 - GETDATABASE(name,'PREDICATES) - catpredvec := CAR u - catinfo := CADR u - catvec := CADDR u - catforms := [[pakform,:pred] for i in 0..MAXINDEX catvec | test ] where - test == - pred := simpCatPredicate - p:=SUBLISLIS(rest conform,$FormalMapVariableList,kTestPred catpredvec.i) - $domain => EVAL p - p - if domname and CONTAINED('$,pred) then pred := SUBST(domname,'$,pred) --- which = '"attribute" => pred --all categories - (pak := catinfo . i) and pred --only those with default packages - pakform == - pak and not IDENTP pak => devaluate pak --in case it has been instantiated - catform := kFormatSlotDomain catvec . i --- which = '"attribute" => dbSubConform(rest conform,catform) - res := dbSubConform(rest conform,[pak,"$",:rest catform]) - if domname then res := SUBST(domname,'$,res) - res - [:dbAddChain conform,:catforms] - -kcPage(htPage,junk) == - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) --- domain := (kind = '"category" => nil; EVAL domname) - conform := htpProperty(htPage,'conform) - conname := opOf conform - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - page := htInitPage(['"Cross Reference for ",:heading],htCopyProplist htPage) - if domname then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - if kind = '"category" and dbpHasDefaultCategory? xpart then - htSay '"This category has default package " - bcCon(STRCONC(name,char '_&),'"") - htSayStandard '"\newline" - htBeginMenu(3) - htSayStandard '"\item " - message := - kind = '"category" => ['"Categories it directly extends"] - ['"Categories the ",(kind = '"default package" => '"package"; kind),'" belongs to by assertion"] - htMakePage [['bcLinks,['"\menuitemstyle{Parents}", - [['text,'"\tab{12}",:message]],'kcpPage,nil]]] - satBreak() - message := - kind = '"category" => ['"All categories it is an extension of"] - ['"All categories the ",kind,'" belongs to"] - htMakePage [['bcLinks,['"\menuitemstyle{Ancestors}", - [['text,'"\tab{12}",:message]],'kcaPage,nil]]] - if kind = '"category" then - satBreak() - htMakePage [['bcLinks,['"\menuitemstyle{Children}",[['text,'"\tab{12}", - '"Categories which directly extend this category"]],'kccPage,nil]]] - - satBreak() - htMakePage [['bcLinks,['"\menuitemstyle{Descendants}",[['text,'"\tab{12}", - '"All categories which extend this category"]],'kcdPage,nil]]] - if not asharpConstructorName? conname then - satBreak() - message := '"Constructors mentioning this as an argument type" - htMakePage [['bcLinks,['"\menuitemstyle{Dependents}", - [['text,'"\tab{12}",message]],'kcdePage,nil]]] - if not asharpConstructorName? conname and kind ^= '"category" then - satBreak() - htMakePage [['bcLinks,['"\menuitemstyle{Lineage}", - '"\tab{12}Constructor hierarchy used for operation lookup",'ksPage,nil]]] - if not asharpConstructorName? conname then - if kind = '"category" then - satBreak() - htMakePage [['bcLinks,['"\menuitemstyle{Domains}",[['text,'"\tab{12}", - '"All domains which are of this category"]],'kcdoPage,nil]]] - if kind ^= '"category" then - satBreak() - htMakePage [['bcLinks,['"\menuitemstyle{Clients}",'"\tab{12}Constructors",'kcuPage,nil]]] - if HGET($defaultPackageNamesHT,conname) - then htSay('" which {\em may use} this default package") --- htMakePage [['bcLinks,['"files",'"",'kcuPage,true]]] - else htSay('" which {\em use} this ",kind) - if kind ^= '"category" or dbpHasDefaultCategory? xpart then - satBreak() - message := - kind = '"category" => ['"Constructors {\em used by} its default package"] - ['"Constructors {\em used by} the ",kind] - htMakePage [['bcLinks,['"\menuitemstyle{Benefactors}", - [['text,'"\tab{12}",:message]],'kcnPage,nil]]] - --to remove "Capsule Information", comment out the next 5 lines - if not asharpConstructorName? conname and hasNewInfoAlist conname then - satBreak() - message := ['"Cross reference for capsule implementation"] - htMakePage [['bcLinks,['"\menuitemstyle{CapsuleInfo}", - [['text,'"\tab{12}",:message]],'kciPage,nil]]] - htEndMenu(3) - htShowPage() - -kcpPage(htPage,junk) == - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - if domname then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - conform := htpProperty(htPage,'conform) - conname := opOf conform - page := htInitPage(['"Parents of ",:heading],htCopyProplist htPage) - parents := parentsOf conname --was listSort(function GLESSEQP, =this) - if domname then parents := SUBLISLIS(rest domname,rest conform,parents) - htpSetProperty(htPage,'cAlist,parents) - htpSetProperty(htPage,'thing,'"parent") - choice := - domname => 'parameters - 'names - dbShowCons(htPage,choice) - -reduceAlistForDomain(alist,domform,conform) == --called from kccPage - alist := SUBLISLIS(rest domform,rest conform,alist) - for pair in alist repeat RPLACD(pair,simpHasPred(CDR pair,domform)) - [pair for (pair := [.,:pred]) in alist | pred] - -kcaPage(htPage,junk) == - kcaPage1(htPage,'"category",'" an ",'"ancestor",function ancestorsOf, false) - -kcdPage(htPage,junk) == - kcaPage1(htPage,'"category",'" a ",'"descendant",function descendantsOf,true) - -kcdoPage(htPage,junk)== - kcaPage1(htPage,'"domain",'" a ",'"descendant",function domainsOf, false) - -kcaPage1(htPage,kind,article,whichever,fn, isCatDescendants?) == - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - if domname and not isCatDescendants? then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - conform := htpProperty(htPage,'conform) - conname := opOf conform - ancestors := FUNCALL(fn, conform, domname) - if whichever ^= '"ancestor" then - ancestors := augmentHasArgs(ancestors,conform) - ancestors := listSort(function GLESSEQP,ancestors) ---if domname then ancestors := SUBST(domname,'$,ancestors) - htpSetProperty(htPage,'cAlist,ancestors) - htpSetProperty(htPage,'thing,whichever) - choice := --- domname => 'parameters - 'names - dbShowCons(htPage,choice) - -kccPage(htPage,junk) == - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - if domname then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - conform := htpProperty(htPage,'conform) - conname := opOf conform - page := htInitPage(['"Children of ",:heading],htCopyProplist htPage) - children:= augmentHasArgs(childrenOf conform,conform) - if domname then children := reduceAlistForDomain(children,domname,conform) - htpSetProperty(htPage,'cAlist,children) - htpSetProperty(htPage,'thing,'"child") - dbShowCons(htPage,'names) - -augmentHasArgs(alist,conform) == - conname := opOf conform - args := KDR conform or return alist - n := #args - [[name,:pred] for [name,:p] in alist] where pred == - extractHasArgs p is [a,:b] => p - quickAnd(p,['hasArgs,:TAKE(n,KDR getConstructorForm opOf name)]) - -kcdePage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conname := INTERN name - constring := STRCONC(name,args) - conform := - kind ^= '"default package" => ncParseFromString constring - [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & - pakname := --- kind = '"category" => INTERN STRCONC(name,char '_&) - opOf conform - domList := getDependentsOfConstructor pakname - cAlist := [[getConstructorForm x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"dependent") - dbShowCons(htPage,'names) - -kcuPage(htPage,junk) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - conname := INTERN name - constring := STRCONC(name,args) - conform := - kind ^= '"default package" => ncParseFromString constring - [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & - pakname := - kind = '"category" => INTERN STRCONC(name,char '_&) - opOf conform - domList := getUsersOfConstructor pakname - cAlist := [[getConstructorForm x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"user") - dbShowCons(htPage,'names) - -kcnPage(htPage,junk) == ---if reached by a category, that category has a default package - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - domname := kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - heading := - null domname => htpProperty(htPage,'heading) - ['"{\sf ",form2HtString(domname,nil,true),'"}"] - if domname then - htpSetProperty(htPage,'domname,domname) - htpSetProperty(htPage,'heading,heading) - conform:= htpProperty(htPage,'conform) - pakname := - kind = '"category" => INTERN STRCONC(PNAME conname,char '_&) - opOf conform - domList := getImports pakname - if domname then - domList := SUBLISLIS([domname,:rest domname],['$,:rest conform],domList) - cAlist := [[x,:true] for x in domList] - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"benefactor") - dbShowCons(htPage,'names) - -koPageInputAreaUnchanged?(htPage, nargs) == - [htpLabelInputString(htPage,INTERN STRCONC('"*",STRINGIMAGE i)) for i in 1..nargs] - = htpProperty(htPage,'inputAreaList) - -kDomainName(htPage,kind,name,nargs) == - htpSetProperty(htPage,'domname,nil) - inputAreaList := - [htpLabelInputString(htPage,var) for i in 1..nargs for var in $PatternVariableList] - htpSetProperty(htPage,'inputAreaList,inputAreaList) - conname := INTERN name - args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList - for domain? in rest GETDATABASE(conname,'COSIG)] - or/[null x for x in args] => - (n := +/[1 for x in args | x]) > 0 => - ['error,nil,'"\centerline{You gave values for only {\em ",n,'" } of the {\em ",#args,'"}}",'"\centerline{parameters of {\sf ",name,'"}}\vspace{1}\centerline{Please enter either {\em all} or {\em none} of the type parameters}"] - nil - argString := - null args => '"()" - argTailPart := - "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] - "STRCONC"/['"(",:first args,argTailPart,'")"] - typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or - ['error,'invalidType,STRCONC(name,argString)] - null (evaluatedTypeForm := kisValidType typeForm) => - ['error,'invalidType,STRCONC(name,argString)] - dbMkEvalable evaluatedTypeForm - -kArgumentCheck(domain?,s) == - s = '"" => nil - domain? and (form := conSpecialString? s) => - null KDR form => [STRINGIMAGE opOf form] - form2String form - [s] - -dbMkEvalable form == ---like mkEvalable except that it does NOT quote domains ---does not do "loadIfNecessary" - [op,:.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) - kind = 'category => form - mkEvalable form - -topLevelInterpEval x == - $ProcessInteractiveValue: fluid := true - $noEvalTypeMsg: fluid := true - processInteractive(x,nil) - -kisValidType typeForm == - $ProcessInteractiveValue: fluid := true - $noEvalTypeMsg: fluid := true - CATCH('SPAD__READER, processInteractive(typeForm,nil)) - is [[h,:.],:t] and member(h,'(Domain SubDomain)) => - kCheckArgumentNumbers t and t - false - -kCheckArgumentNumbers t == - [conname,:args] := t - cosig := KDR GETDATABASE(conname,'COSIG) - #cosig ^= #args => false - and/[foo for domain? in cosig for x in args] where foo == - domain? => kCheckArgumentNumbers x - true - -parseNoMacroFromString(s) == - s := next(function ncloopParse, - next(function lineoftoks,incString s)) - StreamNull s => nil - pf2Sex first rest first s - - - -mkConform(kind,name,argString) == - kind ^= '"default package" => - form := STRCONC(name,argString) - parse := parseNoMacroFromString form - null parse => - sayBrightlyNT '"Won't parse: " - pp form - systemError '"Keywords in argument list?" - ATOM parse => [parse] - parse - [INTERN name,:rest ncParseFromString STRCONC(char 'd,argString)] --& case - ---======================================================================= --- Operation Page for a Domain Form from Scratch ---======================================================================= -conOpPage(htPage,conform) == - updown := dbCompositeWithMap htPage - updown = '"DOWN" => - domname := htpProperty(htPage,'domname) - conOpPage1(dbExtractUnderlyingDomain domname,[['updomain,:domname]]) - domname := htpProperty(htPage,'updomain) - conOpPage1(domname,nil) - -dbCompositeWithMap htPage == - htpProperty(htPage,'updomain) => '"UP" - domain := htpProperty(htPage,'domname) - null domain => false - opAlist := htpProperty(htPage,'opAlist) ---not LASSOC('map,opAlist) => false - dbExtractUnderlyingDomain htpProperty(htPage,'domname) => '"DOWN" - false - -dbExtractUnderlyingDomain domain == or/[x for x in KDR domain | isValidType x] - ---conform is atomic if no parameters, otherwise must be valid domain form -conOpPage1(conform,:options) == ---constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) - bindingsAlist := IFCAR options - conname := opOf conform - MEMQ(conname,$Primitives) => - dbSpecialOperations conname - domname := --> !!note!! <-- - null atom conform => conform - nil - line := conPageFastPath conname - [kind,name,nargs,xflag,sig,args,abbrev,comments]:=parts:= dbXParts(line,7,1) - isFile := null kind - kind := kind or '"package" - RPLACA(parts,kind) - constring := STRCONC(name,args) - conform := mkConform(kind,name,args) - capitalKind := capitalize kind - signature := ncParseFromString sig - sourceFileName := dbSourceFile INTERN name - emString := ['"{\sf ",constring,'"}"] - heading := [capitalKind,'" ",:emString] - if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] - page := htInitPage(heading,nil) - htpSetProperty(page,'isFile,true) - htpSetProperty(page,'fromConOpPage1,true) - htpSetProperty(page,'parts,parts) - htpSetProperty(page,'heading,heading) - htpSetProperty(page,'kind,kind) - htpSetProperty(page,'domname,domname) --> !!note!! <-- - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'signature,signature) - if selectedOperation := LASSOC('selectedOperation,IFCDR options) then - htpSetProperty(page,'selectedOperation,selectedOperation) - for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) - koPage(page,'"operation") - ---======================================================================= --- Operation Page from Main Page ---======================================================================= -koPage(htPage,which) == - [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) - constring := STRCONC(name,args) - conname := INTERN name - domname := - (u := htpProperty(htPage,'domname)) is [=conname,:.] - and (htpProperty(htPage,'fromConOpPage1) = true or - koPageInputAreaUnchanged?(htPage,nargs)) => u - kDomainName(htPage,kind,name,nargs) - domname is ['error,:.] => errorPage(htPage,domname) - htpSetProperty(htPage,'domname,domname) - headingString := - domname => form2HtString(domname,nil,true) - constring - heading := [capitalize kind,'" {\sf ",headingString,'"}"] - htpSetProperty(htPage,'which,which) - htpSetProperty(htPage,'heading,heading) - koPageAux(htPage,which,domname,heading) - -koPageFromKKPage(htPage,ao) == - koPageAux(htPage,ao,htpProperty(htPage,'domname),htpProperty(htPage,'heading)) - -koPageAux(htPage,which,domname,heading) == --from koPage, koPageFromKKPage - htpSetProperty(htPage,'which,which) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := htpProperty(htPage,'heading) - opAlist := - which = '"attribute" => koAttrs(conform,domname) - which = '"general operation" => koOps(conform,domname,true) - koOps(conform,domname) - if selectedOperation := htpProperty(htPage,'selectedOperation) then - opAlist := [ASSOC(selectedOperation,opAlist) or systemError()] - dbShowOperationsFromConform(htPage,which,opAlist) - -koPageAux1(htPage,opAlist) == - which := htpProperty(htPage,'which) - dbShowOperationsFromConform(htPage,which,opAlist) - -koaPageFilterByName(htPage,functionToCall) == - htpLabelInputString(htPage,'filter) = '"" => - koaPageFilterByCategory(htPage,functionToCall) - filter := pmTransFilter(dbGetInputString htPage) ---WARNING: this call should check for ['error,:.] returned - which := htpProperty(htPage,'which) - opAlist := - [x for x in htpProperty(htPage,'opAlist) | superMatch?(filter,DOWNCASE STRINGIMAGE first x)] - htpSetProperty(htPage,'opAlist,opAlist) - FUNCALL(functionToCall,htPage,nil) - ---======================================================================= --- Get Constructor Documentation ---======================================================================= - -dbConstructorDoc(conform,$op,$sig) == fn conform where - fn (conform := [conname,:$args]) == - or/[gn y for y in GETDATABASE(conname,'DOCUMENTATION)] - gn([op,:alist]) == - op = $op and or/[doc or '("") for [sig,:doc] in alist | hn sig] - hn sig == - #$sig = #sig and $sig = SUBLISLIS($args,$FormalMapVariableList,sig) - -dbDocTable conform == ---assumes $docTableHash bound --see dbExpandOpAlistIfNecessary - table := HGET($docTableHash,conform) => table - $docTable : local := MAKE_-HASHTABLE 'ID - --process in reverse order so that closest cover up farthest - for x in originsInOrder conform repeat dbAddDocTable x - dbAddDocTable conform - HPUT($docTableHash,conform,$docTable) - $docTable - -originsInOrder conform == --domain = nil or set to live domain ---from dcCats - [con,:argl] := conform - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => - ASSOCLEFT ancestorsOf(conform,nil) - acc := ASSOCLEFT parentsOf con - for x in acc repeat - for y in originsInOrder x repeat acc := insert(y,acc) - acc - -dbAddDocTable conform == - conname := opOf conform - storedArgs := rest getConstructorForm conname - for [op,:alist] in SUBLISLIS(["$",:rest conform], - ["%",:storedArgs],GETDATABASE(opOf conform,'DOCUMENTATION)) - repeat - op1 := - op = '(Zero) => 0 - op = '(One) => 1 - op - for [sig,doc] in alist repeat - HPUT($docTable,op1,[[conform,:alist],:HGET($docTable,op1)]) - --note opOf is needed!!! for some reason, One and Zero appear within prens - -dbGetDocTable(op,$sig,docTable,$which,aux) == main where ---docTable is [[origin,entry1,...,:code] ...] where --- each entry is [sig,doc] and code is NIL or else a topic code for op - main == - if null FIXP op and - DIGITP (s := STRINGIMAGE op).0 then op := string2Integer s - -- the above hack should be removed after 3/94 when 0 is not |0| - aux is [[packageName,:.],:pred] => - doc := dbConstructorDoc(first aux,$op,$sig) - origin := - pred => ['ifp,:aux] - first aux - [origin,:doc] - or/[gn x for x in HGET(docTable,op)] - gn u == --u is [origin,entry1,...,:code] - $conform := CAR u --origin - if ATOM $conform then $conform := [$conform] - code := LASTATOM u --optional topic code - comments := or/[p for entry in CDR u | p := hn entry] or return nil - [$conform,first comments,:code] - hn [sig,:doc] == - $which = '"attribute" => sig is ['attribute,: =$sig] and doc - pred := #$sig = #sig and - alteredSig := SUBLISLIS(KDR $conform,$FormalMapVariableList,sig) - alteredSig = $sig - pred => - doc => - doc is ['constant,:r] => r - doc - '("") - false - -kTestPred n == - n = 0 => true - $domain => testBitVector($predvec,n) - simpHasPred $predvec.(n - 1) - -dbAddChainDomain conform == - [name,:args] := conform - $infovec := dbInfovec name or return nil --exit for categories - template := $infovec . 0 - null (form := template . 5) => nil - dbSubConform(args,kFormatSlotDomain devaluate form) - -dbSubConform(args,u) == - atom u => - (n := position(u,$FormalMapVariableList)) >= 0 => args . n - u - u is ['local,y] => dbSubConform(args,y) - [dbSubConform(args,x) for x in u] - -dbAddChain conform == - u := dbAddChainDomain conform => - atom u => nil - [[u,:true],:dbAddChain u] - nil - ---======================================================================= --- Constructor Page Menu ---======================================================================= ----------> !OBSELETE! <------------- -dbPresentCons(htPage,kind,:exclusions) == -- calist is ((catform . pred)...) - $saturn => dbPresentConsSaturn(htPage,kind,exclusions) - htSay('"{\em Views:}") - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") - if empty? or member('names,exclusions) - then htSay '"{\em names}" - else htMakePage [['bcLispLinks,['"names",'"",'dbShowCons,'names]]] - htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") - if empty? or member('kinds,exclusions) or kind ^= 'constructor - then htSay '"{\em kinds}" - else htMakePage [['bcLispLinks,['"kinds",'"",'dbShowCons,'kinds]]] - htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") - if empty? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSay '"{\em parameters}" - else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowCons,'parameters]]] - if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") - if empty? or null CDR cAlist - then htSay '"{\em filter}" - else htMakePage [['bcLinks,['"filter",'"",'dbShowCons,'filter]]] - htMakePage [['bcStrings, [11,'"",'filter,'EM]]] - htSay('"\newline") - if exposedUnexposedFlag then - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"exposed",'" {\em only}",'dbShowCons,'exposureOff]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'dbShowCons,'exposureOn]]] - htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") - if empty? or member('abbrs,exclusions) - then htSay '"{\em abbrs}" - else htMakePage [['bcLispLinks,['"abbrs",'"",'dbShowCons,'abbrs]]] - htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") - if empty? or member('files,exclusions) - then htSay '"{\em files}" - else htMakePage [['bcLispLinks,['"files",'"",'dbShowCons,'files]]] - htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") - if empty? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSay '"{\em conditions}" - else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowCons,'conditions]]] - if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") - if empty? or member('documentation,exclusions) - then htSay '"{\em descriptions}" - else htMakePage [['bcLispLinks,['"descriptions",'"",'dbShowCons,'documentation]]] - -dbShowCons(htPage,key,:options) == - cAlist := htpProperty(htPage,'cAlist) - key = 'filter => - --if $saturn, IFCAR options is the filter string - filter := pmTransFilter(IFCAR options or dbGetInputString htPage) - filter is ['error,:.] => bcErrorPage filter - abbrev? := htpProperty(htPage,'exclusion) = 'abbrs - u := [x for x in cAlist | test] where test == - conname := CAAR x - subject := (abbrev? => constructor? conname; conname) - superMatch?(filter,DOWNCASE STRINGIMAGE subject) - null u => emptySearchPage('"constructor",filter) - htPage := htInitPageNoScroll(htCopyProplist htPage) - htpSetProperty(htPage,'cAlist,u) - dbShowCons(htPage,htpProperty(htPage,'exclusion)) - if MEMQ(key,'(exposureOn exposureOff)) then - $exposedOnlyIfTrue := - key = 'exposureOn => 'T - NIL - key := htpProperty(htPage,'exclusion) - dbShowCons1(htPage,cAlist,key) - -conPageChoose conname == - cAlist := [[getConstructorForm conname,:true]] - dbShowCons1(nil,cAlist,'names) - -dbShowCons1(htPage,cAlist,key) == - conlist := REMDUP [item for x in cAlist | pred] where - pred == - item := CAR x - $exposedOnlyIfTrue => isExposedConstructor opOf item - item ---$searchFirstTime and (conlist is [.]) => conPage first conlist ---$searchFirstTime := false - conlist is [.] => conPage - htPage and htpProperty(htPage,'domname) => first conlist - opOf first conlist - conlist := [opOf x for x in conlist] - kinds := "union"/[dbConstructorKind x for x in conlist] - kind := - kinds is [a] => a - 'constructor - proplist := - htPage => htCopyProplist htPage - nil - page := htInitPageNoScroll(proplist,dbConsHeading(htPage,conlist,key,kind)) - if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) - htSayStandard('"\beginscroll ") - htpSetProperty(page,'cAlist,cAlist) - $conformsAreDomains: local := htpProperty(page,'domname) - do - --key = 'catfilter => dbShowCatFilter(page,key) - key = 'names => bcNameConTable conlist - key = 'abbrs => - bcAbbTable [getCDTEntry(con,true) for con in conlist] - key = 'files => - flist := - [y for con in conlist | - y := (fn := GETDATABASE(con,'SOURCEFILE))] - bcUnixTable(listSort(function GLESSEQP,REMDUP flist)) - key = 'documentation => dbShowConsDoc(page,conlist) - if $exposedOnlyIfTrue then - cAlist := [x for x in cAlist | isExposedConstructor opOf CAR x] - key = 'conditions => dbShowConditions(page,cAlist,kind) - key = 'parameters => bcConTable REMDUP ASSOCLEFT cAlist - key = 'kinds => dbShowConsKinds cAlist - dbConsExposureMessage() - htSayStandard("\endscroll ") - dbPresentCons(page,kind,key) - htShowPageNoScroll() - - -dbConsExposureMessage() == - $atLeastOneUnexposed => - htSay '"\newline{}-------------\newline{}{\em *} = unexposed" - --- DUPLICATE DEF - ALSO in br-saturn.boot --- dbShowConsKinds cAlist == --- ---------> !OBSELETE! <------------- --- cats := doms := paks := defs := nil --- for x in cAlist repeat --- op := CAAR x --- kind := dbConstructorKind op --- kind = 'category => cats := [x,:cats] --- kind = 'domain => doms := [x,:doms] --- kind = 'package => paks:= [x,:paks] --- defs := [x,:defs] --- lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] --- htBeginMenu(2) --- htSayStandard '"\indent{1}" --- kinds := +/[1 for x in lists | #x > 0] --- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat --- htSay('"\item") --- if kinds = 1 then htSay menuButton() else --- htMakePage [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] --- htSayStandard '"\tab{1}" --- htSay '"{\em " --- htSay (c := #x) --- htSay '" " --- htSay (c > 1 => pluralize kind; kind) --- htSay '":}" --- bcConTable REMDUP [CAAR y for y in x] --- htEndMenu(2) --- htSay '"\indent{0}" - -dbShowConsKindsFilter(htPage,[kind,cAlist]) == - htpSetProperty(htPage,'cAlist,cAlist) - dbShowCons(htPage,htpProperty(htPage,'exclusion)) - -dbShowConsDoc(htPage,conlist) == - null rest conlist => dbShowConsDoc1(htPage,getConstructorForm opOf first conlist,nil) - cAlist := htpProperty(htPage,'cAlist) - --the following code is necessary to skip over duplicates on cAlist - index := 0 - for x in REMDUP conlist repeat - -- for x in conlist repeat - dbShowConsDoc1(htPage,getConstructorForm x,i) where i == - while CAAAR cAlist ^= x repeat - index := index + 1 - cAlist := rest cAlist - null cAlist => systemError () - index - -dbShowConsDoc1(htPage,conform,indexOrNil) == - [conname,:conargs] := conform - MEMQ(conname,$Primitives) => - conname := htpProperty(htPage,'conname) - [["constructor",["NIL",doc]],:.] := GETL(conname,'documentation) - sig := '((CATEGORY domain) (SetCategory) (SetCategory)) - displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,nil,nil) - exposeFlag := isExposedConstructor conname - doc := [getConstructorDocumentation conname] - signature := getConstructorSignature conname - sig := - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - SUBLISLIS(conargs,$TriangleVariableList,signature) - sublisFormal(conargs,signature) - htSaySaturn '"\begin{description}" - displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,null exposeFlag,nil) - htSaySaturn '"\end{description}" - --NOTE that we pass conform is as "origin" - -getConstructorDocumentation conname == - LASSOC('constructor,GETDATABASE(conname,'DOCUMENTATION)) - is [[nil,line,:.],:.] and line or '"" - -dbSelectCon(htPage,which,index) == - conPage opOf first htpProperty(htPage,'cAlist) . index - -dbShowConditions(htPage,cAlist,kind) == - conform := htpProperty(htPage,'conform) - conname := opOf conform - article := htpProperty(htPage,'article) - whichever := htpProperty(htPage,'whichever) - [consNoPred,:consPred] := splitConTable cAlist - singular := [kind,'" is"] - plural := [pluralize STRINGIMAGE kind,'" are"] - dbSayItems(#consNoPred,singular,plural,'" unconditional") - htSaySaturn '"\\" - bcConPredTable(consNoPred,conname) - htSayHrule() - dbSayItems(#consPred,singular,plural,'" conditional") - htSaySaturn '"\\" - bcConPredTable(consPred,conname) - -dbConsHeading(htPage,conlist,view,kind) == - thing := htPage and htpProperty(htPage,'thing) or '"constructor" - place := - htPage => htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - nil - count := #(REMDUP conlist) - -- count := #conlist - thing = '"benefactor" => - [STRINGIMAGE count,'" Constructors Used by ",form2HtString(place,nil,true)] - modifier := - thing = '"argument" => - rank := htPage and htpProperty(htPage,'rank) - ['" Possible ",rank,'" "] - kind = 'constructor => ['" "] - ['" ",capitalize STRINGIMAGE kind,'" "] --- count = 1 => --- ['"Select name or a {\em view} at the bottom"] - exposureWord := - $exposedOnlyIfTrue => '(" Exposed ") - nil - prefix := - count = 1 => [STRINGIMAGE count,:modifier,capitalize thing] - firstWord := (count = 0 => '"No "; STRINGIMAGE count) - [firstWord,:exposureWord, :modifier,capitalize pluralize thing] - placepart := - place => ['" of {\em ",form2HtString(place,nil,true),"}"] - nil - heading := [:prefix,:placepart] - connective := - member(view,'(abbrs files kinds)) => '" as " - '" with " - if count ^= 0 and member(view,'(abbrs files parameters conditions)) then heading:= [:heading,'" viewed",connective,'"{\em ",STRINGIMAGE view,'"}"] - heading - -dbShowConstructorLines lines == - cAlist := [[getConstructorForm intern dbName line,:true] for line in lines] - dbShowCons1(nil,listSort(function GLESSEQP,cAlist),'names) - -bcUnixTable(u) == - htSay '"\newline" - htBeginTable() - firstTime := true - for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - ft := - isAsharpFileName? x => '("AS") - '("SPAD") - filename := NAMESTRING $FINDFILE(STRINGIMAGE x, ft) - htMakePage [['text, '"\unixcommand{",PATHNAME_-NAME x, '"}{$AXIOM/lib/SPADEDIT ", filename, '"} "]] - htSay '"}" - htEndTable() - -isAsharpFileName? con == false - ---======================================================================= --- Special Code for Union, Mapping, and Record ---======================================================================= - -dbSpecialDescription(conname) == - conform := getConstructorForm conname - heading := ['"Description of Domain {\sf ",form2HtString conform,'"}"] - page := htInitPage(heading,nil) - htpSetProperty(page,'conname,conname) - $conformsAreDomains := nil - dbShowConsDoc1(page,conform,nil) - htShowPage() - -dbSpecialOperations(conname) == - page := htInitPage(nil,nil) - conform := getConstructorForm conname - opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) - fromHeading := ['" from domain {\sf ",form2HtString conform,'"}"] - htpSetProperty(page,'fromHeading,fromHeading) - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'opAlist,opAlist) - htpSetProperty(page,'noUsage,true) - htpSetProperty(page,'condition?,'no) - dbShowOp1(page,opAlist,'"operation",'names) - -dbSpecialExports(conname) == - conform := getConstructorForm conname - page := htInitPage(['"Exports of {\sf ",form2HtString conform,'"}"],nil) - opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) - kePageDisplay(page,'"operation",opAlist) - htShowPage() - -dbSpecialExpandIfNecessary(conform,opAlist) == - opAlist is [[op,[sig,:r],:.],:.] and rest r => opAlist - for [op,:u] in opAlist repeat - for pair in u repeat - [sig,comments] := pair - RPLACD(pair,['T,conform,'T,comments]) --[sig,pred,origin,exposeFg,doc] - opAlist - -X := '"{\sf Record(a:A,b:B)} is used to create the class of pairs of objects made up of a value of type {\em A} selected by the symbol {\em a} and a value of type {\em B} selected by the symbol {\em b}. " - -Y := '"In general, the {\sf Record} constructor can take any number of arguments and thus can be used to create aggregates of heterogeneous components of arbitrary size selectable by name. " - -Z := '"{\sf Record} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z) - -PUT('Record,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) _$ _$) - "\spad{r = s} tests for equality of two records \spad{r} and \spad{s}")) - (coerce (((OutputForm) _$) - "\spad{coerce(r)} returns an representation of \spad{r} as an output form") - ((_$ (List (Any))) - "\spad{coerce(u)}, where \spad{u} is the list \spad{[x,y]} for \spad{x} of type \spad{A} and \spad{y} of type \spad{B}, returns the record \spad{[a:x,b:y]}")) - (elt ((A $ "a") - "\spad{r . a} returns the value stored in record \spad{r} under selector \spad{a}.") - ((B $ "b") - "\spad{r . b} returns the value stored in record \spad{r} under selector \spad{b}.")) - (setelt ((A $ "a" A) - "\spad{r . a := x} destructively replaces the value stored in record \spad{r} under selector \spad{a} by the value of \spad{x}. Error: if \spad{r} has not been previously assigned a value.") - ((B $ "b" B) - "\spad{r . b := y} destructively replaces the value stored in record \spad{r} under selector \spad{b} by the value of \spad{y}. Error: if \spad{r} has not been previously assigned a value.")) - ))) - -X := '"{\sf Union(A,B)} denotes the class of objects which are which are either members of domain {\em A} or of domain {\em B}. The {\sf Union} constructor can take any number of arguments. " - -Y := '"For an alternate form of {\sf Union} with _"tags_", see \downlink{Union(a:A,b:B)}{DomainUnion}. {\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y) - -PUT('UntaggedUnion,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if two objects of the union are equal, that is, u and v are hold objects of same branch which are equal.")) - (case (((Boolean) $ "A") - "\spad{u case A} tests if \spad{u} is of the type \spad{A} branch of the union.") - (((Boolean) $ "B") - "\spad{u case B} tests if \spad{u} is of the \spad{B} branch of the union.")) - (coerce ((A $) - "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of the \spad{A} branch of the union. Error: if \spad{u} is of the \spad{B} branch of the union.") - ((B $) - "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of the \spad{B} branch of the union. Error: if \spad{u} is of the \spad{A} branch of the union.") - (($ A) - "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") - (($ B) - "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) - ))) - -X := '"{\sf Union(a:A,b:B)} denotes the class of objects which are either members of domain {\em A} or of domain {\em B}. " - -Y := '"The symbols {\em a} and {\em b} are called _"tags_" and are used to identify the two _"branches_" of the union. " - -Z := '"The {\sf Union} constructor can take any number of arguments and has an alternate form without {\em tags} (see \downlink{Union(A,B)}{UntaggedUnion}). " - -W := '"This tagged {\sf Union} type is necessary, for example, to disambiguate two branches of a union where {\em A} and {\em B} denote the same type. " - -A := '"{\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z,W,A) - -PUT('Union,'documentation,SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if two objects of the union are equal, that is, \spad{u} and \spad{v} are objects of same branch which are equal.")) - (case (((Boolean) $ "A") - "\spad{u case a} tests if \spad{u} is of branch \spad{a} of the union.") - (((Boolean) $ "B") - "\spad{u case b} tests if \spad{u} is of branch \spad{b} of the union.")) - (coerce ((A $) - "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of branch \spad{a} of the union. Error: if \spad{u} is of branch \spad{b} of the union.") - ((B $) - "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of branch \spad{b} branch of the union. Error: if \spad{u} is of the \spad{a} branch of the union.") - (($ A) - "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") - (($ B) - "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) - ))) - -X := '"{\sf Mapping(T,S,...)} denotes the class of objects which are mappings from a source domain ({\em S,...}) into a target domain {\em T}. The {\sf Mapping} constructor can take any number of arguments." - -Y := '" All but the first argument is regarded as part of a source tuple for the mapping. For example, {\sf Mapping(T,A,B)} denotes the class of mappings from {\em (A,B)} into {\em T}. " - -Z := '"{\sf Mapping} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." - -MESSAGE := STRCONC(X,Y,Z) - -PUT('Mapping,'documentation, SUBST(MESSAGE,'MESSAGE,'( - (constructor (NIL MESSAGE)) - (_= (((Boolean) $ $) - "\spad{u = v} tests if mapping objects are equal.")) - ))) - -X := '"{\em Enumeration(a1, a2 ,..., aN)} creates an object which is exactly one of the N symbols {\em a1}, {\em a2}, ..., or {\em aN}, N > 0. " - -Y := '" The {\em Enumeration} can constructor can take any number of symbols as arguments." - -MESSAGE := STRCONC(X, Y) - -PUT('Enumeration, 'documentation, SUBST(MESSAGE, 'MESSAGE, '( - (constructor (NIL MESSAGE)) - (_= (((Boolean) _$ _$) - "\spad{e = f} tests for equality of two enumerations \spad{e} and \spad{f}")) - (_^_= (((Boolean) _$ _$) - "\spad{e ^= f} tests that two enumerations \spad{e} and \spad{f} are nont equal")) - (coerce (((OutputForm) _$) - "\spad{coerce(e)} returns a representation of enumeration \spad{r} as an output form") - ((_$ (Symbol)) - "\spad{coerce(s)} converts a symbol \spad{s} into an enumeration which has \spad{s} as a member symbol")) - ))) - - -mkConArgSublis args == - [[arg,:INTERN digits2Names PNAME arg] for arg in args - | (s := PNAME arg) and or/[DIGITP ELT(s,i) for i in 0..MAXINDEX s]] - -digits2Names s == ---This is necessary since arguments of conforms CANNOT have digits in TechExplorer - str := '"" - for i in 0..MAXINDEX s repeat - c := s.i - segment := - n := DIGIT_-CHAR_-P c => - ('("Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine")).n - c - CONCAT(str, segment) - str diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet new file mode 100644 index 00000000..7c7dec66 --- /dev/null +++ b/src/interp/br-con.boot.pamphlet @@ -0,0 +1,1407 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-con.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS b-con.boot <================================ + +--======================================================================= +-- Pages Initiated from HyperDoc Pages +--======================================================================= +--NOTE: This duplicate version was discovered 3/20/94 in br-search.boot +--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon +--conPage(a,:b) == +-- --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) +-- $conArgstrings: local := +-- atom a => b +-- a := conform2OutputForm a +-- [mathform2HtString x for x in rest a] +-- if not atom a then a := first a +-- da := DOWNCASE a +-- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => +-- downlink pageName --special jump out for primitive domains +-- line := conPageFastPath a => kPage line --lower case name of cons? +-- line := conPageFastPath UPCASE a => kPage line --upper case an abbr? +-- ySearch a --slow search (include default packages) +-- + +--called from buttons via bcCon, bcAbb, bcConform, dbShowCons1, dbSelectCon +conPage(a,:b) == + --The next 4 lines allow e.g. MATRIX INT ==> Matrix Integer (see kPage) + form := + atom a => [a,:b] + a + $conArgstrings: local := [form2HtString x for x in KDR a] + if not atom a then a := first a + da := DOWNCASE a + pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => + downlink pageName --special jump out for primitive domains + line := conPageFastPath da => kPage(line,form) --lower case name of cons? + line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr? + ySearch a --slow search (include default packages) + +conPageFastPath x == --called by conPage and constructorSearch +--gets line quickly for constructor name or abbreviation + s := STRINGIMAGE x + charPosition(char '_*,s,0) < #s => nil --quit if name has * in it + name := (STRINGP x => INTERN x; x) + entry := HGET($lowerCaseConTb,name) or return nil + lineNumber := LASSQ('dbLineNumber,CDDR entry) => + --'dbLineNumbers property is set by function dbAugmentConstructorDataTable + dbRead lineNumber --read record for constructor from libdb.text + conPageConEntry first entry + +conPageConEntry entry == + $conname: local := nil + $conform: local := nil + $exposed?:local := nil + $doc: local := nil + $kind: local := nil + buildLibdbConEntry entry + +--======================================================================= +-- Constructor Page +--======================================================================= +-- in br-saturn.boot now +--% kPage(line,:options) == --any cat, dom, package, default package +--% --constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) +--% ------------------> BRANCH OUT FOR SATURN +--% true => kPageSaturn(line,options) +--% parts := dbXParts(line,7,1) +--% [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts +--% form := IFCAR options +--% isFile := null kind +--% kind := kind or '"package" +--% RPLACA(parts,kind) +--% conform := mkConform(kind,name,args) +--% conname := opOf conform +--% capitalKind := capitalize kind +--% signature := ncParseFromString sig +--% sourceFileName := dbSourceFile INTERN name +--% constrings := +--% KDR form => dbConformGenUnder form +--% [STRCONC(name,args)] +--% emString := ['"{\sf ",:constrings,'"}"] +--% heading := [capitalKind,'" ",:emString] +--% if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] +--% if name=abbrev then abbrev := asyAbbreviation(conname,nargs) +--% page := htInitPage(heading,nil) +--% htpSetProperty(page,'isFile,true) +--% htpSetProperty(page,'parts,parts) +--% htpSetProperty(page,'heading,heading) +--% htpSetProperty(page,'kind,kind) +--% if asharpConstructorName? conname then +--% htpSetProperty(page,'isAsharpConstructor,true) +--% htpSetProperty(page,'conform,conform) +--% htpSetProperty(page,'signature,signature) +--% kdPageInfo(name,abbrev,nargs,conform,signature,isFile) +--% htSayStandard '"\newline" +--% htBeginMenu(3) +--% htSayStandard '"\item " +--% htMakePage [['bcLinks,['"\menuitemstyle{Description}", +--% [['text,'"\tab{19}",'"General description"]],'kiPage,nil]]] +--% satBreak() +--% htMakePage [['bcLinks,['"\menuitemstyle{Operations}", +--% [['text,'"\tab{19}All exported operations"]],'koPage,'"operation"]]] +--% if not asharpConstructorName? conname then +--% satBreak() +--% htMakePage [['bcLinks,['"\menuitemstyle{Attributes}", +--% [['text,'"\tab{19}All exported attributes"]],'koPage,'"attribute"]]] +--% if kind ^= 'category and (pathname := dbHasExamplePage conname) then +--% satBreak() +--% htMakePage [['bcLinks,['"\menuitemstyle{Examples}", +--% [['text,'"\tab{19}Examples illustrating use"]],'kxPage,pathname]]] +--% satBreak() +--% htMakePage [['bcLinks,['"\menuitemstyle{Exports}", +--% [['text,'"\tab{19}Explicit categories and operations"]],'kePage,nil]]] +--% satBreak() +--% htMakePage [['bcLinks,['"\menuitemstyle{Cross Reference}", +--% [['text,'"\tab{19}Hierarchy and usage information"]],'kcPage,nil]]] +--% htEndMenu(3) +--% if kind ^= 'category and nargs > 0 then addParameterTemplates conform +--% htShowPage() +--% +conform2String u == + x := form2String u + atom x => STRINGIMAGE x + "STRCONC"/[STRINGIMAGE y for y in x] + +kxPage(htPage,name) == downlink name + +kdPageInfo(name,abbrev,nargs,conform,signature,file?) == + htSay("{\sf ",name,'"}") + if abbrev ^= name then bcHt [" has abbreviation ",abbrev] + if file? then bcHt ['" is a source file."] + if nargs = 0 then (if abbrev ^= name then bcHt '".") + else + if abbrev ^= name then bcHt '" and" + bcHt + nargs = 1 => '" takes one argument:" + [" takes ",STRINGIMAGE nargs," arguments:"] + htSaturnBreak() + htSayStandard '"\indentrel{2}" + if nargs > 0 then kPageArgs(conform,signature) + htSayStandard '"\indentrel{-2}" + if name.(#name-1) = char "&" then name := SUBSEQ(name, 0, #name-1) +--sourceFileName := dbSourceFile INTERN name + sourceFileName := GETDATABASE(INTERN name,'SOURCEFILE) + filename := extractFileNameFromPath sourceFileName + if filename ^= '"" then + htSayStandard '"\newline{}" + htSay('"The source code for the constructor is found in ") + htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", + sourceFileName, '" ", name, '"}"]] + if nargs ^= 0 then htSay '"." + htSaturnBreak() + +kPageArgs([op,:args],[.,.,:source]) == +------------------> OBSELETE + firstTime := true + coSig := rest GETDATABASE(op,'COSIG) + for x in args for t in source for pred in coSig repeat + if not firstTime then htSay '", and" + htSay('"\newline ") + typeForm := (t is [":",.,t1] => t1; t) + if pred = true + then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] + else htSay('"{\em ",x,'"}") + htSay( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") + htSay + pred => '"a domain of category " + '"an element of the domain " + bcConform(typeForm,true) + +kArgPage(htPage,arg) == + [op,:args] := conform := htpProperty(htPage,'conform) + domname := htpProperty(htPage,'domname) + heading := htpProperty(htPage,'heading) + source := CDDAR getConstructorModemap op + n := position(arg,args) + typeForm := sublisFormal(args,source . n) + domTypeForm := mkDomTypeForm(typeForm,conform,domname) + descendants := domainDescendantsOf(typeForm,domTypeForm) + htpSetProperty(htPage,'cAlist,descendants) + rank := + n > 4 => nil + ('(First Second Third Fourth Fifth)).n + htpSetProperty(htPage,'rank,rank) + htpSetProperty(htPage,'thing,'"argument") +--htpSetProperty(htPage,'specialMessage,['reportCategory,conform,typeForm,arg]) + dbShowCons(htPage,'names) + +reportCategory(conform,typeForm,arg) == + htSay('"Argument {\em ",arg,'"}") + [conlist,attrlist,:oplist] := categoryParts(conform,typeForm,true) + htSay '" must " + if conlist then + htSay '"belong to " + if conlist is [u] then + htSay('"category ") + bcConform first u + bcPred rest u + else + htSay('"categories:") + bcConPredTable(conlist,opOf conform) + htSay '"\newline " + if attrlist then + if conlist then htSay '" and " + reportAO('"attribute",attrlist) + htSay '"\newline " + if oplist then + if conlist or attrlist then htSay '" and " + reportAO('"operation",oplist) + +reportAO(kind,oplist) == + htSay('"have ",kind,'":") + for [op,sig,:pred] in oplist repeat + htSay '"\newline " + if #oplist = 1 then htSay '"\centerline{" + if kind = '"attribute" then + attr := form2String [op,:sig] + satDownLink(attr,['"(|attrPage| '|",attr,'"|)"]) + else + ops := escapeSpecialChars STRINGIMAGE op + sigs := form2HtString ['Mapping,:sig] + satDownLink(ops,['"(|opPage| '|",ops,'"| |",sigs,'"|)"]) + htSay '": " + bcConform ['Mapping,:sig] + if #oplist = 1 then htSay '"}" + htSay '"\newline " + +mkDomTypeForm(typeForm,conform,domname) == --called by kargPage + domname => SUBLISLIS(rest domname,rest conform,typeForm) + typeForm is ['Join,:r] => ['Join,:[mkDomTypeForm(t,conform,domname) for t in r]] + null hasIdent typeForm => typeForm + nil + +domainDescendantsOf(conform,domform) == main where --called by kargPage + main == + conform is [op,:r] => + op = 'Join => jfn(delete('(Type Object),r),delete('(Type Object),IFCDR domform)) + op = 'CATEGORY => nil + domainsOf(conform,domform) + domainsOf(conform,domform) + jfn([y,:r],domlist) == --keep only those domains that appear in ALL parts of Join + alist := domainsOf(y,IFCAR domlist) + for x in r repeat + domlist := IFCDR domlist + x is ['CATEGORY,.,:r] => alist := catScreen(r,alist) + keepList := nil + for [item,:pred] in domainsOf(x,IFCAR domlist) repeat + u := ASSOC(item,alist) => + keepList := [[item,:quickAnd(CDR u,pred)],:keepList] + alist := keepList + for pair in alist repeat RPLACD(pair,simpHasPred CDR pair) + listSort(function GLESSEQP, alist) + catScreen(r,alist) == + for x in r repeat + x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x + alist := [[item,:npred] for [item,:pred] in alist | + (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))] + alist + +--======================================================================= +-- Branches of Constructor Page +--======================================================================= + +kiPage(htPage,junk) == + [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + conform := mkConform(kind,name,args) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := ['"Description of ", capitalize kind,'" {\sf ",name,args,'"}"] + page := htInitPage(heading,htCopyProplist htPage) + $conformsAreDomains := domname + dbShowConsDoc1(htPage,conform,nil) + htShowPage() + +kePage(htPage,junk) == + [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + constring := STRCONC(name,args) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + htpSetProperty(htPage,'domname,domname) + $conformsAreDomains: local := domname + conform := mkConform(kind,name,args) + conname := opOf conform + heading := [capitalize kind,'" {\sf ", + (domname => form2HtString(domname,nil,true); constring),'"}"] + data := sublisFormal(IFCDR domname or rest conform, + getConstructorExports((domname or conform),true)) + [conlist,attrlist,:oplist] := data + if domname then + for x in conlist repeat RPLAC(CDR x,simpHasPred CDR x) + for x in attrlist repeat RPLAC(CDDR x,simpHasPred CDDR x) + for x in oplist repeat RPLAC(CDDR x,simpHasPred CDDR x) + prefix := pluralSay(#conlist + #attrlist + #oplist,'"Export",'"Exports") + page := htInitPage([:prefix,'" of ",:heading],htCopyProplist htPage) + htSayStandard '"\beginmenu " + htpSetProperty(page,'data,data) + if conlist then + htMakePage [['bcLinks,[menuButton(),'"",'dbShowCons1,conlist,'names]]] + htSayStandard '"\tab{2}" + htSay '"All attributes and operations from:" + bcConPredTable(conlist,opOf conform,rest conform) + if attrlist then + if conlist then htBigSkip() + kePageDisplay(page,'"attribute",kePageOpAlist attrlist) + if oplist then + if conlist or attrlist then htBigSkip() + kePageDisplay(page,'"operation",kePageOpAlist oplist) + htSayStandard '" \endmenu " + htShowPage() + +kePageOpAlist oplist == + opAlist := nil + for [op,sig,:pred] in oplist repeat + u := LASSOC(op,opAlist) +--was +-- opAlist := insertAlist(op,[[sig,pred],:u],opAlist) + opAlist := insertAlist(zeroOneConvert op,[[sig,pred],:u],opAlist) + opAlist + +kePageDisplay(htPage,which,opAlist) == + count := #opAlist + total := +/[#(rest entry) for entry in opAlist] + count = 0 => nil + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + htpSetProperty(htPage,expandProperty,'lists) --mark as unexpanded + htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,'names]]] + htSayStandard '"\tab{2}" + if count ^= total then + if count = 1 + then htSay('"1 name for ") + else htSay(STRINGIMAGE count,'" names for ") + if total > 1 + then htSay(STRINGIMAGE total,'" ",pluralize which,'" are explicitly exported:") + else htSay('"1 ",which,'" is explicitly exported:") + htSaySaturn '"\\" + data := dbGatherData(htPage,opAlist,which,'names) + dbShowOpItems(which,data,false) + +ksPage(htPage,junk) == + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + if domname then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + domain := (kind = '"category" => nil; EVAL domname) + conform:= htpProperty(htPage,'conform) + page := htInitPageNoScroll(htCopyProplist htPage, + ['"Search order for ",:heading]) + htSay '"When an operation is not defined by the domain, the following domains are searched in order for a _"default definition" + htSayStandard '"\beginscroll " + u := dbSearchOrder(conform,domname,domain) + htpSetProperty(htPage,'cAlist,u) + htpSetProperty(htPage,'thing,'"constructor") + dbShowCons(htPage,'names) + +dbSearchOrder(conform,domname,$domain) == --domain = nil or set to live domain + conform := domname or conform + name:= opOf conform + $infovec: local := dbInfovec name or return nil --exit for categories + u := $infovec.3 + $predvec:= + $domain => $domain . 3 + GETDATABASE(name,'PREDICATES) + catpredvec := CAR u + catinfo := CADR u + catvec := CADDR u + catforms := [[pakform,:pred] for i in 0..MAXINDEX catvec | test ] where + test == + pred := simpCatPredicate + p:=SUBLISLIS(rest conform,$FormalMapVariableList,kTestPred catpredvec.i) + $domain => EVAL p + p + if domname and CONTAINED('$,pred) then pred := SUBST(domname,'$,pred) +-- which = '"attribute" => pred --all categories + (pak := catinfo . i) and pred --only those with default packages + pakform == + pak and not IDENTP pak => devaluate pak --in case it has been instantiated + catform := kFormatSlotDomain catvec . i +-- which = '"attribute" => dbSubConform(rest conform,catform) + res := dbSubConform(rest conform,[pak,"$",:rest catform]) + if domname then res := SUBST(domname,'$,res) + res + [:dbAddChain conform,:catforms] + +kcPage(htPage,junk) == + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) +-- domain := (kind = '"category" => nil; EVAL domname) + conform := htpProperty(htPage,'conform) + conname := opOf conform + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + page := htInitPage(['"Cross Reference for ",:heading],htCopyProplist htPage) + if domname then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + if kind = '"category" and dbpHasDefaultCategory? xpart then + htSay '"This category has default package " + bcCon(STRCONC(name,char '_&),'"") + htSayStandard '"\newline" + htBeginMenu(3) + htSayStandard '"\item " + message := + kind = '"category" => ['"Categories it directly extends"] + ['"Categories the ",(kind = '"default package" => '"package"; kind),'" belongs to by assertion"] + htMakePage [['bcLinks,['"\menuitemstyle{Parents}", + [['text,'"\tab{12}",:message]],'kcpPage,nil]]] + satBreak() + message := + kind = '"category" => ['"All categories it is an extension of"] + ['"All categories the ",kind,'" belongs to"] + htMakePage [['bcLinks,['"\menuitemstyle{Ancestors}", + [['text,'"\tab{12}",:message]],'kcaPage,nil]]] + if kind = '"category" then + satBreak() + htMakePage [['bcLinks,['"\menuitemstyle{Children}",[['text,'"\tab{12}", + '"Categories which directly extend this category"]],'kccPage,nil]]] + + satBreak() + htMakePage [['bcLinks,['"\menuitemstyle{Descendants}",[['text,'"\tab{12}", + '"All categories which extend this category"]],'kcdPage,nil]]] + if not asharpConstructorName? conname then + satBreak() + message := '"Constructors mentioning this as an argument type" + htMakePage [['bcLinks,['"\menuitemstyle{Dependents}", + [['text,'"\tab{12}",message]],'kcdePage,nil]]] + if not asharpConstructorName? conname and kind ^= '"category" then + satBreak() + htMakePage [['bcLinks,['"\menuitemstyle{Lineage}", + '"\tab{12}Constructor hierarchy used for operation lookup",'ksPage,nil]]] + if not asharpConstructorName? conname then + if kind = '"category" then + satBreak() + htMakePage [['bcLinks,['"\menuitemstyle{Domains}",[['text,'"\tab{12}", + '"All domains which are of this category"]],'kcdoPage,nil]]] + if kind ^= '"category" then + satBreak() + htMakePage [['bcLinks,['"\menuitemstyle{Clients}",'"\tab{12}Constructors",'kcuPage,nil]]] + if HGET($defaultPackageNamesHT,conname) + then htSay('" which {\em may use} this default package") +-- htMakePage [['bcLinks,['"files",'"",'kcuPage,true]]] + else htSay('" which {\em use} this ",kind) + if kind ^= '"category" or dbpHasDefaultCategory? xpart then + satBreak() + message := + kind = '"category" => ['"Constructors {\em used by} its default package"] + ['"Constructors {\em used by} the ",kind] + htMakePage [['bcLinks,['"\menuitemstyle{Benefactors}", + [['text,'"\tab{12}",:message]],'kcnPage,nil]]] + --to remove "Capsule Information", comment out the next 5 lines + if not asharpConstructorName? conname and hasNewInfoAlist conname then + satBreak() + message := ['"Cross reference for capsule implementation"] + htMakePage [['bcLinks,['"\menuitemstyle{CapsuleInfo}", + [['text,'"\tab{12}",:message]],'kciPage,nil]]] + htEndMenu(3) + htShowPage() + +kcpPage(htPage,junk) == + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + if domname then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + conform := htpProperty(htPage,'conform) + conname := opOf conform + page := htInitPage(['"Parents of ",:heading],htCopyProplist htPage) + parents := parentsOf conname --was listSort(function GLESSEQP, =this) + if domname then parents := SUBLISLIS(rest domname,rest conform,parents) + htpSetProperty(htPage,'cAlist,parents) + htpSetProperty(htPage,'thing,'"parent") + choice := + domname => 'parameters + 'names + dbShowCons(htPage,choice) + +reduceAlistForDomain(alist,domform,conform) == --called from kccPage + alist := SUBLISLIS(rest domform,rest conform,alist) + for pair in alist repeat RPLACD(pair,simpHasPred(CDR pair,domform)) + [pair for (pair := [.,:pred]) in alist | pred] + +kcaPage(htPage,junk) == + kcaPage1(htPage,'"category",'" an ",'"ancestor",function ancestorsOf, false) + +kcdPage(htPage,junk) == + kcaPage1(htPage,'"category",'" a ",'"descendant",function descendantsOf,true) + +kcdoPage(htPage,junk)== + kcaPage1(htPage,'"domain",'" a ",'"descendant",function domainsOf, false) + +kcaPage1(htPage,kind,article,whichever,fn, isCatDescendants?) == + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + if domname and not isCatDescendants? then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + conform := htpProperty(htPage,'conform) + conname := opOf conform + ancestors := FUNCALL(fn, conform, domname) + if whichever ^= '"ancestor" then + ancestors := augmentHasArgs(ancestors,conform) + ancestors := listSort(function GLESSEQP,ancestors) +--if domname then ancestors := SUBST(domname,'$,ancestors) + htpSetProperty(htPage,'cAlist,ancestors) + htpSetProperty(htPage,'thing,whichever) + choice := +-- domname => 'parameters + 'names + dbShowCons(htPage,choice) + +kccPage(htPage,junk) == + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + if domname then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + conform := htpProperty(htPage,'conform) + conname := opOf conform + page := htInitPage(['"Children of ",:heading],htCopyProplist htPage) + children:= augmentHasArgs(childrenOf conform,conform) + if domname then children := reduceAlistForDomain(children,domname,conform) + htpSetProperty(htPage,'cAlist,children) + htpSetProperty(htPage,'thing,'"child") + dbShowCons(htPage,'names) + +augmentHasArgs(alist,conform) == + conname := opOf conform + args := KDR conform or return alist + n := #args + [[name,:pred] for [name,:p] in alist] where pred == + extractHasArgs p is [a,:b] => p + quickAnd(p,['hasArgs,:TAKE(n,KDR getConstructorForm opOf name)]) + +kcdePage(htPage,junk) == + [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + conname := INTERN name + constring := STRCONC(name,args) + conform := + kind ^= '"default package" => ncParseFromString constring + [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & + pakname := +-- kind = '"category" => INTERN STRCONC(name,char '_&) + opOf conform + domList := getDependentsOfConstructor pakname + cAlist := [[getConstructorForm x,:true] for x in domList] + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,'"dependent") + dbShowCons(htPage,'names) + +kcuPage(htPage,junk) == + [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + conname := INTERN name + constring := STRCONC(name,args) + conform := + kind ^= '"default package" => ncParseFromString constring + [INTERN name,:rest ncParseFromString STRCONC(char 'd,args)] --because of & + pakname := + kind = '"category" => INTERN STRCONC(name,char '_&) + opOf conform + domList := getUsersOfConstructor pakname + cAlist := [[getConstructorForm x,:true] for x in domList] + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,'"user") + dbShowCons(htPage,'names) + +kcnPage(htPage,junk) == +--if reached by a category, that category has a default package + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + domname := kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + heading := + null domname => htpProperty(htPage,'heading) + ['"{\sf ",form2HtString(domname,nil,true),'"}"] + if domname then + htpSetProperty(htPage,'domname,domname) + htpSetProperty(htPage,'heading,heading) + conform:= htpProperty(htPage,'conform) + pakname := + kind = '"category" => INTERN STRCONC(PNAME conname,char '_&) + opOf conform + domList := getImports pakname + if domname then + domList := SUBLISLIS([domname,:rest domname],['$,:rest conform],domList) + cAlist := [[x,:true] for x in domList] + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,'"benefactor") + dbShowCons(htPage,'names) + +koPageInputAreaUnchanged?(htPage, nargs) == + [htpLabelInputString(htPage,INTERN STRCONC('"*",STRINGIMAGE i)) for i in 1..nargs] + = htpProperty(htPage,'inputAreaList) + +kDomainName(htPage,kind,name,nargs) == + htpSetProperty(htPage,'domname,nil) + inputAreaList := + [htpLabelInputString(htPage,var) for i in 1..nargs for var in $PatternVariableList] + htpSetProperty(htPage,'inputAreaList,inputAreaList) + conname := INTERN name + args := [kArgumentCheck(domain?,x) or nil for x in inputAreaList + for domain? in rest GETDATABASE(conname,'COSIG)] + or/[null x for x in args] => + (n := +/[1 for x in args | x]) > 0 => + ['error,nil,'"\centerline{You gave values for only {\em ",n,'" } of the {\em ",#args,'"}}",'"\centerline{parameters of {\sf ",name,'"}}\vspace{1}\centerline{Please enter either {\em all} or {\em none} of the type parameters}"] + nil + argString := + null args => '"()" + argTailPart := + "STRCONC"/["STRCONC"/ ['",",:x] for x in KDR args] + "STRCONC"/['"(",:first args,argTailPart,'")"] + typeForm := CATCH('SPAD__READER, unabbrev mkConform(kind,name,argString)) or + ['error,'invalidType,STRCONC(name,argString)] + null (evaluatedTypeForm := kisValidType typeForm) => + ['error,'invalidType,STRCONC(name,argString)] + dbMkEvalable evaluatedTypeForm + +kArgumentCheck(domain?,s) == + s = '"" => nil + domain? and (form := conSpecialString? s) => + null KDR form => [STRINGIMAGE opOf form] + form2String form + [s] + +dbMkEvalable form == +--like mkEvalable except that it does NOT quote domains +--does not do "loadIfNecessary" + [op,:.] := form + kind := GETDATABASE(op,'CONSTRUCTORKIND) + kind = 'category => form + mkEvalable form + +topLevelInterpEval x == + $ProcessInteractiveValue: fluid := true + $noEvalTypeMsg: fluid := true + processInteractive(x,nil) + +kisValidType typeForm == + $ProcessInteractiveValue: fluid := true + $noEvalTypeMsg: fluid := true + CATCH('SPAD__READER, processInteractive(typeForm,nil)) + is [[h,:.],:t] and member(h,'(Domain SubDomain)) => + kCheckArgumentNumbers t and t + false + +kCheckArgumentNumbers t == + [conname,:args] := t + cosig := KDR GETDATABASE(conname,'COSIG) + #cosig ^= #args => false + and/[foo for domain? in cosig for x in args] where foo == + domain? => kCheckArgumentNumbers x + true + +parseNoMacroFromString(s) == + s := next(function ncloopParse, + next(function lineoftoks,incString s)) + StreamNull s => nil + pf2Sex first rest first s + + + +mkConform(kind,name,argString) == + kind ^= '"default package" => + form := STRCONC(name,argString) + parse := parseNoMacroFromString form + null parse => + sayBrightlyNT '"Won't parse: " + pp form + systemError '"Keywords in argument list?" + ATOM parse => [parse] + parse + [INTERN name,:rest ncParseFromString STRCONC(char 'd,argString)] --& case + +--======================================================================= +-- Operation Page for a Domain Form from Scratch +--======================================================================= +conOpPage(htPage,conform) == + updown := dbCompositeWithMap htPage + updown = '"DOWN" => + domname := htpProperty(htPage,'domname) + conOpPage1(dbExtractUnderlyingDomain domname,[['updomain,:domname]]) + domname := htpProperty(htPage,'updomain) + conOpPage1(domname,nil) + +dbCompositeWithMap htPage == + htpProperty(htPage,'updomain) => '"UP" + domain := htpProperty(htPage,'domname) + null domain => false + opAlist := htpProperty(htPage,'opAlist) +--not LASSOC('map,opAlist) => false + dbExtractUnderlyingDomain htpProperty(htPage,'domname) => '"DOWN" + false + +dbExtractUnderlyingDomain domain == or/[x for x in KDR domain | isValidType x] + +--conform is atomic if no parameters, otherwise must be valid domain form +conOpPage1(conform,:options) == +--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) + bindingsAlist := IFCAR options + conname := opOf conform + MEMQ(conname,$Primitives) => + dbSpecialOperations conname + domname := --> !!note!! <-- + null atom conform => conform + nil + line := conPageFastPath conname + [kind,name,nargs,xflag,sig,args,abbrev,comments]:=parts:= dbXParts(line,7,1) + isFile := null kind + kind := kind or '"package" + RPLACA(parts,kind) + constring := STRCONC(name,args) + conform := mkConform(kind,name,args) + capitalKind := capitalize kind + signature := ncParseFromString sig + sourceFileName := dbSourceFile INTERN name + emString := ['"{\sf ",constring,'"}"] + heading := [capitalKind,'" ",:emString] + if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] + page := htInitPage(heading,nil) + htpSetProperty(page,'isFile,true) + htpSetProperty(page,'fromConOpPage1,true) + htpSetProperty(page,'parts,parts) + htpSetProperty(page,'heading,heading) + htpSetProperty(page,'kind,kind) + htpSetProperty(page,'domname,domname) --> !!note!! <-- + htpSetProperty(page,'conform,conform) + htpSetProperty(page,'signature,signature) + if selectedOperation := LASSOC('selectedOperation,IFCDR options) then + htpSetProperty(page,'selectedOperation,selectedOperation) + for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) + koPage(page,'"operation") + +--======================================================================= +-- Operation Page from Main Page +--======================================================================= +koPage(htPage,which) == + [kind,name,nargs,xflag,sig,args,abbrev,comments] := htpProperty(htPage,'parts) + constring := STRCONC(name,args) + conname := INTERN name + domname := + (u := htpProperty(htPage,'domname)) is [=conname,:.] + and (htpProperty(htPage,'fromConOpPage1) = true or + koPageInputAreaUnchanged?(htPage,nargs)) => u + kDomainName(htPage,kind,name,nargs) + domname is ['error,:.] => errorPage(htPage,domname) + htpSetProperty(htPage,'domname,domname) + headingString := + domname => form2HtString(domname,nil,true) + constring + heading := [capitalize kind,'" {\sf ",headingString,'"}"] + htpSetProperty(htPage,'which,which) + htpSetProperty(htPage,'heading,heading) + koPageAux(htPage,which,domname,heading) + +koPageFromKKPage(htPage,ao) == + koPageAux(htPage,ao,htpProperty(htPage,'domname),htpProperty(htPage,'heading)) + +koPageAux(htPage,which,domname,heading) == --from koPage, koPageFromKKPage + htpSetProperty(htPage,'which,which) + domname := htpProperty(htPage,'domname) + conform := htpProperty(htPage,'conform) + heading := htpProperty(htPage,'heading) + opAlist := + which = '"attribute" => koAttrs(conform,domname) + which = '"general operation" => koOps(conform,domname,true) + koOps(conform,domname) + if selectedOperation := htpProperty(htPage,'selectedOperation) then + opAlist := [ASSOC(selectedOperation,opAlist) or systemError()] + dbShowOperationsFromConform(htPage,which,opAlist) + +koPageAux1(htPage,opAlist) == + which := htpProperty(htPage,'which) + dbShowOperationsFromConform(htPage,which,opAlist) + +koaPageFilterByName(htPage,functionToCall) == + htpLabelInputString(htPage,'filter) = '"" => + koaPageFilterByCategory(htPage,functionToCall) + filter := pmTransFilter(dbGetInputString htPage) +--WARNING: this call should check for ['error,:.] returned + which := htpProperty(htPage,'which) + opAlist := + [x for x in htpProperty(htPage,'opAlist) | superMatch?(filter,DOWNCASE STRINGIMAGE first x)] + htpSetProperty(htPage,'opAlist,opAlist) + FUNCALL(functionToCall,htPage,nil) + +--======================================================================= +-- Get Constructor Documentation +--======================================================================= + +dbConstructorDoc(conform,$op,$sig) == fn conform where + fn (conform := [conname,:$args]) == + or/[gn y for y in GETDATABASE(conname,'DOCUMENTATION)] + gn([op,:alist]) == + op = $op and or/[doc or '("") for [sig,:doc] in alist | hn sig] + hn sig == + #$sig = #sig and $sig = SUBLISLIS($args,$FormalMapVariableList,sig) + +dbDocTable conform == +--assumes $docTableHash bound --see dbExpandOpAlistIfNecessary + table := HGET($docTableHash,conform) => table + $docTable : local := MAKE_-HASHTABLE 'ID + --process in reverse order so that closest cover up farthest + for x in originsInOrder conform repeat dbAddDocTable x + dbAddDocTable conform + HPUT($docTableHash,conform,$docTable) + $docTable + +originsInOrder conform == --domain = nil or set to live domain +--from dcCats + [con,:argl] := conform + GETDATABASE(con,'CONSTRUCTORKIND) = 'category => + ASSOCLEFT ancestorsOf(conform,nil) + acc := ASSOCLEFT parentsOf con + for x in acc repeat + for y in originsInOrder x repeat acc := insert(y,acc) + acc + +dbAddDocTable conform == + conname := opOf conform + storedArgs := rest getConstructorForm conname + for [op,:alist] in SUBLISLIS(["$",:rest conform], + ["%",:storedArgs],GETDATABASE(opOf conform,'DOCUMENTATION)) + repeat + op1 := + op = '(Zero) => 0 + op = '(One) => 1 + op + for [sig,doc] in alist repeat + HPUT($docTable,op1,[[conform,:alist],:HGET($docTable,op1)]) + --note opOf is needed!!! for some reason, One and Zero appear within prens + +dbGetDocTable(op,$sig,docTable,$which,aux) == main where +--docTable is [[origin,entry1,...,:code] ...] where +-- each entry is [sig,doc] and code is NIL or else a topic code for op + main == + if null FIXP op and + DIGITP (s := STRINGIMAGE op).0 then op := string2Integer s + -- the above hack should be removed after 3/94 when 0 is not |0| + aux is [[packageName,:.],:pred] => + doc := dbConstructorDoc(first aux,$op,$sig) + origin := + pred => ['ifp,:aux] + first aux + [origin,:doc] + or/[gn x for x in HGET(docTable,op)] + gn u == --u is [origin,entry1,...,:code] + $conform := CAR u --origin + if ATOM $conform then $conform := [$conform] + code := LASTATOM u --optional topic code + comments := or/[p for entry in CDR u | p := hn entry] or return nil + [$conform,first comments,:code] + hn [sig,:doc] == + $which = '"attribute" => sig is ['attribute,: =$sig] and doc + pred := #$sig = #sig and + alteredSig := SUBLISLIS(KDR $conform,$FormalMapVariableList,sig) + alteredSig = $sig + pred => + doc => + doc is ['constant,:r] => r + doc + '("") + false + +kTestPred n == + n = 0 => true + $domain => testBitVector($predvec,n) + simpHasPred $predvec.(n - 1) + +dbAddChainDomain conform == + [name,:args] := conform + $infovec := dbInfovec name or return nil --exit for categories + template := $infovec . 0 + null (form := template . 5) => nil + dbSubConform(args,kFormatSlotDomain devaluate form) + +dbSubConform(args,u) == + atom u => + (n := position(u,$FormalMapVariableList)) >= 0 => args . n + u + u is ['local,y] => dbSubConform(args,y) + [dbSubConform(args,x) for x in u] + +dbAddChain conform == + u := dbAddChainDomain conform => + atom u => nil + [[u,:true],:dbAddChain u] + nil + +--======================================================================= +-- Constructor Page Menu +--======================================================================= +---------> !OBSELETE! <------------- +dbPresentCons(htPage,kind,:exclusions) == -- calist is ((catform . pred)...) + $saturn => dbPresentConsSaturn(htPage,kind,exclusions) + htSay('"{\em Views:}") + htpSetProperty(htPage,'exclusion,first exclusions) + cAlist := htpProperty(htPage,'cAlist) + empty? := null cAlist + exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 + star? := true --always include information on exposed/unexposed 4/92 + htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") + if empty? or member('names,exclusions) + then htSay '"{\em names}" + else htMakePage [['bcLispLinks,['"names",'"",'dbShowCons,'names]]] + htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") + if empty? or member('kinds,exclusions) or kind ^= 'constructor + then htSay '"{\em kinds}" + else htMakePage [['bcLispLinks,['"kinds",'"",'dbShowCons,'kinds]]] + htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") + if empty? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] + then htSay '"{\em parameters}" + else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowCons,'parameters]]] + if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") + if empty? or null CDR cAlist + then htSay '"{\em filter}" + else htMakePage [['bcLinks,['"filter",'"",'dbShowCons,'filter]]] + htMakePage [['bcStrings, [11,'"",'filter,'EM]]] + htSay('"\newline") + if exposedUnexposedFlag then + if $exposedOnlyIfTrue then + htMakePage [['bcLinks,['"exposed",'" {\em only}",'dbShowCons,'exposureOff]]] + else + htSay('"*{\em =}") + htMakePage [['bcLinks,['"unexposed",'"",'dbShowCons,'exposureOn]]] + htSayStandard(if star? then '"\tab{13}" else '"\tab{9}") + if empty? or member('abbrs,exclusions) + then htSay '"{\em abbrs}" + else htMakePage [['bcLispLinks,['"abbrs",'"",'dbShowCons,'abbrs]]] + htSayStandard(if star? then '"\tab{21}" else '"\tab{17}") + if empty? or member('files,exclusions) + then htSay '"{\em files}" + else htMakePage [['bcLispLinks,['"files",'"",'dbShowCons,'files]]] + htSayStandard(if star? then '"\tab{29}" else '"\tab{25}") + if empty? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] + then htSay '"{\em conditions}" + else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowCons,'conditions]]] + if star? then htSayStandard('"\tab{42}") else htSayStandard('"\tab{38}") + if empty? or member('documentation,exclusions) + then htSay '"{\em descriptions}" + else htMakePage [['bcLispLinks,['"descriptions",'"",'dbShowCons,'documentation]]] + +dbShowCons(htPage,key,:options) == + cAlist := htpProperty(htPage,'cAlist) + key = 'filter => + --if $saturn, IFCAR options is the filter string + filter := pmTransFilter(IFCAR options or dbGetInputString htPage) + filter is ['error,:.] => bcErrorPage filter + abbrev? := htpProperty(htPage,'exclusion) = 'abbrs + u := [x for x in cAlist | test] where test == + conname := CAAR x + subject := (abbrev? => constructor? conname; conname) + superMatch?(filter,DOWNCASE STRINGIMAGE subject) + null u => emptySearchPage('"constructor",filter) + htPage := htInitPageNoScroll(htCopyProplist htPage) + htpSetProperty(htPage,'cAlist,u) + dbShowCons(htPage,htpProperty(htPage,'exclusion)) + if MEMQ(key,'(exposureOn exposureOff)) then + $exposedOnlyIfTrue := + key = 'exposureOn => 'T + NIL + key := htpProperty(htPage,'exclusion) + dbShowCons1(htPage,cAlist,key) + +conPageChoose conname == + cAlist := [[getConstructorForm conname,:true]] + dbShowCons1(nil,cAlist,'names) + +dbShowCons1(htPage,cAlist,key) == + conlist := REMDUP [item for x in cAlist | pred] where + pred == + item := CAR x + $exposedOnlyIfTrue => isExposedConstructor opOf item + item +--$searchFirstTime and (conlist is [.]) => conPage first conlist +--$searchFirstTime := false + conlist is [.] => conPage + htPage and htpProperty(htPage,'domname) => first conlist + opOf first conlist + conlist := [opOf x for x in conlist] + kinds := "union"/[dbConstructorKind x for x in conlist] + kind := + kinds is [a] => a + 'constructor + proplist := + htPage => htCopyProplist htPage + nil + page := htInitPageNoScroll(proplist,dbConsHeading(htPage,conlist,key,kind)) + if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) + htSayStandard('"\beginscroll ") + htpSetProperty(page,'cAlist,cAlist) + $conformsAreDomains: local := htpProperty(page,'domname) + do + --key = 'catfilter => dbShowCatFilter(page,key) + key = 'names => bcNameConTable conlist + key = 'abbrs => + bcAbbTable [getCDTEntry(con,true) for con in conlist] + key = 'files => + flist := + [y for con in conlist | + y := (fn := GETDATABASE(con,'SOURCEFILE))] + bcUnixTable(listSort(function GLESSEQP,REMDUP flist)) + key = 'documentation => dbShowConsDoc(page,conlist) + if $exposedOnlyIfTrue then + cAlist := [x for x in cAlist | isExposedConstructor opOf CAR x] + key = 'conditions => dbShowConditions(page,cAlist,kind) + key = 'parameters => bcConTable REMDUP ASSOCLEFT cAlist + key = 'kinds => dbShowConsKinds cAlist + dbConsExposureMessage() + htSayStandard("\endscroll ") + dbPresentCons(page,kind,key) + htShowPageNoScroll() + + +dbConsExposureMessage() == + $atLeastOneUnexposed => + htSay '"\newline{}-------------\newline{}{\em *} = unexposed" + +-- DUPLICATE DEF - ALSO in br-saturn.boot +-- dbShowConsKinds cAlist == +-- ---------> !OBSELETE! <------------- +-- cats := doms := paks := defs := nil +-- for x in cAlist repeat +-- op := CAAR x +-- kind := dbConstructorKind op +-- kind = 'category => cats := [x,:cats] +-- kind = 'domain => doms := [x,:doms] +-- kind = 'package => paks:= [x,:paks] +-- defs := [x,:defs] +-- lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] +-- htBeginMenu(2) +-- htSayStandard '"\indent{1}" +-- kinds := +/[1 for x in lists | #x > 0] +-- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat +-- htSay('"\item") +-- if kinds = 1 then htSay menuButton() else +-- htMakePage [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] +-- htSayStandard '"\tab{1}" +-- htSay '"{\em " +-- htSay (c := #x) +-- htSay '" " +-- htSay (c > 1 => pluralize kind; kind) +-- htSay '":}" +-- bcConTable REMDUP [CAAR y for y in x] +-- htEndMenu(2) +-- htSay '"\indent{0}" + +dbShowConsKindsFilter(htPage,[kind,cAlist]) == + htpSetProperty(htPage,'cAlist,cAlist) + dbShowCons(htPage,htpProperty(htPage,'exclusion)) + +dbShowConsDoc(htPage,conlist) == + null rest conlist => dbShowConsDoc1(htPage,getConstructorForm opOf first conlist,nil) + cAlist := htpProperty(htPage,'cAlist) + --the following code is necessary to skip over duplicates on cAlist + index := 0 + for x in REMDUP conlist repeat + -- for x in conlist repeat + dbShowConsDoc1(htPage,getConstructorForm x,i) where i == + while CAAAR cAlist ^= x repeat + index := index + 1 + cAlist := rest cAlist + null cAlist => systemError () + index + +dbShowConsDoc1(htPage,conform,indexOrNil) == + [conname,:conargs] := conform + MEMQ(conname,$Primitives) => + conname := htpProperty(htPage,'conname) + [["constructor",["NIL",doc]],:.] := GETL(conname,'documentation) + sig := '((CATEGORY domain) (SetCategory) (SetCategory)) + displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,nil,nil) + exposeFlag := isExposedConstructor conname + doc := [getConstructorDocumentation conname] + signature := getConstructorSignature conname + sig := + GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + SUBLISLIS(conargs,$TriangleVariableList,signature) + sublisFormal(conargs,signature) + htSaySaturn '"\begin{description}" + displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,null exposeFlag,nil) + htSaySaturn '"\end{description}" + --NOTE that we pass conform is as "origin" + +getConstructorDocumentation conname == + LASSOC('constructor,GETDATABASE(conname,'DOCUMENTATION)) + is [[nil,line,:.],:.] and line or '"" + +dbSelectCon(htPage,which,index) == + conPage opOf first htpProperty(htPage,'cAlist) . index + +dbShowConditions(htPage,cAlist,kind) == + conform := htpProperty(htPage,'conform) + conname := opOf conform + article := htpProperty(htPage,'article) + whichever := htpProperty(htPage,'whichever) + [consNoPred,:consPred] := splitConTable cAlist + singular := [kind,'" is"] + plural := [pluralize STRINGIMAGE kind,'" are"] + dbSayItems(#consNoPred,singular,plural,'" unconditional") + htSaySaturn '"\\" + bcConPredTable(consNoPred,conname) + htSayHrule() + dbSayItems(#consPred,singular,plural,'" conditional") + htSaySaturn '"\\" + bcConPredTable(consPred,conname) + +dbConsHeading(htPage,conlist,view,kind) == + thing := htPage and htpProperty(htPage,'thing) or '"constructor" + place := + htPage => htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + nil + count := #(REMDUP conlist) + -- count := #conlist + thing = '"benefactor" => + [STRINGIMAGE count,'" Constructors Used by ",form2HtString(place,nil,true)] + modifier := + thing = '"argument" => + rank := htPage and htpProperty(htPage,'rank) + ['" Possible ",rank,'" "] + kind = 'constructor => ['" "] + ['" ",capitalize STRINGIMAGE kind,'" "] +-- count = 1 => +-- ['"Select name or a {\em view} at the bottom"] + exposureWord := + $exposedOnlyIfTrue => '(" Exposed ") + nil + prefix := + count = 1 => [STRINGIMAGE count,:modifier,capitalize thing] + firstWord := (count = 0 => '"No "; STRINGIMAGE count) + [firstWord,:exposureWord, :modifier,capitalize pluralize thing] + placepart := + place => ['" of {\em ",form2HtString(place,nil,true),"}"] + nil + heading := [:prefix,:placepart] + connective := + member(view,'(abbrs files kinds)) => '" as " + '" with " + if count ^= 0 and member(view,'(abbrs files parameters conditions)) then heading:= [:heading,'" viewed",connective,'"{\em ",STRINGIMAGE view,'"}"] + heading + +dbShowConstructorLines lines == + cAlist := [[getConstructorForm intern dbName line,:true] for line in lines] + dbShowCons1(nil,listSort(function GLESSEQP,cAlist),'names) + +bcUnixTable(u) == + htSay '"\newline" + htBeginTable() + firstTime := true + for x in u repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + ft := + isAsharpFileName? x => '("AS") + '("SPAD") + filename := NAMESTRING $FINDFILE(STRINGIMAGE x, ft) + htMakePage [['text, '"\unixcommand{",PATHNAME_-NAME x, '"}{$AXIOM/lib/SPADEDIT ", filename, '"} "]] + htSay '"}" + htEndTable() + +isAsharpFileName? con == false + +--======================================================================= +-- Special Code for Union, Mapping, and Record +--======================================================================= + +dbSpecialDescription(conname) == + conform := getConstructorForm conname + heading := ['"Description of Domain {\sf ",form2HtString conform,'"}"] + page := htInitPage(heading,nil) + htpSetProperty(page,'conname,conname) + $conformsAreDomains := nil + dbShowConsDoc1(page,conform,nil) + htShowPage() + +dbSpecialOperations(conname) == + page := htInitPage(nil,nil) + conform := getConstructorForm conname + opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) + fromHeading := ['" from domain {\sf ",form2HtString conform,'"}"] + htpSetProperty(page,'fromHeading,fromHeading) + htpSetProperty(page,'conform,conform) + htpSetProperty(page,'opAlist,opAlist) + htpSetProperty(page,'noUsage,true) + htpSetProperty(page,'condition?,'no) + dbShowOp1(page,opAlist,'"operation",'names) + +dbSpecialExports(conname) == + conform := getConstructorForm conname + page := htInitPage(['"Exports of {\sf ",form2HtString conform,'"}"],nil) + opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) + kePageDisplay(page,'"operation",opAlist) + htShowPage() + +dbSpecialExpandIfNecessary(conform,opAlist) == + opAlist is [[op,[sig,:r],:.],:.] and rest r => opAlist + for [op,:u] in opAlist repeat + for pair in u repeat + [sig,comments] := pair + RPLACD(pair,['T,conform,'T,comments]) --[sig,pred,origin,exposeFg,doc] + opAlist + +X := '"{\sf Record(a:A,b:B)} is used to create the class of pairs of objects made up of a value of type {\em A} selected by the symbol {\em a} and a value of type {\em B} selected by the symbol {\em b}. " + +Y := '"In general, the {\sf Record} constructor can take any number of arguments and thus can be used to create aggregates of heterogeneous components of arbitrary size selectable by name. " + +Z := '"{\sf Record} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +MESSAGE := STRCONC(X,Y,Z) + +PUT('Record,'documentation,SUBST(MESSAGE,'MESSAGE,'( + (constructor (NIL MESSAGE)) + (_= (((Boolean) _$ _$) + "\spad{r = s} tests for equality of two records \spad{r} and \spad{s}")) + (coerce (((OutputForm) _$) + "\spad{coerce(r)} returns an representation of \spad{r} as an output form") + ((_$ (List (Any))) + "\spad{coerce(u)}, where \spad{u} is the list \spad{[x,y]} for \spad{x} of type \spad{A} and \spad{y} of type \spad{B}, returns the record \spad{[a:x,b:y]}")) + (elt ((A $ "a") + "\spad{r . a} returns the value stored in record \spad{r} under selector \spad{a}.") + ((B $ "b") + "\spad{r . b} returns the value stored in record \spad{r} under selector \spad{b}.")) + (setelt ((A $ "a" A) + "\spad{r . a := x} destructively replaces the value stored in record \spad{r} under selector \spad{a} by the value of \spad{x}. Error: if \spad{r} has not been previously assigned a value.") + ((B $ "b" B) + "\spad{r . b := y} destructively replaces the value stored in record \spad{r} under selector \spad{b} by the value of \spad{y}. Error: if \spad{r} has not been previously assigned a value.")) + ))) + +X := '"{\sf Union(A,B)} denotes the class of objects which are which are either members of domain {\em A} or of domain {\em B}. The {\sf Union} constructor can take any number of arguments. " + +Y := '"For an alternate form of {\sf Union} with _"tags_", see \downlink{Union(a:A,b:B)}{DomainUnion}. {\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +MESSAGE := STRCONC(X,Y) + +PUT('UntaggedUnion,'documentation,SUBST(MESSAGE,'MESSAGE,'( + (constructor (NIL MESSAGE)) + (_= (((Boolean) $ $) + "\spad{u = v} tests if two objects of the union are equal, that is, u and v are hold objects of same branch which are equal.")) + (case (((Boolean) $ "A") + "\spad{u case A} tests if \spad{u} is of the type \spad{A} branch of the union.") + (((Boolean) $ "B") + "\spad{u case B} tests if \spad{u} is of the \spad{B} branch of the union.")) + (coerce ((A $) + "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of the \spad{A} branch of the union. Error: if \spad{u} is of the \spad{B} branch of the union.") + ((B $) + "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of the \spad{B} branch of the union. Error: if \spad{u} is of the \spad{A} branch of the union.") + (($ A) + "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") + (($ B) + "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) + ))) + +X := '"{\sf Union(a:A,b:B)} denotes the class of objects which are either members of domain {\em A} or of domain {\em B}. " + +Y := '"The symbols {\em a} and {\em b} are called _"tags_" and are used to identify the two _"branches_" of the union. " + +Z := '"The {\sf Union} constructor can take any number of arguments and has an alternate form without {\em tags} (see \downlink{Union(A,B)}{UntaggedUnion}). " + +W := '"This tagged {\sf Union} type is necessary, for example, to disambiguate two branches of a union where {\em A} and {\em B} denote the same type. " + +A := '"{\sf Union} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +MESSAGE := STRCONC(X,Y,Z,W,A) + +PUT('Union,'documentation,SUBST(MESSAGE,'MESSAGE,'( + (constructor (NIL MESSAGE)) + (_= (((Boolean) $ $) + "\spad{u = v} tests if two objects of the union are equal, that is, \spad{u} and \spad{v} are objects of same branch which are equal.")) + (case (((Boolean) $ "A") + "\spad{u case a} tests if \spad{u} is of branch \spad{a} of the union.") + (((Boolean) $ "B") + "\spad{u case b} tests if \spad{u} is of branch \spad{b} of the union.")) + (coerce ((A $) + "\spad{coerce(u)} returns \spad{x} of type \spad{A} if \spad{x} is of branch \spad{a} of the union. Error: if \spad{u} is of branch \spad{b} of the union.") + ((B $) + "\spad{coerce(u)} returns \spad{x} of type \spad{B} if \spad{x} is of branch \spad{b} branch of the union. Error: if \spad{u} is of the \spad{a} branch of the union.") + (($ A) + "\spad{coerce(x)}, where \spad{x} has type \spad{A}, returns \spad{x} as a union type.") + (($ B) + "\spad{coerce(y)}, where \spad{y} has type \spad{B}, returns \spad{y} as a union type.")) + ))) + +X := '"{\sf Mapping(T,S,...)} denotes the class of objects which are mappings from a source domain ({\em S,...}) into a target domain {\em T}. The {\sf Mapping} constructor can take any number of arguments." + +Y := '" All but the first argument is regarded as part of a source tuple for the mapping. For example, {\sf Mapping(T,A,B)} denotes the class of mappings from {\em (A,B)} into {\em T}. " + +Z := '"{\sf Mapping} is a primitive domain of \Language{} which cannot be defined in the \Language{} language." + +MESSAGE := STRCONC(X,Y,Z) + +PUT('Mapping,'documentation, SUBST(MESSAGE,'MESSAGE,'( + (constructor (NIL MESSAGE)) + (_= (((Boolean) $ $) + "\spad{u = v} tests if mapping objects are equal.")) + ))) + +X := '"{\em Enumeration(a1, a2 ,..., aN)} creates an object which is exactly one of the N symbols {\em a1}, {\em a2}, ..., or {\em aN}, N > 0. " + +Y := '" The {\em Enumeration} can constructor can take any number of symbols as arguments." + +MESSAGE := STRCONC(X, Y) + +PUT('Enumeration, 'documentation, SUBST(MESSAGE, 'MESSAGE, '( + (constructor (NIL MESSAGE)) + (_= (((Boolean) _$ _$) + "\spad{e = f} tests for equality of two enumerations \spad{e} and \spad{f}")) + (_^_= (((Boolean) _$ _$) + "\spad{e ^= f} tests that two enumerations \spad{e} and \spad{f} are nont equal")) + (coerce (((OutputForm) _$) + "\spad{coerce(e)} returns a representation of enumeration \spad{r} as an output form") + ((_$ (Symbol)) + "\spad{coerce(s)} converts a symbol \spad{s} into an enumeration which has \spad{s} as a member symbol")) + ))) + + +mkConArgSublis args == + [[arg,:INTERN digits2Names PNAME arg] for arg in args + | (s := PNAME arg) and or/[DIGITP ELT(s,i) for i in 0..MAXINDEX s]] + +digits2Names s == +--This is necessary since arguments of conforms CANNOT have digits in TechExplorer + str := '"" + for i in 0..MAXINDEX s repeat + c := s.i + segment := + n := DIGIT_-CHAR_-P c => + ('("Zero" "One" "Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine")).n + c + CONCAT(str, segment) + str +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot deleted file mode 100644 index 98d35349..00000000 --- a/src/interp/br-data.boot +++ /dev/null @@ -1,783 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -lefts u == - [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] - - - ---====================> WAS b-data.boot <================================ - ---============================================================================ --- Build Library Database (libdb.text,...) ---============================================================================ ---Formal for libdb.text: --- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) --- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) --- attributes Aname\#\E\args\conname\pred\comments --- I = -buildLibdb(:options) == --called by buildDatabase (database.boot) - domainList := IFCAR options --build local libdb if list of domains is given - $OpLst: local := nil - $AttrLst: local := nil - $DomLst : local := nil - $CatLst : local := nil - $PakLst : local := nil - $DefLst : local := nil - deleteFile '"temp.text" - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - if null domainList then - comments := - '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." - writedb - buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'union,comments] - comments := - '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}." - writedb - buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] - comments := - '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}." - writedb - buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] - comments := - '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." - writedb - buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] - $conname: local := nil - $conform: local := nil - $exposed?:local := nil - $doc: local := nil - $kind: local := nil - constructorList := domainList or allConstructors() - for con in constructorList repeat - writedb buildLibdbConEntry con - [attrlist,:oplist] := getConstructorExports $conform - buildLibOps oplist - buildLibAttrs attrlist - SHUT $outStream - domainList => 'done --leave new database in temp.text - OBEY - $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" - $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" - '"sort _"temp.text_" > _"libdb.text_"" - --OBEY '"mv libdb.text olibdb.text" - RENAME_-FILE('"libdb.text", '"olibdb.text") - deleteFile '"temp.text" - -buildLibdbConEntry conname == - NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil - abb:=GETDATABASE(conname,'ABBREVIATION) - $conname := conname - conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. - $conform := dbMkForm SUBST('T,"T$",conform) - null $conform => nil - $exposed? := (isExposedConstructor conname => '"x"; '"n") - $doc := GETDATABASE(conname, 'DOCUMENTATION) - pname := PNAME conname - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - if kind = 'domain - and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] - and t is ['CATEGORY,'package,:.] then kind := 'package - $kind := - pname.(MAXINDEX pname) = char '_& => 'x - DOWNCASE (PNAME kind).0 - argl := rest $conform - conComments := - LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r - '"" - argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) - sigpart:= libConstructorSig $conform - header := STRCONC($kind,PNAME conname) - buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] - -dbMkForm x == atom x and [x] or x - -buildLibdbString [x,:u] == - STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) - -libConstructorSig [conname,:argl] == - [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) - formals := TAKE(#argl,$FormalMapVariableList) - sig := SUBLISLIS(formals,$TriangleVariableList,sig) - keys := [g(f,sig,i) for f in formals for i in 1..] where - g(x,u,i) == --does x appear in any but i-th element of u? - or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] - sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where - fn x == - atom x => x - x is ['Join,a,:r] => ['Join,fn a,'etc] - x is ['CATEGORY,:.] => 'etc - [fn y for y in x] - sig := [first sig,:[(k => [":",a,s]; s) - for a in argl for s in rest sig for k in keys]] - sigpart:= form2LispString ['Mapping,:sig] - if null ncParseFromString sigpart then - sayBrightly ['"Won't parse: ",sigpart] - sigpart - -concatWithBlanks r == - r is [head,:tail] => - tail => STRCONC(head,'" ",concatWithBlanks tail) - head - '"" - -writedb(u) == - not STRINGP u => nil --skip if not a string - PRINTEXP(addPatchesToLongLines(u,500),$outStream) - --positions for tick(1), dashes(2), and address(9), i.e. 12 - TERPRI $outStream - -addPatchesToLongLines(s,n) == - #s > n => STRCONC(SUBSTRING(s,0,n), - addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) - s - -buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) - -buildLibOp(op,sig,pred) == ---operations OKop \#\sig \conname\pred\comments (K is U or C) - nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! - pred := SUBST('T,"T$",pred) - sigpart:= form2LispString ['Mapping,:nsig] - predString := (pred = 'T => '""; form2LispString pred) - sop := - (s := STRINGIMAGE op) = '"One" => '"1" - s = '"Zero" => '"0" - s - header := STRCONC('"o",sop) - conform:= STRCONC($kind,form2LispString $conform) - comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) - checkCommentsForBraces('operation,sop,sigpart,comments) - writedb - buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] - -libdbTrim s == - k := MAXINDEX s - k < 0 => s - for i in 0..k repeat - s.i = $Newline => SETELT(s,i,char '_ ) - trimString s - -checkCommentsForBraces(kind,sop,sigpart,comments) == - count := 0 - for i in 0..MAXINDEX comments repeat - c := comments.i - c = char '_{ => count := count + 1 - c = char '_} => - count := count - 1 - count < 0 => missingLeft := true - if count < 0 or missingLeft then - tail := - kind = 'attribute => [sop,'"(",sigpart,'")"] - [sop,'": ",sigpart] - sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] - if count > 0 then - sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] - if count ^= 0 or missingLeft then pp comments - -buildLibAttrs attrlist == - for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) - -buildLibAttr(name,argl,pred) == ---attributes AKname\#\args\conname\pred\comments (K is U or C) - header := STRCONC('"a",STRINGIMAGE name) - argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - predString := (pred = 'T => '""; form2LispString pred) - header := STRCONC('"a",STRINGIMAGE name) - conname := STRCONC($kind,form2LispString $conname) - comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) - checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) - writedb - buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] - -dbAugmentConstructorDataTable() == - instream := MAKE_-INSTREAM '"libdb.text" - while not EOFP instream repeat - fp := FILE_-POSITION instream - line := READLINE instream - cname := INTERN dbName line - entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record - [name,abb,:.] := entry - RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) --- if xname := constructorHasExamplePage entry then --- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) - args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) - if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) - 'done - -dbHasExamplePage conname == - sname := STRINGIMAGE conname - abb := constructor? conname - ucname := UPCASE STRINGIMAGE abb - pathname :=STRCONC(getEnv '"AXIOM",'"/share/hypertex/pages/",ucname,'".ht") - isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") - nil - -dbRead(n) == - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - SHUT instream - line - -dbReadComments(n) == - n = 0 => '"" - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - k := dbTickIndex(line,1,1) - line := SUBSTRING(line,k + 1,nil) - while not EOFP instream and (x := READLINE instream) and - (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and - x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - SHUT instream - STRCONC(line, "STRCONC"/NREVERSE xtralines) - -dbSplitLibdb() == - instream := MAKE_-INSTREAM '"olibdb.text" - outstream:= MAKE_-OUTSTREAM '"libdb.text" - comstream:= MAKE_-OUTSTREAM '"comdb.text" - PRINTEXP(0, comstream) - PRINTEXP($tick,comstream) - PRINTEXP('"", comstream) - TERPRI(comstream) - while not EOFP instream repeat - line := READLINE instream - outP := FILE_-POSITION outstream - comP := FILE_-POSITION comstream - [prefix,:comments] := dbSplit(line,6,1) - PRINTEXP(prefix,outstream) - PRINTEXP($tick ,outstream) - null comments => - PRINTEXP(0,outstream) - TERPRI(outstream) - PRINTEXP(comP,outstream) - TERPRI(outstream) - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(first comments,comstream) - TERPRI(comstream) - for c in rest comments repeat - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(c, comstream) - TERPRI(comstream) - SHUT instream - SHUT outstream - SHUT comstream - OBEY '"rm olibdb.text" - -dbSplit(line,n,k) == - k := charPosition($tick,line,k + 1) - n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] - dbSplit(line,n - 1,k) - -dbSpreadComments(line,n) == - line = '"" => nil - k := charPosition(char '_-,line,n + 2) - k >= MAXINDEX line => [SUBSTRING(line,n,nil)] - line.(k + 1) ^= char '_- => - u := dbSpreadComments(line,k) - [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] - [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] - ---============================================================================ --- Build Glossary ---============================================================================ -buildGloss() == --called by buildDatabase (database.boot) ---starting with gloss.text, build glosskey.text and glossdef.text - $constructorName : local := nil - $exposeFlag : local := true - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - $x : local := nil - $attribute? : local := true --do not surround first word - pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") - instream := MAKE_-INSTREAM pathname - keypath := '"glosskey.text" - OBEY STRCONC('"rm -f ",keypath) - outstream:= MAKE_-OUTSTREAM keypath - htpath := '"gloss.ht" - OBEY STRCONC('"rm -f ",htpath) - htstream:= MAKE_-OUTSTREAM htpath - defpath := '"glossdef.text" - defstream:= MAKE_-OUTSTREAM defpath - pairs := getGlossLines instream - PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) - for [name,:line] in pairs repeat - outP := FILE_-POSITION outstream - defP := FILE_-POSITION defstream - lines := spreadGlossText transformAndRecheckComments(name,[line]) - PRINTEXP(name, outstream) - PRINTEXP($tick,outstream) - PRINTEXP(defP, outstream) - TERPRI(outstream) --- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) - PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) - PRINTEXP(name, htstream) - PRINTEXP('"}\space{}",htstream) - TERPRI(htstream) - for x in lines repeat - PRINTEXP(outP, defstream) - PRINTEXP($tick,defstream) - PRINTEXP(x, defstream) - TERPRI defstream - PRINTEXP("STRCONC"/lines,htstream) - TERPRI htstream - PRINTEXP('"\endmenu\endscroll",htstream) - PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) - PRINTEXP('"\end{page}",htstream) - SHUT instream - SHUT outstream - SHUT defstream - SHUT htstream - SHUT $outStream - -spreadGlossText(line) == ---this function breaks up a line into chunks ---eventually long line is put into gloss.text as several chunks as follows: ------ key1`this is the first chunk ------ XXX`and this is the second ------ XXX`and this is the third ------ key2`and this is the fourth ---where XXX is the file position of key1 ---this is because grepping will only pick up the first 512 characters - line = '"" => nil - MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] - [line] - -getGlossLines instream == ---instream has text of the form: ------ key1`this is the first line ------ and this is the second ------ key2'and this is the third ---result is ------ key1'this is the first line and this is the second ------ key2'and this is the third - keys := nil - text := nil - lastLineHadTick := false - while not EOFP instream repeat - line := READLINE instream - #line = 0 => 'skip - n := charPosition($tick,line,0) - last := IFCAR text - n > MAXINDEX line => --this line is continuation of previous line; concat it - fill := - #last = 0 => - lastLineHadTick => '"" - '"\blankline " - #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank - '"" - lastLineHadTick := false - text := [STRCONC(last,fill,line),:rest text] - lastLineHadTick := true - keys := [SUBSTRING(line,0,n),:keys] - text := [SUBSTRING(line,n + 1,nil),:text] - ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) - --this complication sorts them after lower casing the keys - ---============================================================================ --- Build Users HashTable --- This database is written out as USERS.DATABASE (database.boot) and read using --- function getUsersOfConstructor. See functions whoUses and kcuPage in browser. ---============================================================================ -mkUsersHashTable() == --called by buildDatabase (database.boot) - $usersTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat - for conform in getImports x repeat - name := opOf conform - if not MEMQ(name,'(QUOTE)) then - HPUT($usersTb,name,insert(x,HGET($usersTb,name))) - for k in HKEYS $usersTb repeat - HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) - for x in allConstructors() | isDefaultPackageName x repeat - HPUT($usersTb,x,getDefaultPackageClients x) - $usersTb - -getDefaultPackageClients con == --called by mkUsersHashTable - catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) - for [catAncestor,:.] in childrenOf([catname]) repeat - pakname := INTERN STRCONC(PNAME catAncestor,'"&") - if getCDTEntry(pakname,true) then acc := [pakname,:acc] - acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc) - listSort(function GLESSEQP,acc) - ---============================================================================ --- Build Dependents Hashtable --- This hashtable is written out by database.boot as DEPENDENTS.DATABASE --- and read back in by getDependentsOfConstructor (see database.boot) --- This information is used by function kcdePage when a user asks for the --- dependents of a constructor. ---============================================================================ -mkDependentsHashTable() == --called by buildDatabase (database.boot) - $depTb := MAKE_-HASH_-TABLE() - for nam in allConstructors() repeat - for con in getArgumentConstructors nam repeat - HPUT($depTb,con,[nam,:HGET($depTb,con)]) - for k in HKEYS $depTb repeat - HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) - $depTb - -getArgumentConstructors con == --called by mkDependentsHashTable - argtypes := IFCDR IFCAR getConstructorModemap con or return nil - fn argtypes where - fn(u) == "union"/[gn x for x in u] - gn(x) == - atom x => nil - x is ['Join,:r] => fn(r) - x is ['CATEGORY,:.] => nil - constructor? first x => [first x,:fn rest x] - fn rest x - -getImports conname == --called by mkUsersHashTable - conform := GETDATABASE(conname,'CONSTRUCTORFORM) - infovec := dbInfovec conname or return nil - template := infovec.0 - u := [import(i,template) - for i in 5..(MAXINDEX template) | test] where - test == template.i is [op,:.] and IDENTP op - and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) - import(x,template) == - x is [op,:args] => - op = 'QUOTE or op = 'NRTEVAL => CAR args - op = 'local => first args - op = 'Record => - ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] - ---TTT next three lines: handles some tagged/untagged Union case. - op = 'Union=> - args is [['_:,:x1],:x2] => --- CAAR args = '_: => -- tagged! - ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] - [op,:[import(y,template) for y in args]] - - [op,:[import(y,template) for y in args]] - INTEGERP x => import(template.x,template) - x = '$ => '$ - x = "$$" => "$$" - STRINGP x => x - systemError '"bad argument in template" - listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) - - ---============================================================================ --- Get Hierarchical Information ---============================================================================ -getParentsFor(cname,formalParams,constructorCategory) == ---called by compDefineFunctor1 - acc := nil - formals := TAKE(#formalParams,$TriangleVariableList) - constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) - for x in folks constructorCategory repeat - x := SUBLISLIS(formalParams,formals,x) - x := SUBLISLIS(IFCDR constructorForm,formalParams,x) - x := SUBST('Type,'Object,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -parentsOf con == --called by kcpPage, ancestorsRecur - if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) - HGET($parentsCache,con) or - parents := getParentsForDomain con - HPUT($parentsCache,con,parents) - parents - -parentsOfForm [op,:argl] == - parents := parentsOf op - null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => - parents - SUBLISLIS(argl, newArgl, parents) - -getParentsForDomain domname == --called by parentsOf - acc := nil - for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat - x := - GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => - sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) - sublisFormal(IFCDR getConstructorForm domname,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -explodeIfs x == main where --called by getParents, getParentsForDomain - main == - x is ['IF,p,a,b] => fn(p,a,b) - [[x,:true]] - fn(p,a,b) == - [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] - gn(p,a) == - a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) - [[a,:p]] - -folks u == --called by getParents and getParentsForDomain - atom u => nil - u is [op,:v] and MEMQ(op,'(Join PROGN)) - or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] - u is ['SIGNATURE,:.] => nil - u is ['TYPE,:.] => nil - u is ['ATTRIBUTE,a] => - PAIRP a and constructor? opOf a => folks a - nil - u is ['IF,p,q,r] => - q1 := folks q - r1 := folks r - q1 or r1 => [['IF,p,q1,r1]] - nil - [u] - -descendantsOf(conform,domform) == --called by kcdPage - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - cats := catsOf(conform,domform) - [op,:argl] := conform - null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) - => cats - SUBLISLIS(argl, newArgl, cats) - 'notAvailable - -childrenOf conform == - [pair for pair in descendantsOf(conform,nil) | - childAssoc(conform,parentsOfForm first pair)] - -childAssoc(form,alist) == - null (argl := CDR form) => ASSOC(form,alist) - u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u - nil - -assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] - -childArgCheck(argl, nargl) == - and/[fn for x in argl for y in nargl for i in 0..] where - fn == - x = y or constructor? opOf y => true - isSharpVar y => i = POSN1(y, $FormalMapVariableList) - false - ---computeDescendantsOf cat == ---dynamically generates descendants --- hash := MAKE_-HASHTABLE 'UEQUAL --- for [child,:pred] in childrenOf cat repeat --- childForm := getConstructorForm child --- HPUT(hash,childForm,pred) --- for [form,:pred] in descendantsOf(childForm,nil) repeat --- newPred := --- oldPred := HGET(hash,form) => quickOr(oldPred,pred) --- pred --- HPUT(hash,form,newPred) --- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] - -ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - alist := GETDATABASE(conname,'ANCESTORS) - argl := IFCDR domform or IFCDR conform - [pair for [a,:b] in alist | pair] where pair == - left := sublisFormal(argl,a) - right := sublisFormal(argl,b) - if domform then right := simpHasPred right - null right => false - [left,:right] - computeAncestorsOf(conform,domform) - -computeAncestorsOf(conform,domform) == - $done: local := MAKE_-HASHTABLE 'UEQUAL - $if: local := MAKE_-HASHTABLE 'ID - ancestorsRecur(conform,domform,true,true) - acc := nil - for op in listSort(function GLESSEQP,HKEYS $if) repeat - for pair in HGET($if,op) repeat acc := [pair,:acc] - NREVERSE acc - -ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf - op := opOf conform - pred = HGET($done,conform) => nil --skip if already processed - parents := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => - $lisplibParents - parentsOf op - originalConform := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form - getConstructorForm op - if conform ^= originalConform then - parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) - for [newform,:p] in parents repeat - if domform and rest domform then - newdomform := SUBLISLIS(rest domform,rest conform,newform) - p := SUBLISLIS(rest domform,rest conform,p) - newPred := quickAnd(pred,p) - ancestorsAdd(simpHasPred newPred,newdomform or newform) - ancestorsRecur(newform,newdomform,newPred,false) - HPUT($done,conform,pred) --mark as already processed - -ancestorsAdd(pred,form) == --called by ancestorsRecur - null pred => nil - op := IFCAR form or form - alist := HGET($if,op) - existingNode := ASSOC(form,alist) => - RPLACD(existingNode,quickOr(CDR existingNode,pred)) - HPUT($if,op,[[form,:pred],:alist]) - -domainsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - u := [key for key in HKEYS _*HASCATEGORY_-HASH_* - | key is [anc,: =conname]] - --u is list of pairs (a . b) where b = conname - --we sort u then replace each b by the predicate for which this is true - s := listSort(function GLESSEQP,COPY u) - s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] - transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) - -catsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - alist := nil - for key in allConstructors() repeat - for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat - [[op,:args],:pred] := item - newItem := - args => [[args,:pred],:LASSOC(key,alist)] - pred - alist := insertShortAlist(key,newItem,alist) - transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) - -transKCatAlist(conform,domname,s) == main where - main == - domname => --accept only exact matches after substitution - domargs := rest domname - acc := nil - rest conform => - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - match? := - domargs = args => true - HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) - nil - null match? => 'skip - npred := sublisFormal(KDR leftForm,pred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - --conform has no arguments so each pair has form [con,:pred] - for pair in s repeat - leftForm := getConstructorForm CAR pair or systemError nil - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - --no domname, so look for special argument combinations - acc := nil - KDR conform => - farglist := TAKE(#rest conform,$FormalMapVariableList) - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - hasArgsForm? := args ^= farglist - npred := sublisFormal(KDR leftForm,pred) - if hasArgsForm? then - subargs := sublisFormal(KDR leftForm,args) - hpred := --- $hasArgsList => mkHasArgsPred subargs - ['hasArgs,:subargs] - npred := quickAnd(hpred,npred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - for pair in s repeat --pair has form [con,:pred] - leftForm := getConstructorForm CAR pair - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - -mkHasArgsPred subargs == ---$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) ---M is required to be Join(B,...); in looking for the domains of B --- we can find that if B has special value C, it can - systemError subargs - -sublisFormal(args,exp,:options) == main where - main == --use only on LIST structures; see also sublisFormalAlist - $formals: local := IFCAR options or $FormalMapVariableList - null args => exp - sublisFormal1(args,exp,#args - 1) - sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] - x is [.,:.] => - acc := nil - y := x - while null atom y repeat - acc := [sublisFormal1(args,QCAR y,n),:acc] - y := QCDR y - r := NREVERSE acc - if y then - nd := LASTNODE r - RPLACD(nd,sublisFormal1(args,y,n)) - r - IDENTP x => - j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => - args.j - x - x - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= - -buildDefaultPackageNamesHT() == - $defaultPackageNamesHT := MAKE_-HASH_-TABLE() - for nam in allConstructors() | isDefaultPackageName nam repeat - HPUT($defaultPackageNamesHT,nam,true) - $defaultPackageNamesHT - -$defaultPackageNamesHT := buildDefaultPackageNamesHT() - ---======================================================================= --- Code for Private Libdbs ---======================================================================= --- $createLocalLibDb := false - -extendLocalLibdb conlist == -- called by astran - not $createLocalLibDb => nil - null conlist => nil - buildLibdb conlist --> puts datafile into temp.text - $newConstructorList := union(conlist, $newConstructorList) - localLibdb := '"libdb.text" - not PROBE_-FILE '"libdb.text" => - RENAME_-FILE('"temp.text",'"libdb.text") - oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) - newlines := dbReadLines '"temp.text" - dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text") - deleteFile '"temp.text" - -purgeLocalLibdb() == --used for debugging purposes only - $newConstructorList := nil - obey '"rm libdb.text" - - diff --git a/src/interp/br-data.boot.pamphlet b/src/interp/br-data.boot.pamphlet new file mode 100644 index 00000000..a5490ee7 --- /dev/null +++ b/src/interp/br-data.boot.pamphlet @@ -0,0 +1,809 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-data.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +lefts u == + [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] + + + +--====================> WAS b-data.boot <================================ + +--============================================================================ +-- Build Library Database (libdb.text,...) +--============================================================================ +--Formal for libdb.text: +-- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) +-- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) +-- attributes Aname\#\E\args\conname\pred\comments +-- I = +buildLibdb(:options) == --called by buildDatabase (database.boot) + domainList := IFCAR options --build local libdb if list of domains is given + $OpLst: local := nil + $AttrLst: local := nil + $DomLst : local := nil + $CatLst : local := nil + $PakLst : local := nil + $DefLst : local := nil + deleteFile '"temp.text" + $outStream: local := MAKE_-OUTSTREAM '"temp.text" + if null domainList then + comments := + '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." + writedb + buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'union,comments] + comments := + '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}." + writedb + buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] + comments := + '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}." + writedb + buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] + comments := + '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." + writedb + buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] + $conname: local := nil + $conform: local := nil + $exposed?:local := nil + $doc: local := nil + $kind: local := nil + constructorList := domainList or allConstructors() + for con in constructorList repeat + writedb buildLibdbConEntry con + [attrlist,:oplist] := getConstructorExports $conform + buildLibOps oplist + buildLibAttrs attrlist + SHUT $outStream + domainList => 'done --leave new database in temp.text + OBEY + $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" + $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" + '"sort _"temp.text_" > _"libdb.text_"" + --OBEY '"mv libdb.text olibdb.text" + RENAME_-FILE('"libdb.text", '"olibdb.text") + deleteFile '"temp.text" + +buildLibdbConEntry conname == + NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil + abb:=GETDATABASE(conname,'ABBREVIATION) + $conname := conname + conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. + $conform := dbMkForm SUBST('T,"T$",conform) + null $conform => nil + $exposed? := (isExposedConstructor conname => '"x"; '"n") + $doc := GETDATABASE(conname, 'DOCUMENTATION) + pname := PNAME conname + kind := GETDATABASE(conname,'CONSTRUCTORKIND) + if kind = 'domain + and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] + and t is ['CATEGORY,'package,:.] then kind := 'package + $kind := + pname.(MAXINDEX pname) = char '_& => 'x + DOWNCASE (PNAME kind).0 + argl := rest $conform + conComments := + LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r + '"" + argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) + sigpart:= libConstructorSig $conform + header := STRCONC($kind,PNAME conname) + buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] + +dbMkForm x == atom x and [x] or x + +buildLibdbString [x,:u] == + STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) + +libConstructorSig [conname,:argl] == + [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) + formals := TAKE(#argl,$FormalMapVariableList) + sig := SUBLISLIS(formals,$TriangleVariableList,sig) + keys := [g(f,sig,i) for f in formals for i in 1..] where + g(x,u,i) == --does x appear in any but i-th element of u? + or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] + sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where + fn x == + atom x => x + x is ['Join,a,:r] => ['Join,fn a,'etc] + x is ['CATEGORY,:.] => 'etc + [fn y for y in x] + sig := [first sig,:[(k => [":",a,s]; s) + for a in argl for s in rest sig for k in keys]] + sigpart:= form2LispString ['Mapping,:sig] + if null ncParseFromString sigpart then + sayBrightly ['"Won't parse: ",sigpart] + sigpart + +concatWithBlanks r == + r is [head,:tail] => + tail => STRCONC(head,'" ",concatWithBlanks tail) + head + '"" + +writedb(u) == + not STRINGP u => nil --skip if not a string + PRINTEXP(addPatchesToLongLines(u,500),$outStream) + --positions for tick(1), dashes(2), and address(9), i.e. 12 + TERPRI $outStream + +addPatchesToLongLines(s,n) == + #s > n => STRCONC(SUBSTRING(s,0,n), + addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) + s + +buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) + +buildLibOp(op,sig,pred) == +--operations OKop \#\sig \conname\pred\comments (K is U or C) + nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) + pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) + nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! + pred := SUBST('T,"T$",pred) + sigpart:= form2LispString ['Mapping,:nsig] + predString := (pred = 'T => '""; form2LispString pred) + sop := + (s := STRINGIMAGE op) = '"One" => '"1" + s = '"Zero" => '"0" + s + header := STRCONC('"o",sop) + conform:= STRCONC($kind,form2LispString $conform) + comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) + checkCommentsForBraces('operation,sop,sigpart,comments) + writedb + buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] + +libdbTrim s == + k := MAXINDEX s + k < 0 => s + for i in 0..k repeat + s.i = $Newline => SETELT(s,i,char '_ ) + trimString s + +checkCommentsForBraces(kind,sop,sigpart,comments) == + count := 0 + for i in 0..MAXINDEX comments repeat + c := comments.i + c = char '_{ => count := count + 1 + c = char '_} => + count := count - 1 + count < 0 => missingLeft := true + if count < 0 or missingLeft then + tail := + kind = 'attribute => [sop,'"(",sigpart,'")"] + [sop,'": ",sigpart] + sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] + if count > 0 then + sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] + if count ^= 0 or missingLeft then pp comments + +buildLibAttrs attrlist == + for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) + +buildLibAttr(name,argl,pred) == +--attributes AKname\#\args\conname\pred\comments (K is U or C) + header := STRCONC('"a",STRINGIMAGE name) + argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) + pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) + predString := (pred = 'T => '""; form2LispString pred) + header := STRCONC('"a",STRINGIMAGE name) + conname := STRCONC($kind,form2LispString $conname) + comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) + checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) + writedb + buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] + +dbAugmentConstructorDataTable() == + instream := MAKE_-INSTREAM '"libdb.text" + while not EOFP instream repeat + fp := FILE_-POSITION instream + line := READLINE instream + cname := INTERN dbName line + entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record + [name,abb,:.] := entry + RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) +-- if xname := constructorHasExamplePage entry then +-- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) + args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) + if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) + 'done + +dbHasExamplePage conname == + sname := STRINGIMAGE conname + abb := constructor? conname + ucname := UPCASE STRINGIMAGE abb + pathname :=STRCONC(getEnv '"AXIOM",'"/share/hypertex/pages/",ucname,'".ht") + isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") + nil + +dbRead(n) == + instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") + FILE_-POSITION(instream,n) + line := READLINE instream + SHUT instream + line + +dbReadComments(n) == + n = 0 => '"" + instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") + FILE_-POSITION(instream,n) + line := READLINE instream + k := dbTickIndex(line,1,1) + line := SUBSTRING(line,k + 1,nil) + while not EOFP instream and (x := READLINE instream) and + (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and + x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat + xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] + SHUT instream + STRCONC(line, "STRCONC"/NREVERSE xtralines) + +dbSplitLibdb() == + instream := MAKE_-INSTREAM '"olibdb.text" + outstream:= MAKE_-OUTSTREAM '"libdb.text" + comstream:= MAKE_-OUTSTREAM '"comdb.text" + PRINTEXP(0, comstream) + PRINTEXP($tick,comstream) + PRINTEXP('"", comstream) + TERPRI(comstream) + while not EOFP instream repeat + line := READLINE instream + outP := FILE_-POSITION outstream + comP := FILE_-POSITION comstream + [prefix,:comments] := dbSplit(line,6,1) + PRINTEXP(prefix,outstream) + PRINTEXP($tick ,outstream) + null comments => + PRINTEXP(0,outstream) + TERPRI(outstream) + PRINTEXP(comP,outstream) + TERPRI(outstream) + PRINTEXP(outP ,comstream) + PRINTEXP($tick ,comstream) + PRINTEXP(first comments,comstream) + TERPRI(comstream) + for c in rest comments repeat + PRINTEXP(outP ,comstream) + PRINTEXP($tick ,comstream) + PRINTEXP(c, comstream) + TERPRI(comstream) + SHUT instream + SHUT outstream + SHUT comstream + OBEY '"rm olibdb.text" + +dbSplit(line,n,k) == + k := charPosition($tick,line,k + 1) + n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] + dbSplit(line,n - 1,k) + +dbSpreadComments(line,n) == + line = '"" => nil + k := charPosition(char '_-,line,n + 2) + k >= MAXINDEX line => [SUBSTRING(line,n,nil)] + line.(k + 1) ^= char '_- => + u := dbSpreadComments(line,k) + [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] + [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] + +--============================================================================ +-- Build Glossary +--============================================================================ +buildGloss() == --called by buildDatabase (database.boot) +--starting with gloss.text, build glosskey.text and glossdef.text + $constructorName : local := nil + $exposeFlag : local := true + $outStream: local := MAKE_-OUTSTREAM '"temp.text" + $x : local := nil + $attribute? : local := true --do not surround first word + pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") + instream := MAKE_-INSTREAM pathname + keypath := '"glosskey.text" + OBEY STRCONC('"rm -f ",keypath) + outstream:= MAKE_-OUTSTREAM keypath + htpath := '"gloss.ht" + OBEY STRCONC('"rm -f ",htpath) + htstream:= MAKE_-OUTSTREAM htpath + defpath := '"glossdef.text" + defstream:= MAKE_-OUTSTREAM defpath + pairs := getGlossLines instream + PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) + for [name,:line] in pairs repeat + outP := FILE_-POSITION outstream + defP := FILE_-POSITION defstream + lines := spreadGlossText transformAndRecheckComments(name,[line]) + PRINTEXP(name, outstream) + PRINTEXP($tick,outstream) + PRINTEXP(defP, outstream) + TERPRI(outstream) +-- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) + PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) + PRINTEXP(name, htstream) + PRINTEXP('"}\space{}",htstream) + TERPRI(htstream) + for x in lines repeat + PRINTEXP(outP, defstream) + PRINTEXP($tick,defstream) + PRINTEXP(x, defstream) + TERPRI defstream + PRINTEXP("STRCONC"/lines,htstream) + TERPRI htstream + PRINTEXP('"\endmenu\endscroll",htstream) + PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) + PRINTEXP('"\end{page}",htstream) + SHUT instream + SHUT outstream + SHUT defstream + SHUT htstream + SHUT $outStream + +spreadGlossText(line) == +--this function breaks up a line into chunks +--eventually long line is put into gloss.text as several chunks as follows: +----- key1`this is the first chunk +----- XXX`and this is the second +----- XXX`and this is the third +----- key2`and this is the fourth +--where XXX is the file position of key1 +--this is because grepping will only pick up the first 512 characters + line = '"" => nil + MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] + [line] + +getGlossLines instream == +--instream has text of the form: +----- key1`this is the first line +----- and this is the second +----- key2'and this is the third +--result is +----- key1'this is the first line and this is the second +----- key2'and this is the third + keys := nil + text := nil + lastLineHadTick := false + while not EOFP instream repeat + line := READLINE instream + #line = 0 => 'skip + n := charPosition($tick,line,0) + last := IFCAR text + n > MAXINDEX line => --this line is continuation of previous line; concat it + fill := + #last = 0 => + lastLineHadTick => '"" + '"\blankline " + #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank + '"" + lastLineHadTick := false + text := [STRCONC(last,fill,line),:rest text] + lastLineHadTick := true + keys := [SUBSTRING(line,0,n),:keys] + text := [SUBSTRING(line,n + 1,nil),:text] + ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) + --this complication sorts them after lower casing the keys + +--============================================================================ +-- Build Users HashTable +-- This database is written out as USERS.DATABASE (database.boot) and read using +-- function getUsersOfConstructor. See functions whoUses and kcuPage in browser. +--============================================================================ +mkUsersHashTable() == --called by buildDatabase (database.boot) + $usersTb := MAKE_-HASH_-TABLE() + for x in allConstructors() repeat + for conform in getImports x repeat + name := opOf conform + if not MEMQ(name,'(QUOTE)) then + HPUT($usersTb,name,insert(x,HGET($usersTb,name))) + for k in HKEYS $usersTb repeat + HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) + for x in allConstructors() | isDefaultPackageName x repeat + HPUT($usersTb,x,getDefaultPackageClients x) + $usersTb + +getDefaultPackageClients con == --called by mkUsersHashTable + catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) + for [catAncestor,:.] in childrenOf([catname]) repeat + pakname := INTERN STRCONC(PNAME catAncestor,'"&") + if getCDTEntry(pakname,true) then acc := [pakname,:acc] + acc := union([CAAR x for x in domainsOf([catAncestor],nil)],acc) + listSort(function GLESSEQP,acc) + +--============================================================================ +-- Build Dependents Hashtable +-- This hashtable is written out by database.boot as DEPENDENTS.DATABASE +-- and read back in by getDependentsOfConstructor (see database.boot) +-- This information is used by function kcdePage when a user asks for the +-- dependents of a constructor. +--============================================================================ +mkDependentsHashTable() == --called by buildDatabase (database.boot) + $depTb := MAKE_-HASH_-TABLE() + for nam in allConstructors() repeat + for con in getArgumentConstructors nam repeat + HPUT($depTb,con,[nam,:HGET($depTb,con)]) + for k in HKEYS $depTb repeat + HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) + $depTb + +getArgumentConstructors con == --called by mkDependentsHashTable + argtypes := IFCDR IFCAR getConstructorModemap con or return nil + fn argtypes where + fn(u) == "union"/[gn x for x in u] + gn(x) == + atom x => nil + x is ['Join,:r] => fn(r) + x is ['CATEGORY,:.] => nil + constructor? first x => [first x,:fn rest x] + fn rest x + +getImports conname == --called by mkUsersHashTable + conform := GETDATABASE(conname,'CONSTRUCTORFORM) + infovec := dbInfovec conname or return nil + template := infovec.0 + u := [import(i,template) + for i in 5..(MAXINDEX template) | test] where + test == template.i is [op,:.] and IDENTP op + and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) + import(x,template) == + x is [op,:args] => + op = 'QUOTE or op = 'NRTEVAL => CAR args + op = 'local => first args + op = 'Record => + ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] + +--TTT next three lines: handles some tagged/untagged Union case. + op = 'Union=> + args is [['_:,:x1],:x2] => +-- CAAR args = '_: => -- tagged! + ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] + [op,:[import(y,template) for y in args]] + + [op,:[import(y,template) for y in args]] + INTEGERP x => import(template.x,template) + x = '$ => '$ + x = "$$" => "$$" + STRINGP x => x + systemError '"bad argument in template" + listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) + + +--============================================================================ +-- Get Hierarchical Information +--============================================================================ +getParentsFor(cname,formalParams,constructorCategory) == +--called by compDefineFunctor1 + acc := nil + formals := TAKE(#formalParams,$TriangleVariableList) + constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) + for x in folks constructorCategory repeat + x := SUBLISLIS(formalParams,formals,x) + x := SUBLISLIS(IFCDR constructorForm,formalParams,x) + x := SUBST('Type,'Object,x) + acc := [:explodeIfs x,:acc] + NREVERSE acc + +parentsOf con == --called by kcpPage, ancestorsRecur + if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) + HGET($parentsCache,con) or + parents := getParentsForDomain con + HPUT($parentsCache,con,parents) + parents + +parentsOfForm [op,:argl] == + parents := parentsOf op + null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => + parents + SUBLISLIS(argl, newArgl, parents) + +getParentsForDomain domname == --called by parentsOf + acc := nil + for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat + x := + GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => + sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) + sublisFormal(IFCDR getConstructorForm domname,x) + acc := [:explodeIfs x,:acc] + NREVERSE acc + +explodeIfs x == main where --called by getParents, getParentsForDomain + main == + x is ['IF,p,a,b] => fn(p,a,b) + [[x,:true]] + fn(p,a,b) == + [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] + gn(p,a) == + a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) + [[a,:p]] + +folks u == --called by getParents and getParentsForDomain + atom u => nil + u is [op,:v] and MEMQ(op,'(Join PROGN)) + or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] + u is ['SIGNATURE,:.] => nil + u is ['TYPE,:.] => nil + u is ['ATTRIBUTE,a] => + PAIRP a and constructor? opOf a => folks a + nil + u is ['IF,p,q,r] => + q1 := folks q + r1 := folks r + q1 or r1 => [['IF,p,q1,r1]] + nil + [u] + +descendantsOf(conform,domform) == --called by kcdPage + 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => + cats := catsOf(conform,domform) + [op,:argl] := conform + null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) + => cats + SUBLISLIS(argl, newArgl, cats) + 'notAvailable + +childrenOf conform == + [pair for pair in descendantsOf(conform,nil) | + childAssoc(conform,parentsOfForm first pair)] + +childAssoc(form,alist) == + null (argl := CDR form) => ASSOC(form,alist) + u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u + nil + +assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] + +childArgCheck(argl, nargl) == + and/[fn for x in argl for y in nargl for i in 0..] where + fn == + x = y or constructor? opOf y => true + isSharpVar y => i = POSN1(y, $FormalMapVariableList) + false + +--computeDescendantsOf cat == +--dynamically generates descendants +-- hash := MAKE_-HASHTABLE 'UEQUAL +-- for [child,:pred] in childrenOf cat repeat +-- childForm := getConstructorForm child +-- HPUT(hash,childForm,pred) +-- for [form,:pred] in descendantsOf(childForm,nil) repeat +-- newPred := +-- oldPred := HGET(hash,form) => quickOr(oldPred,pred) +-- pred +-- HPUT(hash,form,newPred) +-- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] + +ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... + 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => + alist := GETDATABASE(conname,'ANCESTORS) + argl := IFCDR domform or IFCDR conform + [pair for [a,:b] in alist | pair] where pair == + left := sublisFormal(argl,a) + right := sublisFormal(argl,b) + if domform then right := simpHasPred right + null right => false + [left,:right] + computeAncestorsOf(conform,domform) + +computeAncestorsOf(conform,domform) == + $done: local := MAKE_-HASHTABLE 'UEQUAL + $if: local := MAKE_-HASHTABLE 'ID + ancestorsRecur(conform,domform,true,true) + acc := nil + for op in listSort(function GLESSEQP,HKEYS $if) repeat + for pair in HGET($if,op) repeat acc := [pair,:acc] + NREVERSE acc + +ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf + op := opOf conform + pred = HGET($done,conform) => nil --skip if already processed + parents := + firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => + $lisplibParents + parentsOf op + originalConform := + firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form + getConstructorForm op + if conform ^= originalConform then + parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) + for [newform,:p] in parents repeat + if domform and rest domform then + newdomform := SUBLISLIS(rest domform,rest conform,newform) + p := SUBLISLIS(rest domform,rest conform,p) + newPred := quickAnd(pred,p) + ancestorsAdd(simpHasPred newPred,newdomform or newform) + ancestorsRecur(newform,newdomform,newPred,false) + HPUT($done,conform,pred) --mark as already processed + +ancestorsAdd(pred,form) == --called by ancestorsRecur + null pred => nil + op := IFCAR form or form + alist := HGET($if,op) + existingNode := ASSOC(form,alist) => + RPLACD(existingNode,quickOr(CDR existingNode,pred)) + HPUT($if,op,[[form,:pred],:alist]) + +domainsOf(conform,domname,:options) == + $hasArgList := IFCAR options + conname := opOf conform + u := [key for key in HKEYS _*HASCATEGORY_-HASH_* + | key is [anc,: =conname]] + --u is list of pairs (a . b) where b = conname + --we sort u then replace each b by the predicate for which this is true + s := listSort(function GLESSEQP,COPY u) + s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] + transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) + +catsOf(conform,domname,:options) == + $hasArgList := IFCAR options + conname := opOf conform + alist := nil + for key in allConstructors() repeat + for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat + [[op,:args],:pred] := item + newItem := + args => [[args,:pred],:LASSOC(key,alist)] + pred + alist := insertShortAlist(key,newItem,alist) + transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) + +transKCatAlist(conform,domname,s) == main where + main == + domname => --accept only exact matches after substitution + domargs := rest domname + acc := nil + rest conform => + for pair in s repeat --pair has form [con,[conargs,:pred],...]] + leftForm := getConstructorForm CAR pair + for (ap := [args,:pred]) in CDR pair repeat + match? := + domargs = args => true + HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) + nil + null match? => 'skip + npred := sublisFormal(KDR leftForm,pred) + acc := [[leftForm,:npred],:acc] + NREVERSE acc + --conform has no arguments so each pair has form [con,:pred] + for pair in s repeat + leftForm := getConstructorForm CAR pair or systemError nil + RPLACA(pair,leftForm) + RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) + s + --no domname, so look for special argument combinations + acc := nil + KDR conform => + farglist := TAKE(#rest conform,$FormalMapVariableList) + for pair in s repeat --pair has form [con,[conargs,:pred],...]] + leftForm := getConstructorForm CAR pair + for (ap := [args,:pred]) in CDR pair repeat + hasArgsForm? := args ^= farglist + npred := sublisFormal(KDR leftForm,pred) + if hasArgsForm? then + subargs := sublisFormal(KDR leftForm,args) + hpred := +-- $hasArgsList => mkHasArgsPred subargs + ['hasArgs,:subargs] + npred := quickAnd(hpred,npred) + acc := [[leftForm,:npred],:acc] + NREVERSE acc + for pair in s repeat --pair has form [con,:pred] + leftForm := getConstructorForm CAR pair + RPLACA(pair,leftForm) + RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) + s + +mkHasArgsPred subargs == +--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) +--M is required to be Join(B,...); in looking for the domains of B +-- we can find that if B has special value C, it can + systemError subargs + +sublisFormal(args,exp,:options) == main where + main == --use only on LIST structures; see also sublisFormalAlist + $formals: local := IFCAR options or $FormalMapVariableList + null args => exp + sublisFormal1(args,exp,#args - 1) + sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] + x is [.,:.] => + acc := nil + y := x + while null atom y repeat + acc := [sublisFormal1(args,QCAR y,n),:acc] + y := QCDR y + r := NREVERSE acc + if y then + nd := LASTNODE r + RPLACD(nd,sublisFormal1(args,y,n)) + r + IDENTP x => + j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => + args.j + x + x + +--======================================================================= +-- Build Table of Lower Case Constructor Names +--======================================================================= + +buildDefaultPackageNamesHT() == + $defaultPackageNamesHT := MAKE_-HASH_-TABLE() + for nam in allConstructors() | isDefaultPackageName nam repeat + HPUT($defaultPackageNamesHT,nam,true) + $defaultPackageNamesHT + +$defaultPackageNamesHT := buildDefaultPackageNamesHT() + +--======================================================================= +-- Code for Private Libdbs +--======================================================================= +-- $createLocalLibDb := false + +extendLocalLibdb conlist == -- called by astran + not $createLocalLibDb => nil + null conlist => nil + buildLibdb conlist --> puts datafile into temp.text + $newConstructorList := union(conlist, $newConstructorList) + localLibdb := '"libdb.text" + not PROBE_-FILE '"libdb.text" => + RENAME_-FILE('"temp.text",'"libdb.text") + oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) + newlines := dbReadLines '"temp.text" + dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text") + deleteFile '"temp.text" + +purgeLocalLibdb() == --used for debugging purposes only + $newConstructorList := nil + obey '"rm libdb.text" + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot deleted file mode 100644 index 4eedf3c9..00000000 --- a/src/interp/br-op1.boot +++ /dev/null @@ -1,1135 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-op1.boot <================================ - ---======================================================================= --- Operation Page Menu ---======================================================================= ---opAlist has form [[op,:alist],:.] where each alist --- has form [sig,pred,origin,exposeFlag,comments] - -dbFromConstructor?(htPage) == htpProperty(htPage,'conform) - -dbPresentOps(htPage,which,:exclusions) == - true => dbPresentOpsSaturn(htPage,which,exclusions) ---Flags: --- fromConPage?: came (originally) from a constructor page --- usage?: display usage? --- star?: display exposed/*=unexposed --- implementation?: display implementation? - htSay('"{\em Views:}") - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := $UserLevel = 'development and fromConPage? and which = '"operation" - and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - and not asharp? - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - tabs := - which = '"attribute" => '("12" "12" "25" "40" 13) - star? => '("12" "19" "31" "43" 10) - implementation? => '("9" "16" "28" "44" 9) - '("9" "16" "28" "41" 12) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - htTab - which = '"attribute" => tabs.1 - tabs.0 - if empty? or member('names,exclusions) or null KDR opAlist - then htSay '"{\em names}" - else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]] - if which ^= '"attribute" then - htTab tabs.1 - if empty? or member('signatures,exclusions) - then htSay '"{\em signatures}" - else htMakePage [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]] - htTab tabs.2 - if empty? or member('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSay '"{\em parameters}" - else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]] - htTab tabs.3 - if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage) - then - if htpProperty(htPage,'conform) - then htMakePage - [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]] - else htMakePage - [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]] - else - if empty? or MEMQ('usage,exclusions) or htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else - htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]] - htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]] - htSay('"\newline ") - if star? - then - if $exposedOnlyIfTrue - then htMakePage - [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]] --- else if (updown := dbCompositeWithMap htPage) --- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] - htTab tabs.0 - if usage? then - if empty? or member('usage,exclusions) or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category or HGET($defaultPackageNamesHT,conname) or htpProperty(htPage,'noUsage) - then htSay '"{\em usage}" - else htMakePage [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] - htTab tabs.1 - if empty? or member('origins,exclusions) - then htSay '"{\em origins}" - else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]] - htTab tabs.2 - if implementation? then - if member('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSay '"{\em implementation}" - else htMakePage [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] - else if empty? or member('conditions,exclusions) or (htpProperty(htPage,'condition?) = 'no) - then htSay '"{\em conditions}" - else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]] - htTab tabs.3 - if empty? or member('documentation,exclusions) - then htSay '"{\em description}" - else htMakePage [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]] - htShowPageNoScroll() - -htTab s == htSay('"\tab{",s,'"}") - -dbDoesOneOpHaveParameters? opAlist == - or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == - STRINGP x => dbPart(x,2,1) ^= '"0" - KAR x ---============================================================================ --- Master Switch Functions for Operation Views ---============================================================================ - -dbShowOps(htPage,which,key,:options) == - --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string - which := STRINGIMAGE which - if MEMQ(key,'(extended basic all)) then - $groupChoice := key - key := htpProperty(htPage,'key) or 'names - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) --- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) --- htpSetProperty(htPage,'opAlist,al) --- al - htpProperty(htPage,'attrAlist) - key = 'generalise => - arg := STRINGIMAGE CAAR opAlist - which = '"attribute" => aPage arg - oPage arg - key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) - key = 'filter => - --if $saturn, IFCAR options contains filter string - filter := IFCAR options or pmTransFilter(dbGetInputString htPage) - filter is ['error,:.] => bcErrorPage filter - opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] - null opAlist => emptySearchPage(which,filter) - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) - htpSetProperty(htPage,'key,key) - if MEMQ(key,'(exposureOn exposureOff)) then - $exposedOnlyIfTrue := - key = 'exposureOn => 'T - nil - key := htpProperty(htPage,'exclusion) - dbShowOp1(htPage,opAlist,which,key) - -reduceByGroup(htPage,opAlist) == - not dbFromConstructor?(htPage) or null $groupChoice => opAlist - dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) - bitNumber := HGET($topicHash,$groupChoice) - res := [[op,:newItems] for [op,:items] in opAlist | newItems] where - newItems == - null bitNumber => items - [x for x in items | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)] - res - - -dbShowOp1(htPage,opAlist,which,key) == - --set up for filtering below in dbGatherData - $which: local := which - if INTEGERP key then - opAlist := dbSelectData(htPage,opAlist,key) - ------> Jump out for constructor names in file <-------- - INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) - and constructor? con => return conPageChoose con - if INTEGERP key then - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - --opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...] - opAlist:=[item for [op,:items] in opAlist | item] where - item == - acc := nil - for x in items | x.3 repeat acc:= [x,:acc] - null acc => nil - [op,:NREVERSE acc] - $conformsAreDomains : local := htpProperty(htPage,'domname) - opCount := opAlistCount(opAlist, which) - branch := - INTEGERP key => - opCount <= $opDescriptionThreshold => 'documentation - 'names - key = 'names and null rest opAlist => --means a single op - opCount <= $opDescriptionThreshold => 'documentation - 'names - key - [what,whats,fn] := LASSOC(branch,$OpViewTable) - data := dbGatherData(htPage,opAlist,which,branch) - dataCount := +/[1 for x in data | (what = '"Name" and $exposedOnlyIfTrue => atom x; true)] - namedPart := - null rest opAlist => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - ['" {\em ",ops,'"}"] - nil - if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 - exposurePart := - $exposedOnlyIfTrue => '(" Exposed ") - nil - firstPart := - opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] - dataCount = 1 or dataCount = opCount => - opCount = 1 => [:exposurePart, capitalize which,:namedPart] - [STRINGIMAGE opCount,'" ",:exposurePart, - pluralize capitalize which,:namedPart] - prefix := pluralSay(dataCount,what,whats) - [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart] - page := htInitPageNoScroll(htCopyProplist htPage) - ------------>above line used to call htInitPageHoHeading<---------- - htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) - htpSetProperty(page,'data,data) - htpSetProperty(page,'branch,branch) - -- the only place where specialMessage property is set seems to be commented. out - if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) - htSayStandard('"\beginscroll ") - FUNCALL(fn,page,opAlist,which,data) --apply branch function - dbOpsExposureMessage() - htSayStandard("\endscroll ") - dbPresentOps(page,which,branch) - htShowPageNoScroll() - -opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == - null $exposedOnlyIfTrue or which = '"attribute" => #items - --count if unexpanded---CDDR(w) = nil---or if w.3 = true - +/[1 for w in items | null (p := CDDR w) or p . 1] - -dbShowOpHeading(heading, branch) == - suffix := --- branch = 'signatures => '" viewed as signatures" - branch = 'parameters => '" viewed with parameters" - branch = 'origins => '" organized by origins" - branch = 'conditions => '" organized by conditions" - '"" - [:heading, suffix] - -dbOpsExposureMessage() == - $atLeastOneUnexposed => htSay '"{\em *} = unexposed" - -fromHeading htPage == - null htPage => '"" - $pn := [htPage.0,'"}{"] - updomain := htpProperty(htPage,'updomain) => - dnForm := dbExtractUnderlyingDomain updomain - dnString:= form2StringList dnForm - dnFence := form2Fence dnForm --- upString:= form2StringList updomain - upFence := form2Fence updomain - upOp := PNAME opOf updomain - ['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"] - domname := htpProperty(htPage,'domname) - numberOfUnderlyingDomains := #[x for x in rest GETDATABASE(opOf domname,'COSIG) | x] --- numberOfUnderlyingDomains = 1 and --- KDR domname and (dn := dbExtractUnderlyingDomain domname) => --- ['" {\em from} ",:pickitForm(domname,dn)] - KDR domname => ['" {\em from} ",:dbConformGen domname] - htpProperty(htPage,'fromHeading) - -pickitForm(form,uarg) == - conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) - -conformString(form) == - KDR form => - conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil) - form2StringList form - -conform2StringList(form,opFn,argFn,exception) == - exception := exception or '"%%%nothing%%%" - [op1,:args] := form - op := IFCAR HGET($lowerCaseConTb,op1) or op1 - null args => APPLY(opFn,[op]) - special := MEMQ(op,'(Union Record Mapping)) - cosig := - special => ['T for x in args] - rest GETDATABASE(op,'COSIG) - atypes := - special => cosig - rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - keyword := - x is [":",y,t] => - x := t - y - nil - res := - x = exception => dbOpsForm exception - pred => - STRINGP x => [x] - u := APPLY(argFn,[x]) - atom u and [u] or u - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] - NUMBERP x or STRINGP x => [x] - systemError() - keyword => [keyword,'": ",:res] - res - op = 'Mapping => dbMapping2StringList sargl - head := - special => [op] - APPLY(opFn,[form]) - [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] - - -dbMapping2StringList [target,:sl] == - null sl => target - restPart := - null rest sl => nil - "append"/[[",",:y] for y in rest sl] - sourcePart := - restPart => ['"(",:first sl,:restPart,'")"] - first sl - [:sourcePart,'" -> ",:target] - -dbOuttran form == - if LISTP form then - [op,:args] := form - else - op := form - args := nil - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - argl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pred => x - typ := sublisFormal(args,atype) - arg := - x is ['QUOTE,a] => a - x - res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - NUMBERP res or STRINGP res => res - ['QUOTE,res] - [op,:argl] - -dbOpsForm form == ---one button for the operations of a type ---1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted ---2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) - ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] - -dbConform form == ---------------------> OBSELETE <-------------------------- ---one button for the main constructor page of a type ---NOTE: Next line should be as follows---but form2Fence form will --- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1 - $saturn => ["\conf{",:form2StringList opOf form, - '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"] - ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] ---["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"] - - -dbConformGen form == dbConformGen1(form,true) ---many buttons: one for the type and one for each inner type ---NOTE: must only be called on types KNOWN to be correct - -dbConformGenUnder form == dbConformGen1(form,false) ---same as above, except buttons only for the inner types - -dbConformGen1(form,opButton?) == - opFunction := - opButton? => FUNCTION dbConform - FUNCTION conname2StringList - originalOp := opOf form - op := unAbbreviateIfNecessary opOf form - args := IFCDR form - form := - originalOp=op => form - [op, :args] - args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) - APPLY(opFunction,[form]) - -unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op - -conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] - ---=========================================================================== --- Data Gathering Code ---============================================================================ -dbGatherData(htPage,opAlist,which,key) == - key = 'implementation => dbGatherDataImplementation(htPage,opAlist) - dataFunction := LASSOC(key,table) where - table == - $dbDataFunctionAlist or - ($dbDataFunctionAlist := [ - ['signatures,:function dbMakeSignature], - ['parameters,:function dbContrivedForm], - ['origins,:function dbGetOrigin], - ['domains,:function dbGetOrigin], - ['conditions,:function dbGetCondition]]) - null dataFunction => - --key= names or filter or documentation; do not expand - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := --to get indexing correct - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - acc := nil - initialExposure := - htPage and htpProperty(htPage,'conform) and which ^= '"package operation" - => true - --never star ops from a constructor - nil - for [op,:alist] in opAlist repeat - exposureFlag := initialExposure - while alist repeat - item := first alist - isExposed? := - STRINGP item => dbExposed?(item,char 'o) --unexpanded case - null (r := rest rest item) => true --assume true if unexpanded - r . 1 --expanded case - if isExposed? then return (exposureFlag := true) - alist := rest alist - node := - exposureFlag => op - [op,nil] - acc := [node,:acc] - NREVERSE acc - data := nil - dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false) - --create data, a list of the form ((entry,exposeFlag,:entries)...) - for [op,:alist] in opAlist repeat - for item in alist repeat - entry := FUNCALL(dataFunction,op,item)--get key item - exposeFlag := --is the current op-sig exposed? - null (r := rest rest item) => true --not given, assume yes - r . 1 --is given, use value - tail := - item is [.,'ASCONST,:.] => 'ASCONST - nil - newEntry := - u := ASSOC(entry,data) => --key seen before? look on DATA - RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed - u - data := [y := [entry,exposeFlag,:tail],:data] - y --no, create new entry in DATA - if member(key,'(origins conditions)) then - r := CDDR newEntry - if atom r then r := nil --clear out possible 'ASCONST - RPLACD(CDR newEntry, --store op/sigs under key if needed - insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) - if member(key,'(origins conditions)) then - for entry in data repeat --sort list of entries (after the 2nd) - tail := CDDR entry - tail := - atom tail => tail - listSort(function LEXLESSEQP,tail) - RPLACD(CDR entry,tail) - data := listSort(function LEXLESSEQP,data) - data - -dbGatherDataImplementation(htPage,opAlist) == ---returns data, of form ((implementor exposed? entry entry...)... --- where entry has form ((op sig . implementor) . stuff) - conform := htpProperty(htPage,'conform) - domainForm := htpProperty(htPage,'domname) - dom := EVAL domainForm - which := '"operation" - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) - --u has form ((op,sig,:implementor)...) - --sort into 4 groups: domain exports, unexports, default exports, others - - for (x := [.,.,:key]) in u for i in 0.. repeat - key = domainForm => domexports := [x,:domexports] - INTEGERP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant =>constants := [x,:constants] - others := [x,:others] --add chain domains go here - fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, - NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where - fn l == - alist := nil - for u in l repeat - while u repeat - key := CDDAR u --implementor - entries := - [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] - alist := [[key,gn key,:entries],:alist] - NREVERSE alist - gn key == - atom key => true - isExposedConstructor CAR key - -dbSelectData(htPage,opAlist,key) == - branch := htpProperty(htPage,'branch) - data := htpProperty(htPage,'data) - MEMQ(branch,'(signatures parameters)) => - dbReduceOpAlist(opAlist,data.key,branch) - MEMQ(branch,'(origins conditions implementation)) => - key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) - [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large - innerData := CDDR data.(newkey - 1) - dbReduceOpAlist(opAlist,innerData.binkey,'signatures) - [opAlist . key] - -dbReduceOpAlist(opAlist,data,branch) == - branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) - branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) - branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) - branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) - branch = 'parameters => dbReduceByForm(opAlist,CAR data) - systemError ['"Unexpected branch: ",branch] - -dbReduceByOpSignature(opAlist,datalist) == ---reduces opAlist by implementation datalist, one of the form --- (((op,sig,:implementor),:stuff),...) - ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] - acc := nil - for [op,:alist] in opAlist | MEMQ(op,ops) repeat - entryList := [entry for (entry := [sig,:.]) in alist | test] where test == - or/[x for x in datalist | x is [[=op,=sig,:.],:.]] - entryList => acc := [[op,:NREVERSE entryList],:acc] - NREVERSE acc - -dbReduceBySignature(opAlist,op,sig) == ---reduces opAlist to one with a fixed op and sig - [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] - -dbReduceByForm(opAlist,form) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | dbContrivedForm(op,x) = form] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbReduceBySelection(opAlist,key,fn) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | FUNCALL(fn,x) = key] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbContrivedForm(op,[sig,:.]) == - $which = '"attribute" => [op,sig] - dbMakeContrivedForm(op,sig) - -dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format - -dbGetOrigin(op,[.,.,origin,:.]) == origin - -dbGetCondition(op,[.,pred,:.]) == pred - ---dbInsertOpAlist(op,item,opAlist) == --- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) - ---dbSortOpAlist opAlist == --- [[op,:listSort(function LEXLESSEQP,alist)] --- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] - ---============================================================================ --- Branches of Views ---============================================================================ -dbShowOpNames(htPage,opAlist,which,data) == - single? := opAlist and null rest data - single? => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - htSayStandard('"Select a view below") - htSaySaturn '"Select a view with the right mouse button" - exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) - dbShowOpItems(which,data,exposedOnly?) - -dbShowOpItems(which,data,exposedOnly?) == - htBeginTable() - firstTime := true - for i in 0.. for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - if atom item then - op := item - exposeFlag := true - else - [op,exposeFlag] := item - ops := escapeSpecialChars STRINGIMAGE op - exposeFlag or not exposedOnly? => - htSay('"{") - bcStarSpaceOp(ops,exposeFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] - htSay('"}") - htEndTable() - -dbShowOpAllDomains(htPage,opAlist,which) == - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - catOriginAlist := nil --list of category origins - domOriginAlist := nil --list of domain origins - for [op,:items] in opAlist repeat - for [.,predicate,origin,:.] in items repeat - conname := CAR origin - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) - catOriginAlist := insertAlist(conname,pred,catOriginAlist) - pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) - domOriginAlist := insertAlist(conname,pred,domOriginAlist) - --the following is similar to "domainsOf" but do not sort immediately - u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* - | LASSQ(CDR key,catOriginAlist)] - for pair in u repeat - [dom,:cat] := pair - LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) - RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) - --now add all of the domains - for [dom,:pred] in domOriginAlist repeat - u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) - cAlist := listSort(function GLESSEQP,u) - for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"constructor") - htpSetProperty(htPage,'specialHeading,'"hoho") - dbShowCons(htPage,'names) - -simpOrDumb(new,old) == - new = 'etc => 'etc - atom new => old - 'etc - -dbShowOpOrigins(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform) - -dbShowOpImplementations(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) - -dbShowOpConditions(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) - -dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == ------------------> OBSELETE - single? := null rest data - htSay('"\beginmenu ") - bincount := 0 - for [thing,exposeFlag,:items] in data repeat - htSay('"\item ") - if single? then htSay(menuButton()) - else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] - htSay '"{\em " - htSay - thing = 'nowhere => '"implemented nowhere" - thing = 'constant => '"constant" - thing = '_$ => '"by the domain" - INTEGERP thing => '"unexported" - constructorIfTrue => - htSay word - atom thing => '" an unknown constructor" - '"" - atom thing => '"unconditional" - '"" - htSay '"}" - if null atom thing then - if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") - htSay '" " - FUNCALL(fn,thing) - htSay('":\newline ") - dbShowOpSigList(which,items,(1 + bincount) * 8192) - bincount := bincount + 1 - htSay '"\endmenu " - -dbShowKind conform == - conname := CAR conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - kind = 'domain => - (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" - '"domain" - PNAME kind - -dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) - -dbShowOpSigList(which,dataItems,count) == ---dataItems is (((op,sig,:.),exposureFlag,...) - single? := null rest dataItems - htBeginTable() - firstTime := true - for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat - if firstTime then firstTime := false - else htSaySaturn '"&"; - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" --- if single? then htSay('"{\em ",ops,'"}") else..... - htSayExpose(ops,exposureFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - if which = '"attribute" then htSay args2HtString (sig and [sig]) else - htSay '": " - tail = 'ASCONST => bcConform first sig - bcConform ['Mapping,:sig] - htSay '"}" - count := count + 1 - htEndTable() - count - -dbShowOpParameters(htPage,opAlist,which,data) == - single? := null rest data - count := 0 - htBeginTable() - firstTime := true - for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - [opform,exposeFlag,:tail] := item - op := intern IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" - htSayExpose(ops,exposeFlag) - n := #opform - do - n = 2 and LASSOC('Nud,PROPLIST op) => - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => - htSay('"{\em ",KAR args,'"} ") - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR KDR args,'"}") - dbShowOpParameterJump(ops,which,count,single?) - tail = 'ASCONST or member(op,'(0 1)) or which = '"attribute" and null IFCAR args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",x,'"}") - htSay('")") - htSay '"}" - count := count + 1 - htEndTable() - -dbShowOpParameterJump(ops,which,count,single?) == - single? => htSay('"{\em ",ops,'"}") - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - -dbShowOpDocumentation(htPage,opAlist,which,data) == - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - --NOTE: this line is necessary to get indexing right. - --The test below for $exposedOnlyIfTrue causes unexposed items - --to be skipped. - newWhich := - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - which = '"package operation" => '"operation" - which - expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if expand then - condata := dbGatherData(htPage,opAlist,which,'conditions) - htpSetProperty(htPage,'conditionData,condata) - base := -8192 - exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp - htSaySaturn '"\begin{description}" - for [op,:alist] in opAlist repeat - base := 8192 + base - for item in alist for j in 0.. repeat - [sig,predicate,origin,exposeFlag,comments] := item - exposeFlag or not $exposedOnlyIfTrue => - if comments ^= '"" and STRINGP comments and (k := string2Integer comments) then - comments := - MEMQ(k,'(0 1)) => '"" - dbReadComments k - tail := CDDDDR item - RPLACA(tail,comments) - doc := (STRINGP comments and comments ^= '"" => comments; nil) - pred := predicate or true - index := (exactlyOneOpSig => nil; base + j) - if which = '"package operation" then - sig := SUBST(conform,'_$,sig) - origin := SUBST(conform,'_$,origin) - displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,index,'dbChooseDomainOp,null exposeFlag,true) - htSaySaturn '"\end{description}" - -dbChooseDomainOp(htPage,which,index) == - [opKey,entryKey] := DIVIDE(index,8192) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - [op,:entries] := opAlist . opKey - entry := entries . entryKey - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,[[op,entry]]) - else htpSetProperty(htPage,'attrAlist,[[op,entry]]) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,'documentation) - -htSayExpose(op,flag) == - $includeUnexposed? => - flag => htBlank() - op.0 = char '_* => htSay '"{\em *} " - htSayUnexposed() - htSay '"" ---============================================================================ --- Branch-in From Other Places ---============================================================================ -dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists - $groupChoice := nil - conform := htpProperty(htPage,'conform) - --prepare opAlist for possible filtering of groups - if null BOUNDP '$topicHash then - $topicHash := MAKE_-HASHTABLE 'ID - for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat - HPUT($topicHash,x,c) - if domform := htpProperty(htPage,'domname) then - $conformsAreDomains : local := true - reduceOpAlistForDomain(opAlist,domform,conform) - conform := domform or conform - kind := capitalize htpProperty(htPage,'kind) - exposePart := - isExposedConstructor opOf conform => '"" - '" Unexposed " - fromPart := - domform => evalableConstructor2HtString domform - form2HtString conform - heading := - ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'lists) - htpSetProperty(htPage,'fromHeading,heading) - reducedOpAlist := - which = '"operation" => reduceByGroup(htPage,opAlist) - opAlist - if which = '"operation" - then - htpSetProperty(htPage,'principalOpAlist,opAlist) - htpSetProperty(htPage,'opAlist,reducedOpAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if domform - then htpSetProperty(htPage,'condition?,'no) - else dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOp1(htPage,reducedOpAlist,which,'names) - -reduceOpAlistForDomain(opAlist,domform,conform) == ---destructively simplify all predicates; filter out any that fail - form1 := [domform,:rest domform] - form2 := ['$,:rest conform] - for pair in opAlist repeat - RPLACD(pair,[test for item in rest pair | test]) where test == - [head,:tail] := item - CAR tail = true => item - pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) - null pred => false - RPLACD(item,[pred]) - item - opAlist - -dbShowOperationLines(which,linelist) == --branch in with lines - htPage := htInitPage(nil,nil) --create empty page - opAlist := nil - lines := linelist - while lines repeat - name := dbName (x := first lines) - pile := [x] - while (lines := rest lines) and name = dbName (x := first lines) repeat - pile := [x,:pile] - opAlist := [[name,:NREVERSE pile],:opAlist] - opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'strings) - dbResetOpAlistCondition(htPage,which,opAlist) - if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then - --code needed to handle commutative("*"); called from aPage - --must completely expand the opAlist then check for those with - --arguments equal to $attributeArgs - --here: opAlist is [[op,:itemlist]] - dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) - opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | first item = $attributeArgs]]] - dbShowOp1(htPage,opAlist,which,'names) - ---============================================================================ --- Code to Expand opAlist ---============================================================================ -dbResetOpAlistCondition(htPage,which,opAlist) == - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbSetOpAlistCondition(htPage,opAlist,which) == ---called whenever a new opAlist is needed ---property can only be inherited if 'no (a subset says NO if whole says NO) - condition := htpProperty(htPage,'condition?) - MEMQ(condition,'(yes no)) => condition = 'yes - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == ---if condition? = true, stop when you find a non-trivial predicate ---otherwise, expand in full ---RETURNS: --- non-trivial predicate, if condition? = true and it finds one --- nil, otherwise ---SIDE-EFFECT: this function references the "expand" property (set elsewhere): --- 'strings, if not fully expanded and it contains strings --- i.e. opAlist is ((op . (string ...))...) if unexpanded --- 'lists, if not fully expanded and it contains lists --- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded - condition? := condition? and not $exposedOnlyIfTrue - value := nil --return value - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - expandFlag := htpProperty(htPage,expandProperty) - expandFlag = 'fullyExpanded => nil - expandFlag = 'strings => --strings are partially expanded - for pair in opAlist repeat - [op,:lines] := pair - acc := nil - for line in lines repeat - --NOTE: we must expand all lines here for a given op - -- since below we will change opAlist - --Case 1: Already expanded; just cons it onto ACC - null STRINGP line => --already expanded - if condition? then --this could have been expanded at a lower level - if null atom (pred := CADR line) then value := pred - acc := [line,:acc] --this one is already expanded; record it anyway - --Case 2: unexpanded; expand it then cons it onto ACC - [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) - predicate := ncParseFromString pred - if condition? and null atom predicate then value := predicate - sig := ncParseFromString sigs --is (Mapping,:.) - if which = '"operation" then - if sig isnt ['Mapping,:.] - then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] - else sig := rest sig - conname := intern dbNewConname line - origin := [conname,:getConstructorArgs conname] - exposeFlag := dbExposed?(line,char 'o) - acc := [[sig,predicate,origin,exposeFlag,comments],:acc] - --always store the fruits of our labor: - RPLACD(pair,NREVERSE acc) --at least partially expand it - condition? and value => return value --early exit - value => value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - expandFlag = 'lists => --lists are partially expanded - -- entry is [sig, predicate, origin, exposeFlag, comments] - $value: local := nil - $docTableHash := MAKE_-HASHTABLE 'EQUAL - packageSymbol := false - domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - if isDefaultPackageName opOf domform then - catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) - packageSymbol := first rest domform - domform := [catname,:rest rest domform] --skip first argument ($) - docTable:= dbDocTable domform - for [op,:alist] in opAlist repeat - for [sig,:tail] in alist repeat - condition? => --the only purpose here is to find a non-trivial pred - null atom (pred := CAR tail) => return ($value := pred) - 'skip - u := - tail is [.,origin,:.] and origin => --- must change any % into $ otherwise we will not pick up comments properly --- delete the SUBLISLIS when we fix on % or $ - dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,which,nil) - if packageSymbol then sig := SUBST('_$,packageSymbol,sig) - dbGetDocTable(op,sig,docTable,which,nil) - origin := IFCAR u or origin - docCode := IFCDR u --> (doc . code) --- if null FIXP CDR docCode then harhar(op) --> - if null doc and which = '"attribute" then doc := getRegistry(op,sig) - RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) - $value => return $value - $value => $value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - 'done - -getRegistry(op,sig) == - u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) - v := LASSOC(op,u) - match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match - '"" - -evalableConstructor2HtString domform == - if VECP domform then domform := devaluate domform - conname := first domform - coSig := rest GETDATABASE(conname,'COSIG) - --entries are T for arguments which are domains; NIL for computational objects - and/[x for x in coSig] => form2HtString(domform,nil,true) - arglist := [unquote x for x in rest domform] where - unquote arg == - arg is [f,:args] => - f = 'QUOTE => first args - [f,:[unquote x for x in args]] - arg - fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) ---argtypes:= sublisFormal(arglist,fargtypes) - form2HtString([conname,:[fn for arg in arglist for x in coSig - for ftype in fargtypes]],nil,true) where - fn == - x => arg - typ := sublisFormal(arglist,ftype) - mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - -mathform2HtString form == escapeString - $fortInts2Floats: local := false - form := niladicHack form - form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) - form is ['BRACKET,['AGGLST,:arg]] => - if arg is ['construct,:r] then arg := r - arg := - atom arg => [arg] - [y for x in arg | y := (x is ['QUOTE,a] => a; x)] - tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] - STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") - form is ['BRACKET,['AGGLST,'QUOTE,arg]] => - if atom arg then arg := [arg] - tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] - STRCONC('"[",first arg,tailPart,'"]") - atom form => form - "STRCONC"/fortexp0 form - -niladicHack form == - atom form => form - form is [x] and GETL(x,'NILADIC) => x - [niladicHack x for x in form] - ---============================================================================ --- Getting Operations from Domain ---============================================================================ - -getDomainOpTable(dom,fromIfTrue,:options) == - ops := KAR options - $predEvalAlist : local := nil - $returnNowhereFromGoGet: local := true - domname := dom.0 - conname := CAR domname - abb := getConstructorAbbreviation conname - opAlist := getOperationAlistFromLisplib conname - "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u - | key ^= 'Subsumed and ((null ops and (op1 := op)) or (op1 := memq(op,ops)))] - for [op,:u] in opAlist] where - memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One - MEMQ(op,ops) => op - EQ(op,'One) => MEMQ(1,ops) and 1 - EQ(op,'Zero) => MEMQ(0,ops) and 0 - false - fn == - sig1 := sublisFormal(rest domname,sig) - predValue := evalDomainOpPred(dom,pred) - info := - null predValue => - 1 -- signifies not exported - null fromIfTrue => nil - cell := compiledLookup(op,sig1,dom) => - [f,:r] := cell - f = 'nowhere => 'nowhere --see replaceGoGetSlot - f = 'makeSpadConstant => 'constant - f = function IDENTITY => 'constant - f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) - null VECP r => systemError devaluateList r - SUBST('_$,domname,devaluate r) - 'nowhere - [sig1,:info] - -evalDomainOpPred(dom,pred) == process(dom,pred) where - process(dom,pred) == - u := convert(dom,pred) - u = 'T => true - evpred(dom,u) - convert(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] - MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] - MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] - op = 'has => - [arg,p] := argl - p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] - ['HasCategory,arg,convertCatArg p] - systemError '"unknown predicate form" - pred = 'T => true - systemError nil - convertCatArg p == - atom p or #p = 1 => MKQ p - ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] - evpred(dom,pred) == - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - evpred1(dom,pred) - evpred1(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] - MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] - op = 'NOT => not evpred1(dom,first argl) - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - op = 'HasAttribute => - [arg,[.,a]] := argl - attPredIndex := LASSOC(a,dom.2) - null attPredIndex => nil - attPredIndex = 0 => true - testBitVector(dom.3,attPredIndex) - nil - pred = 'T => true - systemError '"unknown atomic predicate form" - - diff --git a/src/interp/br-op1.boot.pamphlet b/src/interp/br-op1.boot.pamphlet new file mode 100644 index 00000000..aea5b89b --- /dev/null +++ b/src/interp/br-op1.boot.pamphlet @@ -0,0 +1,1161 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-op1.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS b-op1.boot <================================ + +--======================================================================= +-- Operation Page Menu +--======================================================================= +--opAlist has form [[op,:alist],:.] where each alist +-- has form [sig,pred,origin,exposeFlag,comments] + +dbFromConstructor?(htPage) == htpProperty(htPage,'conform) + +dbPresentOps(htPage,which,:exclusions) == + true => dbPresentOpsSaturn(htPage,which,exclusions) +--Flags: +-- fromConPage?: came (originally) from a constructor page +-- usage?: display usage? +-- star?: display exposed/*=unexposed +-- implementation?: display implementation? + htSay('"{\em Views:}") + asharp? := htpProperty(htPage,'isAsharpConstructor) + fromConPage? := (conname := opOf htpProperty(htPage,'conform)) + usage? := $UserLevel = 'development and fromConPage? and which = '"operation" + and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + and not asharp? + star? := not fromConPage? or which = '"package operation" + implementation? := not asharp? and + $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? + rightmost? := star? or (implementation? and not $includeUnexposed?) + tabs := + which = '"attribute" => '("12" "12" "25" "40" 13) + star? => '("12" "19" "31" "43" 10) + implementation? => '("9" "16" "28" "44" 9) + '("9" "16" "28" "41" 12) + if INTEGERP first exclusions then exclusions := ['documentation] + htpSetProperty(htPage,'exclusion,first exclusions) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + empty? := null opAlist + htTab + which = '"attribute" => tabs.1 + tabs.0 + if empty? or member('names,exclusions) or null KDR opAlist + then htSay '"{\em names}" + else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]] + if which ^= '"attribute" then + htTab tabs.1 + if empty? or member('signatures,exclusions) + then htSay '"{\em signatures}" + else htMakePage [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]] + htTab tabs.2 + if empty? or member('parameters,exclusions) --also test for some parameter + or not dbDoesOneOpHaveParameters? opAlist + then htSay '"{\em parameters}" + else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]] + htTab tabs.3 + if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage) + then + if htpProperty(htPage,'conform) + then htMakePage + [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]] + else htMakePage + [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]] + else + if empty? or MEMQ('usage,exclusions) or htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else + htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]] + htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]] + htSay('"\newline ") + if star? + then + if $exposedOnlyIfTrue + then htMakePage + [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]] + else + htSay('"*{\em =}") + htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]] +-- else if (updown := dbCompositeWithMap htPage) +-- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] + htTab tabs.0 + if usage? then + if empty? or member('usage,exclusions) or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category or HGET($defaultPackageNamesHT,conname) or htpProperty(htPage,'noUsage) + then htSay '"{\em usage}" + else htMakePage [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] + htTab tabs.1 + if empty? or member('origins,exclusions) + then htSay '"{\em origins}" + else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]] + htTab tabs.2 + if implementation? then + if member('implementation,exclusions) or which = '"attribute" or + ((conname := opOf htpProperty(htPage,'conform)) and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + then htSay '"{\em implementation}" + else htMakePage [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] + else if empty? or member('conditions,exclusions) or (htpProperty(htPage,'condition?) = 'no) + then htSay '"{\em conditions}" + else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]] + htTab tabs.3 + if empty? or member('documentation,exclusions) + then htSay '"{\em description}" + else htMakePage [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]] + htShowPageNoScroll() + +htTab s == htSay('"\tab{",s,'"}") + +dbDoesOneOpHaveParameters? opAlist == + or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == + STRINGP x => dbPart(x,2,1) ^= '"0" + KAR x +--============================================================================ +-- Master Switch Functions for Operation Views +--============================================================================ + +dbShowOps(htPage,which,key,:options) == + --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string + which := STRINGIMAGE which + if MEMQ(key,'(extended basic all)) then + $groupChoice := key + key := htpProperty(htPage,'key) or 'names + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) +-- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) +-- htpSetProperty(htPage,'opAlist,al) +-- al + htpProperty(htPage,'attrAlist) + key = 'generalise => + arg := STRINGIMAGE CAAR opAlist + which = '"attribute" => aPage arg + oPage arg + key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) + key = 'filter => + --if $saturn, IFCAR options contains filter string + filter := IFCAR options or pmTransFilter(dbGetInputString htPage) + filter is ['error,:.] => bcErrorPage filter + opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] + null opAlist => emptySearchPage(which,filter) + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) + htpSetProperty(htPage,'key,key) + if MEMQ(key,'(exposureOn exposureOff)) then + $exposedOnlyIfTrue := + key = 'exposureOn => 'T + nil + key := htpProperty(htPage,'exclusion) + dbShowOp1(htPage,opAlist,which,key) + +reduceByGroup(htPage,opAlist) == + not dbFromConstructor?(htPage) or null $groupChoice => opAlist + dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) + bitNumber := HGET($topicHash,$groupChoice) + res := [[op,:newItems] for [op,:items] in opAlist | newItems] where + newItems == + null bitNumber => items + [x for x in items | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)] + res + + +dbShowOp1(htPage,opAlist,which,key) == + --set up for filtering below in dbGatherData + $which: local := which + if INTEGERP key then + opAlist := dbSelectData(htPage,opAlist,key) + ------> Jump out for constructor names in file <-------- + INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) + and constructor? con => return conPageChoose con + if INTEGERP key then + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + --opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...] + opAlist:=[item for [op,:items] in opAlist | item] where + item == + acc := nil + for x in items | x.3 repeat acc:= [x,:acc] + null acc => nil + [op,:NREVERSE acc] + $conformsAreDomains : local := htpProperty(htPage,'domname) + opCount := opAlistCount(opAlist, which) + branch := + INTEGERP key => + opCount <= $opDescriptionThreshold => 'documentation + 'names + key = 'names and null rest opAlist => --means a single op + opCount <= $opDescriptionThreshold => 'documentation + 'names + key + [what,whats,fn] := LASSOC(branch,$OpViewTable) + data := dbGatherData(htPage,opAlist,which,branch) + dataCount := +/[1 for x in data | (what = '"Name" and $exposedOnlyIfTrue => atom x; true)] + namedPart := + null rest opAlist => + ops := escapeSpecialChars STRINGIMAGE CAAR opAlist + ['" {\em ",ops,'"}"] + nil + if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 + exposurePart := + $exposedOnlyIfTrue => '(" Exposed ") + nil + firstPart := + opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] + dataCount = 1 or dataCount = opCount => + opCount = 1 => [:exposurePart, capitalize which,:namedPart] + [STRINGIMAGE opCount,'" ",:exposurePart, + pluralize capitalize which,:namedPart] + prefix := pluralSay(dataCount,what,whats) + [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart] + page := htInitPageNoScroll(htCopyProplist htPage) + ------------>above line used to call htInitPageHoHeading<---------- + htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) + htpSetProperty(page,'data,data) + htpSetProperty(page,'branch,branch) + -- the only place where specialMessage property is set seems to be commented. out + if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) + htSayStandard('"\beginscroll ") + FUNCALL(fn,page,opAlist,which,data) --apply branch function + dbOpsExposureMessage() + htSayStandard("\endscroll ") + dbPresentOps(page,which,branch) + htShowPageNoScroll() + +opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == + null $exposedOnlyIfTrue or which = '"attribute" => #items + --count if unexpanded---CDDR(w) = nil---or if w.3 = true + +/[1 for w in items | null (p := CDDR w) or p . 1] + +dbShowOpHeading(heading, branch) == + suffix := +-- branch = 'signatures => '" viewed as signatures" + branch = 'parameters => '" viewed with parameters" + branch = 'origins => '" organized by origins" + branch = 'conditions => '" organized by conditions" + '"" + [:heading, suffix] + +dbOpsExposureMessage() == + $atLeastOneUnexposed => htSay '"{\em *} = unexposed" + +fromHeading htPage == + null htPage => '"" + $pn := [htPage.0,'"}{"] + updomain := htpProperty(htPage,'updomain) => + dnForm := dbExtractUnderlyingDomain updomain + dnString:= form2StringList dnForm + dnFence := form2Fence dnForm +-- upString:= form2StringList updomain + upFence := form2Fence updomain + upOp := PNAME opOf updomain + ['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"] + domname := htpProperty(htPage,'domname) + numberOfUnderlyingDomains := #[x for x in rest GETDATABASE(opOf domname,'COSIG) | x] +-- numberOfUnderlyingDomains = 1 and +-- KDR domname and (dn := dbExtractUnderlyingDomain domname) => +-- ['" {\em from} ",:pickitForm(domname,dn)] + KDR domname => ['" {\em from} ",:dbConformGen domname] + htpProperty(htPage,'fromHeading) + +pickitForm(form,uarg) == + conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) + +conformString(form) == + KDR form => + conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil) + form2StringList form + +conform2StringList(form,opFn,argFn,exception) == + exception := exception or '"%%%nothing%%%" + [op1,:args] := form + op := IFCAR HGET($lowerCaseConTb,op1) or op1 + null args => APPLY(opFn,[op]) + special := MEMQ(op,'(Union Record Mapping)) + cosig := + special => ['T for x in args] + rest GETDATABASE(op,'COSIG) + atypes := + special => cosig + rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == + keyword := + x is [":",y,t] => + x := t + y + nil + res := + x = exception => dbOpsForm exception + pred => + STRINGP x => [x] + u := APPLY(argFn,[x]) + atom u and [u] or u + typ := sublisFormal(args,atype) + if x is ['QUOTE,a] then x := a + u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] + NUMBERP x or STRINGP x => [x] + systemError() + keyword => [keyword,'": ",:res] + res + op = 'Mapping => dbMapping2StringList sargl + head := + special => [op] + APPLY(opFn,[form]) + [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] + + +dbMapping2StringList [target,:sl] == + null sl => target + restPart := + null rest sl => nil + "append"/[[",",:y] for y in rest sl] + sourcePart := + restPart => ['"(",:first sl,:restPart,'")"] + first sl + [:sourcePart,'" -> ",:target] + +dbOuttran form == + if LISTP form then + [op,:args] := form + else + op := form + args := nil + cosig := rest GETDATABASE(op,'COSIG) + atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + argl := [fn for x in args for atype in atypes for pred in cosig] where fn == + pred => x + typ := sublisFormal(args,atype) + arg := + x is ['QUOTE,a] => a + x + res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) + NUMBERP res or STRINGP res => res + ['QUOTE,res] + [op,:argl] + +dbOpsForm form == +--one button for the operations of a type +--1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted +--2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) + ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] + +dbConform form == +--------------------> OBSELETE <-------------------------- +--one button for the main constructor page of a type +--NOTE: Next line should be as follows---but form2Fence form will +-- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1 + $saturn => ["\conf{",:form2StringList opOf form, + '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"] + ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] +--["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"] + + +dbConformGen form == dbConformGen1(form,true) +--many buttons: one for the type and one for each inner type +--NOTE: must only be called on types KNOWN to be correct + +dbConformGenUnder form == dbConformGen1(form,false) +--same as above, except buttons only for the inner types + +dbConformGen1(form,opButton?) == + opFunction := + opButton? => FUNCTION dbConform + FUNCTION conname2StringList + originalOp := opOf form + op := unAbbreviateIfNecessary opOf form + args := IFCDR form + form := + originalOp=op => form + [op, :args] + args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) + APPLY(opFunction,[form]) + +unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op + +conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] + +--=========================================================================== +-- Data Gathering Code +--============================================================================ +dbGatherData(htPage,opAlist,which,key) == + key = 'implementation => dbGatherDataImplementation(htPage,opAlist) + dataFunction := LASSOC(key,table) where + table == + $dbDataFunctionAlist or + ($dbDataFunctionAlist := [ + ['signatures,:function dbMakeSignature], + ['parameters,:function dbContrivedForm], + ['origins,:function dbGetOrigin], + ['domains,:function dbGetOrigin], + ['conditions,:function dbGetCondition]]) + null dataFunction => + --key= names or filter or documentation; do not expand + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + opAlist := --to get indexing correct + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + acc := nil + initialExposure := + htPage and htpProperty(htPage,'conform) and which ^= '"package operation" + => true + --never star ops from a constructor + nil + for [op,:alist] in opAlist repeat + exposureFlag := initialExposure + while alist repeat + item := first alist + isExposed? := + STRINGP item => dbExposed?(item,char 'o) --unexpanded case + null (r := rest rest item) => true --assume true if unexpanded + r . 1 --expanded case + if isExposed? then return (exposureFlag := true) + alist := rest alist + node := + exposureFlag => op + [op,nil] + acc := [node,:acc] + NREVERSE acc + data := nil + dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false) + --create data, a list of the form ((entry,exposeFlag,:entries)...) + for [op,:alist] in opAlist repeat + for item in alist repeat + entry := FUNCALL(dataFunction,op,item)--get key item + exposeFlag := --is the current op-sig exposed? + null (r := rest rest item) => true --not given, assume yes + r . 1 --is given, use value + tail := + item is [.,'ASCONST,:.] => 'ASCONST + nil + newEntry := + u := ASSOC(entry,data) => --key seen before? look on DATA + RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed + u + data := [y := [entry,exposeFlag,:tail],:data] + y --no, create new entry in DATA + if member(key,'(origins conditions)) then + r := CDDR newEntry + if atom r then r := nil --clear out possible 'ASCONST + RPLACD(CDR newEntry, --store op/sigs under key if needed + insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) + if member(key,'(origins conditions)) then + for entry in data repeat --sort list of entries (after the 2nd) + tail := CDDR entry + tail := + atom tail => tail + listSort(function LEXLESSEQP,tail) + RPLACD(CDR entry,tail) + data := listSort(function LEXLESSEQP,data) + data + +dbGatherDataImplementation(htPage,opAlist) == +--returns data, of form ((implementor exposed? entry entry...)... +-- where entry has form ((op sig . implementor) . stuff) + conform := htpProperty(htPage,'conform) + domainForm := htpProperty(htPage,'domname) + dom := EVAL domainForm + which := '"operation" + [nam,:$domainArgs] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + predVector := dom.3 + u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) + --u has form ((op,sig,:implementor)...) + --sort into 4 groups: domain exports, unexports, default exports, others + + for (x := [.,.,:key]) in u for i in 0.. repeat + key = domainForm => domexports := [x,:domexports] + INTEGERP key => unexports := [x,:unexports] + isDefaultPackageForm? key => defexports := [x,:defexports] + key = 'nowhere => nowheres := [x,:nowheres] + key = 'constant =>constants := [x,:constants] + others := [x,:others] --add chain domains go here + fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, + NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where + fn l == + alist := nil + for u in l repeat + while u repeat + key := CDDAR u --implementor + entries := + [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] + alist := [[key,gn key,:entries],:alist] + NREVERSE alist + gn key == + atom key => true + isExposedConstructor CAR key + +dbSelectData(htPage,opAlist,key) == + branch := htpProperty(htPage,'branch) + data := htpProperty(htPage,'data) + MEMQ(branch,'(signatures parameters)) => + dbReduceOpAlist(opAlist,data.key,branch) + MEMQ(branch,'(origins conditions implementation)) => + key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) + [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large + innerData := CDDR data.(newkey - 1) + dbReduceOpAlist(opAlist,innerData.binkey,'signatures) + [opAlist . key] + +dbReduceOpAlist(opAlist,data,branch) == + branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) + branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) + branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) + branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) + branch = 'parameters => dbReduceByForm(opAlist,CAR data) + systemError ['"Unexpected branch: ",branch] + +dbReduceByOpSignature(opAlist,datalist) == +--reduces opAlist by implementation datalist, one of the form +-- (((op,sig,:implementor),:stuff),...) + ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] + acc := nil + for [op,:alist] in opAlist | MEMQ(op,ops) repeat + entryList := [entry for (entry := [sig,:.]) in alist | test] where test == + or/[x for x in datalist | x is [[=op,=sig,:.],:.]] + entryList => acc := [[op,:NREVERSE entryList],:acc] + NREVERSE acc + +dbReduceBySignature(opAlist,op,sig) == +--reduces opAlist to one with a fixed op and sig + [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] + +dbReduceByForm(opAlist,form) == + acc := nil + for [op,:alist] in opAlist repeat + items := [x for x in alist | dbContrivedForm(op,x) = form] => + acc := [[op,:items],:acc] + NREVERSE acc + +dbReduceBySelection(opAlist,key,fn) == + acc := nil + for [op,:alist] in opAlist repeat + items := [x for x in alist | FUNCALL(fn,x) = key] => + acc := [[op,:items],:acc] + NREVERSE acc + +dbContrivedForm(op,[sig,:.]) == + $which = '"attribute" => [op,sig] + dbMakeContrivedForm(op,sig) + +dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format + +dbGetOrigin(op,[.,.,origin,:.]) == origin + +dbGetCondition(op,[.,pred,:.]) == pred + +--dbInsertOpAlist(op,item,opAlist) == +-- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) + +--dbSortOpAlist opAlist == +-- [[op,:listSort(function LEXLESSEQP,alist)] +-- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] + +--============================================================================ +-- Branches of Views +--============================================================================ +dbShowOpNames(htPage,opAlist,which,data) == + single? := opAlist and null rest data + single? => + ops := escapeSpecialChars STRINGIMAGE CAAR opAlist + htSayStandard('"Select a view below") + htSaySaturn '"Select a view with the right mouse button" + exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) + dbShowOpItems(which,data,exposedOnly?) + +dbShowOpItems(which,data,exposedOnly?) == + htBeginTable() + firstTime := true + for i in 0.. for item in data repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + if atom item then + op := item + exposeFlag := true + else + [op,exposeFlag] := item + ops := escapeSpecialChars STRINGIMAGE op + exposeFlag or not exposedOnly? => + htSay('"{") + bcStarSpaceOp(ops,exposeFlag) + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] + htSay('"}") + htEndTable() + +dbShowOpAllDomains(htPage,opAlist,which) == + dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + catOriginAlist := nil --list of category origins + domOriginAlist := nil --list of domain origins + for [op,:items] in opAlist repeat + for [.,predicate,origin,:.] in items repeat + conname := CAR origin + GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) + catOriginAlist := insertAlist(conname,pred,catOriginAlist) + pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) + domOriginAlist := insertAlist(conname,pred,domOriginAlist) + --the following is similar to "domainsOf" but do not sort immediately + u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* + | LASSQ(CDR key,catOriginAlist)] + for pair in u repeat + [dom,:cat] := pair + LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) + RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) + --now add all of the domains + for [dom,:pred] in domOriginAlist repeat + u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) + cAlist := listSort(function GLESSEQP,u) + for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,'"constructor") + htpSetProperty(htPage,'specialHeading,'"hoho") + dbShowCons(htPage,'names) + +simpOrDumb(new,old) == + new = 'etc => 'etc + atom new => old + 'etc + +dbShowOpOrigins(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform) + +dbShowOpImplementations(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) + +dbShowOpConditions(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) + +dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == +-----------------> OBSELETE + single? := null rest data + htSay('"\beginmenu ") + bincount := 0 + for [thing,exposeFlag,:items] in data repeat + htSay('"\item ") + if single? then htSay(menuButton()) + else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] + htSay '"{\em " + htSay + thing = 'nowhere => '"implemented nowhere" + thing = 'constant => '"constant" + thing = '_$ => '"by the domain" + INTEGERP thing => '"unexported" + constructorIfTrue => + htSay word + atom thing => '" an unknown constructor" + '"" + atom thing => '"unconditional" + '"" + htSay '"}" + if null atom thing then + if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") + htSay '" " + FUNCALL(fn,thing) + htSay('":\newline ") + dbShowOpSigList(which,items,(1 + bincount) * 8192) + bincount := bincount + 1 + htSay '"\endmenu " + +dbShowKind conform == + conname := CAR conform + kind := GETDATABASE(conname,'CONSTRUCTORKIND) + kind = 'domain => + (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" + '"domain" + PNAME kind + +dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) + +dbShowOpSigList(which,dataItems,count) == +--dataItems is (((op,sig,:.),exposureFlag,...) + single? := null rest dataItems + htBeginTable() + firstTime := true + for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat + if firstTime then firstTime := false + else htSaySaturn '"&"; + ops := escapeSpecialChars STRINGIMAGE op + htSay '"{" +-- if single? then htSay('"{\em ",ops,'"}") else..... + htSayExpose(ops,exposureFlag) + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] + if which = '"attribute" then htSay args2HtString (sig and [sig]) else + htSay '": " + tail = 'ASCONST => bcConform first sig + bcConform ['Mapping,:sig] + htSay '"}" + count := count + 1 + htEndTable() + count + +dbShowOpParameters(htPage,opAlist,which,data) == + single? := null rest data + count := 0 + htBeginTable() + firstTime := true + for item in data repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + [opform,exposeFlag,:tail] := item + op := intern IFCAR opform + args := IFCDR opform + ops := escapeSpecialChars STRINGIMAGE op + htSay '"{" + htSayExpose(ops,exposeFlag) + n := #opform + do + n = 2 and LASSOC('Nud,PROPLIST op) => + dbShowOpParameterJump(ops,which,count,single?) + htSay('" {\em ",KAR args,'"}") + n = 3 and LASSOC('Led,PROPLIST op) => + htSay('"{\em ",KAR args,'"} ") + dbShowOpParameterJump(ops,which,count,single?) + htSay('" {\em ",KAR KDR args,'"}") + dbShowOpParameterJump(ops,which,count,single?) + tail = 'ASCONST or member(op,'(0 1)) or which = '"attribute" and null IFCAR args => 'skip + htSay('"(") + if IFCAR args then htSay('"{\em ",IFCAR args,'"}") + for x in IFCDR args repeat + htSay('",{\em ",x,'"}") + htSay('")") + htSay '"}" + count := count + 1 + htEndTable() + +dbShowOpParameterJump(ops,which,count,single?) == + single? => htSay('"{\em ",ops,'"}") + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] + +dbShowOpDocumentation(htPage,opAlist,which,data) == + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + --NOTE: this line is necessary to get indexing right. + --The test below for $exposedOnlyIfTrue causes unexposed items + --to be skipped. + newWhich := + conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + which = '"package operation" => '"operation" + which + expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + if expand then + condata := dbGatherData(htPage,opAlist,which,'conditions) + htpSetProperty(htPage,'conditionData,condata) + base := -8192 + exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp + htSaySaturn '"\begin{description}" + for [op,:alist] in opAlist repeat + base := 8192 + base + for item in alist for j in 0.. repeat + [sig,predicate,origin,exposeFlag,comments] := item + exposeFlag or not $exposedOnlyIfTrue => + if comments ^= '"" and STRINGP comments and (k := string2Integer comments) then + comments := + MEMQ(k,'(0 1)) => '"" + dbReadComments k + tail := CDDDDR item + RPLACA(tail,comments) + doc := (STRINGP comments and comments ^= '"" => comments; nil) + pred := predicate or true + index := (exactlyOneOpSig => nil; base + j) + if which = '"package operation" then + sig := SUBST(conform,'_$,sig) + origin := SUBST(conform,'_$,origin) + displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,index,'dbChooseDomainOp,null exposeFlag,true) + htSaySaturn '"\end{description}" + +dbChooseDomainOp(htPage,which,index) == + [opKey,entryKey] := DIVIDE(index,8192) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + [op,:entries] := opAlist . opKey + entry := entries . entryKey + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,[[op,entry]]) + else htpSetProperty(htPage,'attrAlist,[[op,entry]]) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOps(htPage,which,'documentation) + +htSayExpose(op,flag) == + $includeUnexposed? => + flag => htBlank() + op.0 = char '_* => htSay '"{\em *} " + htSayUnexposed() + htSay '"" +--============================================================================ +-- Branch-in From Other Places +--============================================================================ +dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists + $groupChoice := nil + conform := htpProperty(htPage,'conform) + --prepare opAlist for possible filtering of groups + if null BOUNDP '$topicHash then + $topicHash := MAKE_-HASHTABLE 'ID + for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat + HPUT($topicHash,x,c) + if domform := htpProperty(htPage,'domname) then + $conformsAreDomains : local := true + reduceOpAlistForDomain(opAlist,domform,conform) + conform := domform or conform + kind := capitalize htpProperty(htPage,'kind) + exposePart := + isExposedConstructor opOf conform => '"" + '" Unexposed " + fromPart := + domform => evalableConstructor2HtString domform + form2HtString conform + heading := + ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + htpSetProperty(htPage,expandProperty,'lists) + htpSetProperty(htPage,'fromHeading,heading) + reducedOpAlist := + which = '"operation" => reduceByGroup(htPage,opAlist) + opAlist + if which = '"operation" + then + htpSetProperty(htPage,'principalOpAlist,opAlist) + htpSetProperty(htPage,'opAlist,reducedOpAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if domform + then htpSetProperty(htPage,'condition?,'no) + else dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOp1(htPage,reducedOpAlist,which,'names) + +reduceOpAlistForDomain(opAlist,domform,conform) == +--destructively simplify all predicates; filter out any that fail + form1 := [domform,:rest domform] + form2 := ['$,:rest conform] + for pair in opAlist repeat + RPLACD(pair,[test for item in rest pair | test]) where test == + [head,:tail] := item + CAR tail = true => item + pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) + null pred => false + RPLACD(item,[pred]) + item + opAlist + +dbShowOperationLines(which,linelist) == --branch in with lines + htPage := htInitPage(nil,nil) --create empty page + opAlist := nil + lines := linelist + while lines repeat + name := dbName (x := first lines) + pile := [x] + while (lines := rest lines) and name = dbName (x := first lines) repeat + pile := [x,:pile] + opAlist := [[name,:NREVERSE pile],:opAlist] + opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + htpSetProperty(htPage,expandProperty,'strings) + dbResetOpAlistCondition(htPage,which,opAlist) + if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then + --code needed to handle commutative("*"); called from aPage + --must completely expand the opAlist then check for those with + --arguments equal to $attributeArgs + --here: opAlist is [[op,:itemlist]] + dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) + opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | first item = $attributeArgs]]] + dbShowOp1(htPage,opAlist,which,'names) + +--============================================================================ +-- Code to Expand opAlist +--============================================================================ +dbResetOpAlistCondition(htPage,which,opAlist) == + value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) + htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) + value + +dbSetOpAlistCondition(htPage,opAlist,which) == +--called whenever a new opAlist is needed +--property can only be inherited if 'no (a subset says NO if whole says NO) + condition := htpProperty(htPage,'condition?) + MEMQ(condition,'(yes no)) => condition = 'yes + value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) + htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) + value + +dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == +--if condition? = true, stop when you find a non-trivial predicate +--otherwise, expand in full +--RETURNS: +-- non-trivial predicate, if condition? = true and it finds one +-- nil, otherwise +--SIDE-EFFECT: this function references the "expand" property (set elsewhere): +-- 'strings, if not fully expanded and it contains strings +-- i.e. opAlist is ((op . (string ...))...) if unexpanded +-- 'lists, if not fully expanded and it contains lists +-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded + condition? := condition? and not $exposedOnlyIfTrue + value := nil --return value + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + expandFlag := htpProperty(htPage,expandProperty) + expandFlag = 'fullyExpanded => nil + expandFlag = 'strings => --strings are partially expanded + for pair in opAlist repeat + [op,:lines] := pair + acc := nil + for line in lines repeat + --NOTE: we must expand all lines here for a given op + -- since below we will change opAlist + --Case 1: Already expanded; just cons it onto ACC + null STRINGP line => --already expanded + if condition? then --this could have been expanded at a lower level + if null atom (pred := CADR line) then value := pred + acc := [line,:acc] --this one is already expanded; record it anyway + --Case 2: unexpanded; expand it then cons it onto ACC + [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) + predicate := ncParseFromString pred + if condition? and null atom predicate then value := predicate + sig := ncParseFromString sigs --is (Mapping,:.) + if which = '"operation" then + if sig isnt ['Mapping,:.] + then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] + else sig := rest sig + conname := intern dbNewConname line + origin := [conname,:getConstructorArgs conname] + exposeFlag := dbExposed?(line,char 'o) + acc := [[sig,predicate,origin,exposeFlag,comments],:acc] + --always store the fruits of our labor: + RPLACD(pair,NREVERSE acc) --at least partially expand it + condition? and value => return value --early exit + value => value + condition? => nil + htpSetProperty(htPage,expandProperty,'fullyExpanded) + expandFlag = 'lists => --lists are partially expanded + -- entry is [sig, predicate, origin, exposeFlag, comments] + $value: local := nil + $docTableHash := MAKE_-HASHTABLE 'EQUAL + packageSymbol := false + domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + if isDefaultPackageName opOf domform then + catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) + packageSymbol := first rest domform + domform := [catname,:rest rest domform] --skip first argument ($) + docTable:= dbDocTable domform + for [op,:alist] in opAlist repeat + for [sig,:tail] in alist repeat + condition? => --the only purpose here is to find a non-trivial pred + null atom (pred := CAR tail) => return ($value := pred) + 'skip + u := + tail is [.,origin,:.] and origin => +-- must change any % into $ otherwise we will not pick up comments properly +-- delete the SUBLISLIS when we fix on % or $ + dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,which,nil) + if packageSymbol then sig := SUBST('_$,packageSymbol,sig) + dbGetDocTable(op,sig,docTable,which,nil) + origin := IFCAR u or origin + docCode := IFCDR u --> (doc . code) +-- if null FIXP CDR docCode then harhar(op) --> + if null doc and which = '"attribute" then doc := getRegistry(op,sig) + RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) + $value => return $value + $value => $value + condition? => nil + htpSetProperty(htPage,expandProperty,'fullyExpanded) + 'done + +getRegistry(op,sig) == + u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) + v := LASSOC(op,u) + match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match + '"" + +evalableConstructor2HtString domform == + if VECP domform then domform := devaluate domform + conname := first domform + coSig := rest GETDATABASE(conname,'COSIG) + --entries are T for arguments which are domains; NIL for computational objects + and/[x for x in coSig] => form2HtString(domform,nil,true) + arglist := [unquote x for x in rest domform] where + unquote arg == + arg is [f,:args] => + f = 'QUOTE => first args + [f,:[unquote x for x in args]] + arg + fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) +--argtypes:= sublisFormal(arglist,fargtypes) + form2HtString([conname,:[fn for arg in arglist for x in coSig + for ftype in fargtypes]],nil,true) where + fn == + x => arg + typ := sublisFormal(arglist,ftype) + mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) + +mathform2HtString form == escapeString + $fortInts2Floats: local := false + form := niladicHack form + form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) + form is ['BRACKET,['AGGLST,:arg]] => + if arg is ['construct,:r] then arg := r + arg := + atom arg => [arg] + [y for x in arg | y := (x is ['QUOTE,a] => a; x)] + tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] + STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") + form is ['BRACKET,['AGGLST,'QUOTE,arg]] => + if atom arg then arg := [arg] + tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] + STRCONC('"[",first arg,tailPart,'"]") + atom form => form + "STRCONC"/fortexp0 form + +niladicHack form == + atom form => form + form is [x] and GETL(x,'NILADIC) => x + [niladicHack x for x in form] + +--============================================================================ +-- Getting Operations from Domain +--============================================================================ + +getDomainOpTable(dom,fromIfTrue,:options) == + ops := KAR options + $predEvalAlist : local := nil + $returnNowhereFromGoGet: local := true + domname := dom.0 + conname := CAR domname + abb := getConstructorAbbreviation conname + opAlist := getOperationAlistFromLisplib conname + "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u + | key ^= 'Subsumed and ((null ops and (op1 := op)) or (op1 := memq(op,ops)))] + for [op,:u] in opAlist] where + memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One + MEMQ(op,ops) => op + EQ(op,'One) => MEMQ(1,ops) and 1 + EQ(op,'Zero) => MEMQ(0,ops) and 0 + false + fn == + sig1 := sublisFormal(rest domname,sig) + predValue := evalDomainOpPred(dom,pred) + info := + null predValue => + 1 -- signifies not exported + null fromIfTrue => nil + cell := compiledLookup(op,sig1,dom) => + [f,:r] := cell + f = 'nowhere => 'nowhere --see replaceGoGetSlot + f = 'makeSpadConstant => 'constant + f = function IDENTITY => 'constant + f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) + null VECP r => systemError devaluateList r + SUBST('_$,domname,devaluate r) + 'nowhere + [sig1,:info] + +evalDomainOpPred(dom,pred) == process(dom,pred) where + process(dom,pred) == + u := convert(dom,pred) + u = 'T => true + evpred(dom,u) + convert(dom,pred) == + pred is [op,:argl] => + MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] + MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] + MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] + op = 'has => + [arg,p] := argl + p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] + ['HasCategory,arg,convertCatArg p] + systemError '"unknown predicate form" + pred = 'T => true + systemError nil + convertCatArg p == + atom p or #p = 1 => MKQ p + ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] + evpred(dom,pred) == + k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) + evpred1(dom,pred) + evpred1(dom,pred) == + pred is [op,:argl] => + MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] + MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] + op = 'NOT => not evpred1(dom,first argl) + k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) + op = 'HasAttribute => + [arg,[.,a]] := argl + attPredIndex := LASSOC(a,dom.2) + null attPredIndex => nil + attPredIndex = 0 => true + testBitVector(dom.3,attPredIndex) + nil + pred = 'T => true + systemError '"unknown atomic predicate form" + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-op2.boot b/src/interp/br-op2.boot deleted file mode 100644 index b63519d8..00000000 --- a/src/interp/br-op2.boot +++ /dev/null @@ -1,764 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS br-op2.boot <================================ - ---======================================================================= --- Operation Description ---======================================================================= - -displayDomainOp(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) == ------------------------> OBSELETE - $saturn => - displayDomainOp1(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) - $chooseDownCaseOfType : local := true --see dbGetContrivedForm - $whereList : local := nil - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(D R S E T A B C M N P Q U V W) - exactlyOneOpSig := null index - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - or origin - if $generalSearch? then $DomainList := rest $DomainList - opform := - which = '"attribute" => - null sig => [op] - [op,sig] - which = '"constructor" => origin - dbGetDisplayFormForOp(op,sig,doc) - htSay('"\newline") - if exactlyOneOpSig then htSay('"\menuitemstyle{}") - else htMakePage [['bcLinks,['"\menuitemstyle{}",'"",chooseFn,which,index]]] - htSay('"\tab{2}") - op := IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - n := #sig - do - n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") - if unexposed? and $includeUnexposed? then - htSayUnexposed() - htSaySaturn '"\unexposed{{\em " - htSaySaturn ops - htSaySaturn '"}" - htSayStandard(ops) - predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip - which = '"attribute" and null args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",quickForm2HtString x,'"}") - htSay('")") - constring := form2HtString conform - conname := first conform - $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) - $conlength : local := #constring - $conform : local := conform - $conargs : local := rest conform - if which = '"operation" then - $signature : local := - MEMQ(conname,$Primitives) => nil - CDAR getConstructorModemap conname - --RDJ: this next line is necessary until compiler bug is fixed - --that forgets to substitute #variables for t#variables; - --check the signature for SegmentExpansionCategory, e.g. - tvarlist := TAKE(# $conargs,$TriangleVariableList) - $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) - $sig := - which = '"attribute" or which = '"constructor" => sig - $conkind ^= '"package" => sig - symbolsUsed := [x for x in rest conform | IDENTP x] - $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) - getSubstSigIfPossible sig - if member(which,'("operation" "constructor")) then - $displayReturnValue: local := nil - if args then - htSay('"\newline") - htSayStandard '"\tab{2}" - htSay '"{\em Arguments:}" - for a in args for t in rest $sig repeat - htSayIndentRel(15,true) - htSay('"{\em ",form2HtString(a),'"}, ") - htSayValue t - htSayIndentRel(-15,true) - htSay('"\newline ") - if first $sig then - $displayReturnValue := true - htSay('"\newline\tab{2}{\em Returns:}") - htSayIndentRel(15) - htSayValue first $sig - htSayIndentRel(-15) - htSay('"\newline ") - if origin and ($generalSearch? or origin ^= conform) and opOf(origin)^=op then - htSay('"\newline\tab{2}{\em Origin:}") - htSayIndentRel(15) - if not isExposedConstructor opOf origin and $includeUnexposed? then htSayUnexposed() - bcConform(origin,true) - htSayIndentRel(-15) - if not MEMQ(predicate,'(T ASCONST)) then - pred := sublisFormal(KDR conform,predicate) - count := #pred - htSay('"\newline\tab{2}{\em Conditions:}") - for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat - htSayIndentRel(15,count > 1) - bcPred(p,$conform,true) - htSayIndentRel(-15,count > 1) - htSay('"\newline ") - if $whereList then - count := #$whereList - htSay('"\newline\tab{2}{\em Where:}") - if ASSOC("$",$whereList) then - htSayIndentRel(15,true) - htSayStandard '"{\em \$} is " - htSaySaturn '"{\em \%} is " - htSay - $conkind = '"category" => '"of category " - '"the domain " - bcConform(conform,true,true) - htSayIndentRel(-15,true) - for [d,key,:t] in $whereList | d ^= "$" repeat - htSayIndentRel(15,count > 1) - htSay("{\em ",d,"} is ") - htSayConstructor(key,sublisFormal(KDR conform,t)) - htSayIndentRel(-15,count > 1) - if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then - htSay('"\newline\tab{2}{\em Description:}") - htSayIndentRel(15) - if doc = $charFauxNewline then htSay $charNewline - else - ndoc:= - -- we are confused whether doc is a string or a list of strings - CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] - SUBSTITUTE($charNewline, $charFauxNewline,doc) - htSay ndoc - htSayIndentRel(-15) - if exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then - displayInfoOp(htPage,infoAlist,op,sig) - - -htSayIndentRel(n,:options) == ------------------> OBSELETE - flag := IFCAR options - m := ABSVAL n - if flag then m := m + 2 - htSay - n > 0 => - flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] - ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] - n < 0 => ['"\indent{0}\newline "] - -htSayConstructor(key,u) == - u is ['CATEGORY,kind,:r] => - htSay('"a ",kind,'" ") - htSayExplicitExports(r) - key = 'is => - htSay '"the domain " - bcConform(u,true) - htSay - key = 'is => '"the domain " - kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) - kind = 'domain => '"an element of " - '"a domain of " - u is ['Join,:middle,r] => - rest middle => - htSay '"categories " - bcConform(first middle,true) - for x in rest middle repeat - htSay '", " - bcConform(x,true) - r is ['CATEGORY,.,:r] => - htSay '" and " - htSayExplicitExports(r) - htSay '" and " - bcConform(r,true) - htSay '"category " - bcConform(first middle,true) - r is ['CATEGORY,.,:r] => - htSay '" " - htSayExplicitExports(r) - htSay '" and " - bcConform(r,true) - htSay(kind,'" ") - bcConform(u,true) - -htSayExplicitExports r == - htSay '"with explicit exports" - $displayReturnValue => nil - htSay '":" - for x in r repeat - htSay '"\newline " - x is ['SIGNATURE,op,sig] => - ops := escapeSpecialChars STRINGIMAGE op - htMakePage [['bcLinks,[ops,'"",'oPage,ops]]] - htSay '": " - bcConform ['Mapping,:sig] - x is ['ATTRIBUTE,a] => - s := form2HtString a - htMakePage [['bcLinks,[ops,'"",'aPage,s]]] - x is ['IF,:.] => - htSay('"{\em if ...}") - systemError() - -displayBreakIntoAnds pred == - pred is [op,:u] and member(op,'(and AND)) => u - [pred] - -htSayValue t == - t is ['Mapping,target,:source] => - htSay('"a function from ") - htSayTuple source - htSay '" to " - htSayArgument target - t = '(Category) => htSay('"a category") - t is [op,:.] and MEMQ(op,'(Join CATEGORY)) or constructor? opOf t => - htSayConstructor(nil,t) - htSay('"an element of domain ") - htSayArgument t --continue for operations - -htSayArgument t == --called only for operations not for constructors - null $signature => htSay ['"{\em ",t,'"}"] - MEMQ(t, '(_$ _%)) => - $conkind = '"category" and $conlength > 20 => - $generalSearch? => htSay '"{\em D} of the origin category" - addWhereList("$",'is,nil) - htSayStandard '"{\em $}" - htSaySaturn '"{\em \%}" - htSayStandard '"{\em $}" - htSaySaturn '"{\em \%}" - not IDENTP t => bcConform(t,true) - k := position(t,$conargs) - if k > -1 then - typeOfArg := (rest $signature).k - addWhereList(t,'member,typeOfArg) - htSay('"{\em ",t,'"}") - -addWhereList(id,kind,typ) == - $whereList := insert([id,kind,:typ],$whereList) - -htSayTuple t == - null t => htSay '"()" - null rest t => htSayArgument first t - htSay '"(" - htSayArgument first t - for d in rest t repeat - htSay '"," - htSayArgument d - htSay '")" - -dbGetDisplayFormForOp(op,sig,doc) == - dbGetFormFromDocumentation(op,sig,doc) or dbGetContrivedForm(op,sig) - -dbGetFormFromDocumentation(op,sig,x) == - doc := (STRINGP x => x; first x) - STRINGP doc and - (stringPrefix?('"\spad{",doc) and (k := 6) or - stringPrefix?('"\s{",doc) and (k := 3)) => - n := charPosition($charRbrace,doc,k) - s := SUBSTRING(doc,k,n - k) - parse := ncParseFromString s - parse is [=op,:.] and #parse = #sig => parse - nil - -dbMakeContrivedForm(op,sig,:options) == - $chooseDownCaseOfType : local := IFCAR options - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(R S D E T A B C M N P Q U V W) - dbGetContrivedForm(op,sig) - -dbGetContrivedForm(op,sig) == - op = '"0" => [0] - op = '"1" => [1] - [op,:[dbChooseOperandName s for s in rest sig]] - -dbChooseOperandName(typ) == - typ is ['Mapping,:.] => - x := first $FunctionList - $FunctionList := rest $FunctionList - x - name := opOf typ - kind := - name = "$" => 'domain - GETDATABASE(name,'CONSTRUCTORKIND) - s := PNAME opOf typ - kind ^= 'category => - anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => - x := first $NumberList - $NumberList := rest $NumberList - x - x := - $chooseDownCaseOfType => - y := DOWNCASE typ - x := - member(y,$ElementList) => y - first $ElementList - first $ElementList - $ElementList := delete(x,$ElementList) - x - x := first $DomainList - $DomainList := rest $DomainList - x - -getSubstSigIfPossible sig == - getSubstSignature sig or sig - --- --- while (u := getSubstSignature sig) repeat --- sig := u --- sig - -fullSubstitute(x,y,z) == --substitutes deeply: x for y in list z - z = y => x - atom z => z - [fullSubstitute(x,y,u) for u in z] - -getSubstCandidates sig == - candidates := nil - for x in sig for i in 1.. | x is [.,.,:.] repeat - getSubstQualify(x,i,sig) => candidates := getSubstInsert(x,candidates) - y := or/[getSubstQualify(y,i,sig) for y in rest x | y is [.,.,:.]] => - candidates := insert(y,candidates) - candidates - -getSubstSignature sig == - candidates := getSubstCandidates sig - null candidates => nil - D := first $DomainList - $DomainList := rest $DomainList - winner := first candidates - newsig := fullSubstitute(D,winner,sig) - sig := - null rest candidates => newsig - count := NUMOFNODES newsig - for x in rest candidates repeat - trial := fullSubstitute(D,x,sig) - trialCount := NUMOFNODES trial - trialCount < count => - newsig := trial - count := trialCount - winner := x - newsig - addWhereList(D,'is,winner) - newsig - -getSubstQualify(x,i,sig) == - or/[CONTAINED(x,y) for y in sig for j in 1.. | j ^= i] => x - false - -getSubstInsert(x,candidates) == - return insert(x,candidates) - null candidates => [x] - or/[CONTAINED(x,y) for y in candidates] => candidates - y := or/[CONTAINED(y,x) for y in candidates] => SUBST(x,y,candidates) - candidates - - ---======================================================================= --- Who Uses ---======================================================================= -whoUsesOperation(htPage,which,key) == --see dbPresentOps - key = 'filter => koaPageFilterByName(htPage,'whoUsesOperation) - opAlist := htpProperty(htPage,'opAlist) - conform := htpProperty(htPage,'conform) - conargs := rest conform - opl := nil - for [op,:alist] in opAlist repeat - for [sig,:.] in alist repeat - opl := [[op,:SUBLISLIS($FormalMapVariableList,rest conform,sig)],:opl] - opl := NREVERSE opl - u := whoUses(opl,conform) - prefix := pluralSay(#u,'"constructor uses",'"constructors use") - suffix := - opAlist is [[op1,.]] => - ['" operation {\em ",escapeSpecialChars STRINGIMAGE op1,'":",form2HtString ['Mapping,:sig],'"}"] - ['" these operations"] - page := htInitPage([:prefix,:suffix],htCopyProplist htPage) - nopAlist := nil - for [name,:opsigList] in u repeat - for opsig in opsigList repeat - sofar := LASSOC(opsig,nopAlist) - nopAlist := insertAlist(opsig,[name,:LASSOC(opsig,nopAlist)],nopAlist) - usedList := nil - for [(pair := [op,:sig]),:namelist] in nopAlist repeat - ops := escapeSpecialChars STRINGIMAGE op - usedList := [pair,:usedList] - htSay('"Users of {\em ",ops,'": ") - bcConform ['Mapping,:sublisFormal(conargs,sig)] - htSay('"}\newline") - bcConTable listSort(function GLESSEQP,REMDUP namelist) - noOneUses := SETDIFFERENCE(opl,usedList) - if #noOneUses > 0 then - htSay('"No constructor uses the ") - htSay - #noOneUses = 1 => '"operation: " - [#noOneUses,'" operations:"] - htSay '"\newline " - for [op,:sig] in noOneUses repeat - htSay('"\tab{2}{\em ",escapeSpecialChars STRINGIMAGE op,'": ") - bcConform ['Mapping,:sublisFormal(conargs,sig)] - htSay('"}\newline") - htSayStandard '"\endscroll " - dbPresentOps(page,which,'usage) - htShowPageNoScroll() - -whoUses(opSigList,conform) == - opList := REMDUP ASSOCLEFT opSigList - numOfArgsList := REMDUP [-1 + #sig for [.,:sig] in opSigList] - acc := nil - $conname : local := first conform - domList := getUsersOfConstructor $conname - hash := MAKE_-HASH_-TABLE() - for name in allConstructors() | MEMQ(name,domList) repeat - $infovec : local := dbInfovec name - null $infovec => 'skip --category - template := $infovec . 0 - found := false - opacc := nil - for i in 7..MAXINDEX template repeat - item := template . i - item isnt [n,:op] or not MEMQ(op,opList) => 'skip - index := n - numvec := getCodeVector() - numOfArgs := numvec . index - null member(numOfArgs,numOfArgsList) => 'skip - whereNumber := numvec.(index := index + 1) - template . whereNumber isnt [= $conname,:.] => 'skip - signumList := dcSig(numvec,index + 1,numOfArgs) - opsig := or/[pair for (pair := [op1,:sig]) in opSigList | op1 = op and whoUsesMatch?(signumList,sig,nil)] - => opacc := [opsig,:opacc] - if opacc then acc := [[name,:opacc],:acc] - acc - -whoUsesMatch?(signumList,sig,al) == - #signumList = #sig and whoUsesMatch1?(signumList,sig,al) - -whoUsesMatch1?(signumList,sig,al) == - signumList is [subject,:r] and sig is [pattern,:s] => - x := LASSOC(pattern,al) => - x = subject => whoUsesMatch1?(r,s,al) - false - pattern = '_$ => - subject is [= $conname,:.] => whoUsesMatch1?(r,s,[['_$,:subject],:al]) - false - whoUsesMatch1?(r,s,[[pattern,:subject],:al]) - true - ---======================================================================= --- Get Attribute/Operation Alist ---======================================================================= - -koAttrs(conform,domname) == - [conname,:args] := conform ---asharpConstructorName? conname => nil --assumed - 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => - koCatAttrs(conform,domname) - $infovec: local := dbInfovec conname or return nil - $predvec: local := - $domain => $domain . 3 - GETDATABASE(conname,'PREDICATES) - u := [[a,:pred] for [a,:i] in $infovec . 2 | a ^= 'nil and (pred := sublisFormal(args,kTestPred i))] - --------- CHECK for a = nil - listSort(function GLESSEQP,fn u) where fn u == - alist := nil - for [a,:pred] in u repeat - op := opOf a - args := IFCDR a - alist := insertAlist(op,insertAlist(args,[pred],LASSOC(op,alist)),alist) - alist - -koOps(conform,domname,:options) == main where ---returns alist of form ((op (sig . pred) ...) ...) - main == - $packageItem: local := nil --- relatives? := IFCAR options - ours := --- relatives? = 'onlyRelatives => nil - fn(conform,domname) --- if relatives? then --- relatives := relativesOf(conform,domname) --- if domname then relatives := --- SUBLISLIS([domname,:rest domname],['_$,:rest conform],relatives) --- --kill all relatives that have a sharp variable remaining in them --- for x in relatives repeat --- or/[y for y in CDAR x | isSharpVar y] => 'skip --- acc := [x,:acc] --- relatives := NREVERSE acc --- for (pair := [pakform,:.]) in relatives repeat --- $packageItem := sublisFormal(rest conform,pair) --- ours := merge(fn(pakform,nil),ours) - listSort(function GLESSEQP,trim ours) - trim u == [pair for pair in u | IFCDR pair] - fn(conform,domname) == - conform := domname or conform - [conname,:args] := conform - subargs: local := args - ----------> new <------------------ - u := koCatOps(conform,domname) => u --- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => --- koCatOps(conform,domname) - asharpConstructorName? opOf conform => nil - ----------> new <------------------ - $infovec: local := dbInfovec conname--------> removed 94/10/24 - exposureTail := - null $packageItem => '(NIL NIL) - isExposedConstructor opOf conform => [conform,:'(T)] - [conform,:'(NIL)] - for [op,:u] in getOperationAlistFromLisplib conname repeat - op1 := zeroOneConvert op - acc := - [[op1,:[[sig,npred,:exposureTail] for [sig,slot,pred,key,:.] in sublisFormal(subargs,u) | - (key ^= 'Subsumed) and (npred := simpHasPred pred)]],:acc] - acc - merge(alist,alist1) == --alist1 takes precedence - for [op,:al] in alist1 repeat - u := LASSOC(op,alist) => - for [sig,:item] in al | not LASSOC(sig,u) repeat - u := insertAlist(sig,item,u) - alist := insertAlist(op,u,DELASC(op,alist)) --add the merge of two alists - alist := insertAlist(op,al,alist) --add the whole inner alist - alist - -zeroOneConvert x == - x = 'Zero => 0 - x = 'One => 1 - x - -kFormatSlotDomain x == fn formatSlotDomain x where fn x == - atom x => x - (op := CAR x) = '_$ => '_$ - op = 'local => CADR x - op = ":" => [":",CADR x,fn CADDR x] - MEMQ(op,$Primitives) or constructor? op => - [fn y for y in x] - INTEGERP op => op - op = 'QUOTE and atom CADR x => CADR x - x - -koCatOps(conform,domname) == - conname := opOf conform - oplist := REVERSE GETDATABASE(conname,'OPERATIONALIST) - oplist := sublisFormal(IFCDR domname or IFCDR conform ,oplist) - --check below for INTEGERP key to avoid subsumed signatures - [[zeroOneConvert op,:nalist] for [op,:alist] in oplist | nalist := koCatOps1(alist)] - -koCatOps1 alist == [x for item in alist | x := pair] where - pair == - [sig,:r] := item - null r => [sig,true] - [key,:options] := r - null (pred := IFCAR options) => - IFCAR IFCDR options = 'ASCONST => [sig,'ASCONST] - [sig,true] - npred := simpHasPred pred => [sig,npred] - false - -koCatAttrs(catform,domname) == - $if: local := MAKE_-HASHTABLE 'ID - catname := opOf catform - koCatAttrsAdd(domname or catform,true) - ancestors := ancestorsOf(catform,domname) - for [conform,:pred] in ancestors repeat koCatAttrsAdd(conform,pred) - hashTable2Alist $if - -hashTable2Alist tb == - [[op,:HGET(tb,op)] for op in listSort(function GLESSEQP,HKEYS $if)] - -koCatAttrsAdd(catform,pred) == - for [name,argl,:p] in CAR getConstructorExports catform repeat - npred := quickAnd(pred,p) - exists := HGET($if,name) - if existingPred := LASSOC(argl,exists)_ - then npred := quickOr(npred,existingPred) - if not MEMQ(name,'(nil nothing)) _ - then HPUT($if,name,[[argl,simpHasPred npred],:exists]) - ---======================================================================= --- Filter by Category ---======================================================================= - -koaPageFilterByCategory(htPage,calledFrom) == - opAlist := htpProperty(htPage,'opAlist) - which := htpProperty(htPage,'which) - page := htInitPageNoScroll(htCopyProplist htPage, - dbHeading(opAlist,which,htpProperty(htPage,'heading))) - htSay('"Select a category ancestor below or ") - htMakePage [['bcLispLinks,['"filter",'"on:",calledFrom,'filter]]] - htMakePage [['bcStrings, [13,'"",'filter,'EM]]] - htSay('"\beginscroll ") - conform := htpProperty(htPage,'conform) - domname := htpProperty(htPage,'domname) - ancestors := ASSOCLEFT ancestorsOf(conform,domname) - htpSetProperty(page,'ancestors,listSort(function GLESSEQP,ancestors)) - bcNameCountTable(ancestors,'form2HtString,'koaPageFilterByCategory1,true) - htShowPage() - -dbHeading(items,which,heading,:options) == - names? := IFCAR options - count := - names? => #items - +/[#(rest x) for x in items] - capwhich := capitalize which - prefix := - count < 2 => - names? => pluralSay(count,STRCONC(capwhich," Name"),nil) - pluralSay(count,capwhich,nil) - names? => pluralSay(count,nil,STRCONC(capwhich," Names")) - pluralSay(count,nil,pluralize capwhich) - [:prefix,'" for ",:heading] - -koaPageFilterByCategory1(htPage,i) == - ancestor := htpProperty(htPage,'ancestors) . i - ancestorList := [ancestor,:ASSOCLEFT ancestorsOf(ancestor,nil)] - newOpAlist := nil - which := htpProperty(htPage,'which) - opAlist := htpProperty(htPage,'opAlist) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := htpProperty(htPage,'heading) - docTable := dbDocTable(domname or conform) - for [op,:alist] in opAlist repeat - nalist := [[origin,:item] for item in alist | split] - where split == - [sig,pred,:aux] := item - u := dbGetDocTable(op,sig,docTable,which,aux) - origin := IFCAR u - doc := IFCDR u - true - for [origin,:item] in nalist | origin repeat - member(origin,ancestorList) => - newEntry := [item,:LASSOC(op,newOpAlist)] - newOpAlist := insertAlist(op,newEntry,newOpAlist) - falist := nil - for [op,:alist] in newOpAlist repeat - falist := [[op,:NREVERSE alist],:falist] - htpSetProperty(htPage,'fromcat,['" from category {\sf ",form2HtString ancestor,'"}"]) - dbShowOperationsFromConform(htPage,which,falist) - ---======================================================================= --- New code for search operation alist for exact matches ---======================================================================= - -opPageFast opAlist == --called by oSearch - htPage := htInitPage(nil,nil) - htpSetProperty(htPage,'opAlist,opAlist) - htpSetProperty(htPage,'expandOperations,'lists) - which := '"operation" ---dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOp1(htPage,opAlist,which,'names) - -opPageFastPath opstring == ---return nil - x := STRINGIMAGE opstring - charPosition(char '_*,x,0) < #x => nil --quit if name has * in it - op := (STRINGP x => INTERN x; x) - mmList := getAllModemapsFromDatabase(op,nil) or return nil - opAlist := [[op,:[item for mm in mmList]]] where item == - [predList, origin, sig] := modemap2Sig(op, mm) - predicate := predList and MKPF(predList,'AND) - exposed? := isExposedConstructor opOf origin - [sig, predicate, origin, exposed?] - opAlist - -modemap2Sig(op,mm) == - [dcSig, conds] := mm - [dc, :sig] := dcSig - partial? := - conds is ['partial,:r] => conds := r - false - condlist := modemap2SigConds conds - [origin, vlist, flist] := getDcForm(dc, condlist) or return nil - subcondlist := SUBLISLIS(flist, vlist, condlist) - [predList,vlist, flist] := getSigSubst(subcondlist, nil, vlist, flist) - if partial? then - target := dcSig . 1 - ntarget := ['Union, target, '"failed"] - dcSig := SUBST(ntarget, target, dcSig) - alist := findSubstitutionOrder? pairlis(vlist, flist) or systemError() - predList := substInOrder(alist, predList) - nsig := substInOrder(alist, sig) - if hasPatternVar nsig or hasPatternVar predList then - pp '"--------------" - pp op - pp predList - pp nsig - pp mm - $badStack := [[op, mm], :$badStack] ---pause nsig - [predList, origin, SUBST("%", origin, nsig)] - -modemap2SigConds conds == - conds is ['OR,:r] => modemap2SigConds first r - conds is ['AND,:r] => r - [conds] - -hasPatternVar x == - IDENTP x and (x ^= "**") => isPatternVar x - atom x => false - or/[hasPatternVar y for y in x] - -getDcForm(dc, condlist) == - [ofWord,id,cform] := or/[x for x in condlist | x is [k,=dc,:.] - and MEMQ(k, '(ofCategory isDomain))] or return nil - conform := getConstructorForm opOf cform - ofWord = 'ofCategory => - [conform, ["*1", :rest cform], ["%", :rest conform]] - ofWord = 'isDomain => - [conform, ["*1", :rest cform], ["%", :rest conform]] - systemError() - -getSigSubst(u, pl, vl, fl) == - u is [item, :r] => - item is ['AND,:s] => - [pl, vl, fl] := getSigSubst(s, pl, vl, fl) - getSigSubst(r, pl, vl, fl) - [key, v, f] := item - key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl]) - key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl]) - key = 'ofType => getSigSubst(r, pl, vl, fl) - key = 'has => getSigSubst(r, [item, :pl], vl, fl) - key = 'not => getSigSubst(r, [item, :pl], vl, fl) - systemError() - [pl, vl, fl] - - -pairlis(u,v) == - null u or null v => nil - [[first u,:first v],:pairlis(rest u, rest v)] - - - diff --git a/src/interp/br-op2.boot.pamphlet b/src/interp/br-op2.boot.pamphlet new file mode 100644 index 00000000..3fca3f73 --- /dev/null +++ b/src/interp/br-op2.boot.pamphlet @@ -0,0 +1,790 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-op2.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS br-op2.boot <================================ + +--======================================================================= +-- Operation Description +--======================================================================= + +displayDomainOp(htPage,which,origin,op,sig,predicate, + doc,index,chooseFn,unexposed?,$generalSearch?) == +-----------------------> OBSELETE + $saturn => + displayDomainOp1(htPage,which,origin,op,sig,predicate, + doc,index,chooseFn,unexposed?,$generalSearch?) + $chooseDownCaseOfType : local := true --see dbGetContrivedForm + $whereList : local := nil + $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) + $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) + $FunctionList:local := '(f g h d e F G H) + $DomainList: local := '(D R S E T A B C M N P Q U V W) + exactlyOneOpSig := null index + conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + or origin + if $generalSearch? then $DomainList := rest $DomainList + opform := + which = '"attribute" => + null sig => [op] + [op,sig] + which = '"constructor" => origin + dbGetDisplayFormForOp(op,sig,doc) + htSay('"\newline") + if exactlyOneOpSig then htSay('"\menuitemstyle{}") + else htMakePage [['bcLinks,['"\menuitemstyle{}",'"",chooseFn,which,index]]] + htSay('"\tab{2}") + op := IFCAR opform + args := IFCDR opform + ops := escapeSpecialChars STRINGIMAGE op + n := #sig + do + n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") + n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") + if unexposed? and $includeUnexposed? then + htSayUnexposed() + htSaySaturn '"\unexposed{{\em " + htSaySaturn ops + htSaySaturn '"}" + htSayStandard(ops) + predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip + which = '"attribute" and null args => 'skip + htSay('"(") + if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") + for x in IFCDR args repeat + htSay('",{\em ",quickForm2HtString x,'"}") + htSay('")") + constring := form2HtString conform + conname := first conform + $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" + or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) + $conlength : local := #constring + $conform : local := conform + $conargs : local := rest conform + if which = '"operation" then + $signature : local := + MEMQ(conname,$Primitives) => nil + CDAR getConstructorModemap conname + --RDJ: this next line is necessary until compiler bug is fixed + --that forgets to substitute #variables for t#variables; + --check the signature for SegmentExpansionCategory, e.g. + tvarlist := TAKE(# $conargs,$TriangleVariableList) + $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) + $sig := + which = '"attribute" or which = '"constructor" => sig + $conkind ^= '"package" => sig + symbolsUsed := [x for x in rest conform | IDENTP x] + $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) + getSubstSigIfPossible sig + if member(which,'("operation" "constructor")) then + $displayReturnValue: local := nil + if args then + htSay('"\newline") + htSayStandard '"\tab{2}" + htSay '"{\em Arguments:}" + for a in args for t in rest $sig repeat + htSayIndentRel(15,true) + htSay('"{\em ",form2HtString(a),'"}, ") + htSayValue t + htSayIndentRel(-15,true) + htSay('"\newline ") + if first $sig then + $displayReturnValue := true + htSay('"\newline\tab{2}{\em Returns:}") + htSayIndentRel(15) + htSayValue first $sig + htSayIndentRel(-15) + htSay('"\newline ") + if origin and ($generalSearch? or origin ^= conform) and opOf(origin)^=op then + htSay('"\newline\tab{2}{\em Origin:}") + htSayIndentRel(15) + if not isExposedConstructor opOf origin and $includeUnexposed? then htSayUnexposed() + bcConform(origin,true) + htSayIndentRel(-15) + if not MEMQ(predicate,'(T ASCONST)) then + pred := sublisFormal(KDR conform,predicate) + count := #pred + htSay('"\newline\tab{2}{\em Conditions:}") + for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat + htSayIndentRel(15,count > 1) + bcPred(p,$conform,true) + htSayIndentRel(-15,count > 1) + htSay('"\newline ") + if $whereList then + count := #$whereList + htSay('"\newline\tab{2}{\em Where:}") + if ASSOC("$",$whereList) then + htSayIndentRel(15,true) + htSayStandard '"{\em \$} is " + htSaySaturn '"{\em \%} is " + htSay + $conkind = '"category" => '"of category " + '"the domain " + bcConform(conform,true,true) + htSayIndentRel(-15,true) + for [d,key,:t] in $whereList | d ^= "$" repeat + htSayIndentRel(15,count > 1) + htSay("{\em ",d,"} is ") + htSayConstructor(key,sublisFormal(KDR conform,t)) + htSayIndentRel(-15,count > 1) + if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then + htSay('"\newline\tab{2}{\em Description:}") + htSayIndentRel(15) + if doc = $charFauxNewline then htSay $charNewline + else + ndoc:= + -- we are confused whether doc is a string or a list of strings + CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] + SUBSTITUTE($charNewline, $charFauxNewline,doc) + htSay ndoc + htSayIndentRel(-15) + if exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then + displayInfoOp(htPage,infoAlist,op,sig) + + +htSayIndentRel(n,:options) == +-----------------> OBSELETE + flag := IFCAR options + m := ABSVAL n + if flag then m := m + 2 + htSay + n > 0 => + flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] + ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] + n < 0 => ['"\indent{0}\newline "] + +htSayConstructor(key,u) == + u is ['CATEGORY,kind,:r] => + htSay('"a ",kind,'" ") + htSayExplicitExports(r) + key = 'is => + htSay '"the domain " + bcConform(u,true) + htSay + key = 'is => '"the domain " + kind := GETDATABASE(opOf u,'CONSTRUCTORKIND) + kind = 'domain => '"an element of " + '"a domain of " + u is ['Join,:middle,r] => + rest middle => + htSay '"categories " + bcConform(first middle,true) + for x in rest middle repeat + htSay '", " + bcConform(x,true) + r is ['CATEGORY,.,:r] => + htSay '" and " + htSayExplicitExports(r) + htSay '" and " + bcConform(r,true) + htSay '"category " + bcConform(first middle,true) + r is ['CATEGORY,.,:r] => + htSay '" " + htSayExplicitExports(r) + htSay '" and " + bcConform(r,true) + htSay(kind,'" ") + bcConform(u,true) + +htSayExplicitExports r == + htSay '"with explicit exports" + $displayReturnValue => nil + htSay '":" + for x in r repeat + htSay '"\newline " + x is ['SIGNATURE,op,sig] => + ops := escapeSpecialChars STRINGIMAGE op + htMakePage [['bcLinks,[ops,'"",'oPage,ops]]] + htSay '": " + bcConform ['Mapping,:sig] + x is ['ATTRIBUTE,a] => + s := form2HtString a + htMakePage [['bcLinks,[ops,'"",'aPage,s]]] + x is ['IF,:.] => + htSay('"{\em if ...}") + systemError() + +displayBreakIntoAnds pred == + pred is [op,:u] and member(op,'(and AND)) => u + [pred] + +htSayValue t == + t is ['Mapping,target,:source] => + htSay('"a function from ") + htSayTuple source + htSay '" to " + htSayArgument target + t = '(Category) => htSay('"a category") + t is [op,:.] and MEMQ(op,'(Join CATEGORY)) or constructor? opOf t => + htSayConstructor(nil,t) + htSay('"an element of domain ") + htSayArgument t --continue for operations + +htSayArgument t == --called only for operations not for constructors + null $signature => htSay ['"{\em ",t,'"}"] + MEMQ(t, '(_$ _%)) => + $conkind = '"category" and $conlength > 20 => + $generalSearch? => htSay '"{\em D} of the origin category" + addWhereList("$",'is,nil) + htSayStandard '"{\em $}" + htSaySaturn '"{\em \%}" + htSayStandard '"{\em $}" + htSaySaturn '"{\em \%}" + not IDENTP t => bcConform(t,true) + k := position(t,$conargs) + if k > -1 then + typeOfArg := (rest $signature).k + addWhereList(t,'member,typeOfArg) + htSay('"{\em ",t,'"}") + +addWhereList(id,kind,typ) == + $whereList := insert([id,kind,:typ],$whereList) + +htSayTuple t == + null t => htSay '"()" + null rest t => htSayArgument first t + htSay '"(" + htSayArgument first t + for d in rest t repeat + htSay '"," + htSayArgument d + htSay '")" + +dbGetDisplayFormForOp(op,sig,doc) == + dbGetFormFromDocumentation(op,sig,doc) or dbGetContrivedForm(op,sig) + +dbGetFormFromDocumentation(op,sig,x) == + doc := (STRINGP x => x; first x) + STRINGP doc and + (stringPrefix?('"\spad{",doc) and (k := 6) or + stringPrefix?('"\s{",doc) and (k := 3)) => + n := charPosition($charRbrace,doc,k) + s := SUBSTRING(doc,k,n - k) + parse := ncParseFromString s + parse is [=op,:.] and #parse = #sig => parse + nil + +dbMakeContrivedForm(op,sig,:options) == + $chooseDownCaseOfType : local := IFCAR options + $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) + $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) + $FunctionList:local := '(f g h d e F G H) + $DomainList: local := '(R S D E T A B C M N P Q U V W) + dbGetContrivedForm(op,sig) + +dbGetContrivedForm(op,sig) == + op = '"0" => [0] + op = '"1" => [1] + [op,:[dbChooseOperandName s for s in rest sig]] + +dbChooseOperandName(typ) == + typ is ['Mapping,:.] => + x := first $FunctionList + $FunctionList := rest $FunctionList + x + name := opOf typ + kind := + name = "$" => 'domain + GETDATABASE(name,'CONSTRUCTORKIND) + s := PNAME opOf typ + kind ^= 'category => + anySubstring?('"Integer",s,0) or anySubstring?('"Number",s,0) => + x := first $NumberList + $NumberList := rest $NumberList + x + x := + $chooseDownCaseOfType => + y := DOWNCASE typ + x := + member(y,$ElementList) => y + first $ElementList + first $ElementList + $ElementList := delete(x,$ElementList) + x + x := first $DomainList + $DomainList := rest $DomainList + x + +getSubstSigIfPossible sig == + getSubstSignature sig or sig + +-- +-- while (u := getSubstSignature sig) repeat +-- sig := u +-- sig + +fullSubstitute(x,y,z) == --substitutes deeply: x for y in list z + z = y => x + atom z => z + [fullSubstitute(x,y,u) for u in z] + +getSubstCandidates sig == + candidates := nil + for x in sig for i in 1.. | x is [.,.,:.] repeat + getSubstQualify(x,i,sig) => candidates := getSubstInsert(x,candidates) + y := or/[getSubstQualify(y,i,sig) for y in rest x | y is [.,.,:.]] => + candidates := insert(y,candidates) + candidates + +getSubstSignature sig == + candidates := getSubstCandidates sig + null candidates => nil + D := first $DomainList + $DomainList := rest $DomainList + winner := first candidates + newsig := fullSubstitute(D,winner,sig) + sig := + null rest candidates => newsig + count := NUMOFNODES newsig + for x in rest candidates repeat + trial := fullSubstitute(D,x,sig) + trialCount := NUMOFNODES trial + trialCount < count => + newsig := trial + count := trialCount + winner := x + newsig + addWhereList(D,'is,winner) + newsig + +getSubstQualify(x,i,sig) == + or/[CONTAINED(x,y) for y in sig for j in 1.. | j ^= i] => x + false + +getSubstInsert(x,candidates) == + return insert(x,candidates) + null candidates => [x] + or/[CONTAINED(x,y) for y in candidates] => candidates + y := or/[CONTAINED(y,x) for y in candidates] => SUBST(x,y,candidates) + candidates + + +--======================================================================= +-- Who Uses +--======================================================================= +whoUsesOperation(htPage,which,key) == --see dbPresentOps + key = 'filter => koaPageFilterByName(htPage,'whoUsesOperation) + opAlist := htpProperty(htPage,'opAlist) + conform := htpProperty(htPage,'conform) + conargs := rest conform + opl := nil + for [op,:alist] in opAlist repeat + for [sig,:.] in alist repeat + opl := [[op,:SUBLISLIS($FormalMapVariableList,rest conform,sig)],:opl] + opl := NREVERSE opl + u := whoUses(opl,conform) + prefix := pluralSay(#u,'"constructor uses",'"constructors use") + suffix := + opAlist is [[op1,.]] => + ['" operation {\em ",escapeSpecialChars STRINGIMAGE op1,'":",form2HtString ['Mapping,:sig],'"}"] + ['" these operations"] + page := htInitPage([:prefix,:suffix],htCopyProplist htPage) + nopAlist := nil + for [name,:opsigList] in u repeat + for opsig in opsigList repeat + sofar := LASSOC(opsig,nopAlist) + nopAlist := insertAlist(opsig,[name,:LASSOC(opsig,nopAlist)],nopAlist) + usedList := nil + for [(pair := [op,:sig]),:namelist] in nopAlist repeat + ops := escapeSpecialChars STRINGIMAGE op + usedList := [pair,:usedList] + htSay('"Users of {\em ",ops,'": ") + bcConform ['Mapping,:sublisFormal(conargs,sig)] + htSay('"}\newline") + bcConTable listSort(function GLESSEQP,REMDUP namelist) + noOneUses := SETDIFFERENCE(opl,usedList) + if #noOneUses > 0 then + htSay('"No constructor uses the ") + htSay + #noOneUses = 1 => '"operation: " + [#noOneUses,'" operations:"] + htSay '"\newline " + for [op,:sig] in noOneUses repeat + htSay('"\tab{2}{\em ",escapeSpecialChars STRINGIMAGE op,'": ") + bcConform ['Mapping,:sublisFormal(conargs,sig)] + htSay('"}\newline") + htSayStandard '"\endscroll " + dbPresentOps(page,which,'usage) + htShowPageNoScroll() + +whoUses(opSigList,conform) == + opList := REMDUP ASSOCLEFT opSigList + numOfArgsList := REMDUP [-1 + #sig for [.,:sig] in opSigList] + acc := nil + $conname : local := first conform + domList := getUsersOfConstructor $conname + hash := MAKE_-HASH_-TABLE() + for name in allConstructors() | MEMQ(name,domList) repeat + $infovec : local := dbInfovec name + null $infovec => 'skip --category + template := $infovec . 0 + found := false + opacc := nil + for i in 7..MAXINDEX template repeat + item := template . i + item isnt [n,:op] or not MEMQ(op,opList) => 'skip + index := n + numvec := getCodeVector() + numOfArgs := numvec . index + null member(numOfArgs,numOfArgsList) => 'skip + whereNumber := numvec.(index := index + 1) + template . whereNumber isnt [= $conname,:.] => 'skip + signumList := dcSig(numvec,index + 1,numOfArgs) + opsig := or/[pair for (pair := [op1,:sig]) in opSigList | op1 = op and whoUsesMatch?(signumList,sig,nil)] + => opacc := [opsig,:opacc] + if opacc then acc := [[name,:opacc],:acc] + acc + +whoUsesMatch?(signumList,sig,al) == + #signumList = #sig and whoUsesMatch1?(signumList,sig,al) + +whoUsesMatch1?(signumList,sig,al) == + signumList is [subject,:r] and sig is [pattern,:s] => + x := LASSOC(pattern,al) => + x = subject => whoUsesMatch1?(r,s,al) + false + pattern = '_$ => + subject is [= $conname,:.] => whoUsesMatch1?(r,s,[['_$,:subject],:al]) + false + whoUsesMatch1?(r,s,[[pattern,:subject],:al]) + true + +--======================================================================= +-- Get Attribute/Operation Alist +--======================================================================= + +koAttrs(conform,domname) == + [conname,:args] := conform +--asharpConstructorName? conname => nil --assumed + 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => + koCatAttrs(conform,domname) + $infovec: local := dbInfovec conname or return nil + $predvec: local := + $domain => $domain . 3 + GETDATABASE(conname,'PREDICATES) + u := [[a,:pred] for [a,:i] in $infovec . 2 | a ^= 'nil and (pred := sublisFormal(args,kTestPred i))] + --------- CHECK for a = nil + listSort(function GLESSEQP,fn u) where fn u == + alist := nil + for [a,:pred] in u repeat + op := opOf a + args := IFCDR a + alist := insertAlist(op,insertAlist(args,[pred],LASSOC(op,alist)),alist) + alist + +koOps(conform,domname,:options) == main where +--returns alist of form ((op (sig . pred) ...) ...) + main == + $packageItem: local := nil +-- relatives? := IFCAR options + ours := +-- relatives? = 'onlyRelatives => nil + fn(conform,domname) +-- if relatives? then +-- relatives := relativesOf(conform,domname) +-- if domname then relatives := +-- SUBLISLIS([domname,:rest domname],['_$,:rest conform],relatives) +-- --kill all relatives that have a sharp variable remaining in them +-- for x in relatives repeat +-- or/[y for y in CDAR x | isSharpVar y] => 'skip +-- acc := [x,:acc] +-- relatives := NREVERSE acc +-- for (pair := [pakform,:.]) in relatives repeat +-- $packageItem := sublisFormal(rest conform,pair) +-- ours := merge(fn(pakform,nil),ours) + listSort(function GLESSEQP,trim ours) + trim u == [pair for pair in u | IFCDR pair] + fn(conform,domname) == + conform := domname or conform + [conname,:args] := conform + subargs: local := args + ----------> new <------------------ + u := koCatOps(conform,domname) => u +-- 'category = GETDATABASE(conname,'CONSTRUCTORKIND) => +-- koCatOps(conform,domname) + asharpConstructorName? opOf conform => nil + ----------> new <------------------ + $infovec: local := dbInfovec conname--------> removed 94/10/24 + exposureTail := + null $packageItem => '(NIL NIL) + isExposedConstructor opOf conform => [conform,:'(T)] + [conform,:'(NIL)] + for [op,:u] in getOperationAlistFromLisplib conname repeat + op1 := zeroOneConvert op + acc := + [[op1,:[[sig,npred,:exposureTail] for [sig,slot,pred,key,:.] in sublisFormal(subargs,u) | + (key ^= 'Subsumed) and (npred := simpHasPred pred)]],:acc] + acc + merge(alist,alist1) == --alist1 takes precedence + for [op,:al] in alist1 repeat + u := LASSOC(op,alist) => + for [sig,:item] in al | not LASSOC(sig,u) repeat + u := insertAlist(sig,item,u) + alist := insertAlist(op,u,DELASC(op,alist)) --add the merge of two alists + alist := insertAlist(op,al,alist) --add the whole inner alist + alist + +zeroOneConvert x == + x = 'Zero => 0 + x = 'One => 1 + x + +kFormatSlotDomain x == fn formatSlotDomain x where fn x == + atom x => x + (op := CAR x) = '_$ => '_$ + op = 'local => CADR x + op = ":" => [":",CADR x,fn CADDR x] + MEMQ(op,$Primitives) or constructor? op => + [fn y for y in x] + INTEGERP op => op + op = 'QUOTE and atom CADR x => CADR x + x + +koCatOps(conform,domname) == + conname := opOf conform + oplist := REVERSE GETDATABASE(conname,'OPERATIONALIST) + oplist := sublisFormal(IFCDR domname or IFCDR conform ,oplist) + --check below for INTEGERP key to avoid subsumed signatures + [[zeroOneConvert op,:nalist] for [op,:alist] in oplist | nalist := koCatOps1(alist)] + +koCatOps1 alist == [x for item in alist | x := pair] where + pair == + [sig,:r] := item + null r => [sig,true] + [key,:options] := r + null (pred := IFCAR options) => + IFCAR IFCDR options = 'ASCONST => [sig,'ASCONST] + [sig,true] + npred := simpHasPred pred => [sig,npred] + false + +koCatAttrs(catform,domname) == + $if: local := MAKE_-HASHTABLE 'ID + catname := opOf catform + koCatAttrsAdd(domname or catform,true) + ancestors := ancestorsOf(catform,domname) + for [conform,:pred] in ancestors repeat koCatAttrsAdd(conform,pred) + hashTable2Alist $if + +hashTable2Alist tb == + [[op,:HGET(tb,op)] for op in listSort(function GLESSEQP,HKEYS $if)] + +koCatAttrsAdd(catform,pred) == + for [name,argl,:p] in CAR getConstructorExports catform repeat + npred := quickAnd(pred,p) + exists := HGET($if,name) + if existingPred := LASSOC(argl,exists)_ + then npred := quickOr(npred,existingPred) + if not MEMQ(name,'(nil nothing)) _ + then HPUT($if,name,[[argl,simpHasPred npred],:exists]) + +--======================================================================= +-- Filter by Category +--======================================================================= + +koaPageFilterByCategory(htPage,calledFrom) == + opAlist := htpProperty(htPage,'opAlist) + which := htpProperty(htPage,'which) + page := htInitPageNoScroll(htCopyProplist htPage, + dbHeading(opAlist,which,htpProperty(htPage,'heading))) + htSay('"Select a category ancestor below or ") + htMakePage [['bcLispLinks,['"filter",'"on:",calledFrom,'filter]]] + htMakePage [['bcStrings, [13,'"",'filter,'EM]]] + htSay('"\beginscroll ") + conform := htpProperty(htPage,'conform) + domname := htpProperty(htPage,'domname) + ancestors := ASSOCLEFT ancestorsOf(conform,domname) + htpSetProperty(page,'ancestors,listSort(function GLESSEQP,ancestors)) + bcNameCountTable(ancestors,'form2HtString,'koaPageFilterByCategory1,true) + htShowPage() + +dbHeading(items,which,heading,:options) == + names? := IFCAR options + count := + names? => #items + +/[#(rest x) for x in items] + capwhich := capitalize which + prefix := + count < 2 => + names? => pluralSay(count,STRCONC(capwhich," Name"),nil) + pluralSay(count,capwhich,nil) + names? => pluralSay(count,nil,STRCONC(capwhich," Names")) + pluralSay(count,nil,pluralize capwhich) + [:prefix,'" for ",:heading] + +koaPageFilterByCategory1(htPage,i) == + ancestor := htpProperty(htPage,'ancestors) . i + ancestorList := [ancestor,:ASSOCLEFT ancestorsOf(ancestor,nil)] + newOpAlist := nil + which := htpProperty(htPage,'which) + opAlist := htpProperty(htPage,'opAlist) + domname := htpProperty(htPage,'domname) + conform := htpProperty(htPage,'conform) + heading := htpProperty(htPage,'heading) + docTable := dbDocTable(domname or conform) + for [op,:alist] in opAlist repeat + nalist := [[origin,:item] for item in alist | split] + where split == + [sig,pred,:aux] := item + u := dbGetDocTable(op,sig,docTable,which,aux) + origin := IFCAR u + doc := IFCDR u + true + for [origin,:item] in nalist | origin repeat + member(origin,ancestorList) => + newEntry := [item,:LASSOC(op,newOpAlist)] + newOpAlist := insertAlist(op,newEntry,newOpAlist) + falist := nil + for [op,:alist] in newOpAlist repeat + falist := [[op,:NREVERSE alist],:falist] + htpSetProperty(htPage,'fromcat,['" from category {\sf ",form2HtString ancestor,'"}"]) + dbShowOperationsFromConform(htPage,which,falist) + +--======================================================================= +-- New code for search operation alist for exact matches +--======================================================================= + +opPageFast opAlist == --called by oSearch + htPage := htInitPage(nil,nil) + htpSetProperty(htPage,'opAlist,opAlist) + htpSetProperty(htPage,'expandOperations,'lists) + which := '"operation" +--dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOp1(htPage,opAlist,which,'names) + +opPageFastPath opstring == +--return nil + x := STRINGIMAGE opstring + charPosition(char '_*,x,0) < #x => nil --quit if name has * in it + op := (STRINGP x => INTERN x; x) + mmList := getAllModemapsFromDatabase(op,nil) or return nil + opAlist := [[op,:[item for mm in mmList]]] where item == + [predList, origin, sig] := modemap2Sig(op, mm) + predicate := predList and MKPF(predList,'AND) + exposed? := isExposedConstructor opOf origin + [sig, predicate, origin, exposed?] + opAlist + +modemap2Sig(op,mm) == + [dcSig, conds] := mm + [dc, :sig] := dcSig + partial? := + conds is ['partial,:r] => conds := r + false + condlist := modemap2SigConds conds + [origin, vlist, flist] := getDcForm(dc, condlist) or return nil + subcondlist := SUBLISLIS(flist, vlist, condlist) + [predList,vlist, flist] := getSigSubst(subcondlist, nil, vlist, flist) + if partial? then + target := dcSig . 1 + ntarget := ['Union, target, '"failed"] + dcSig := SUBST(ntarget, target, dcSig) + alist := findSubstitutionOrder? pairlis(vlist, flist) or systemError() + predList := substInOrder(alist, predList) + nsig := substInOrder(alist, sig) + if hasPatternVar nsig or hasPatternVar predList then + pp '"--------------" + pp op + pp predList + pp nsig + pp mm + $badStack := [[op, mm], :$badStack] +--pause nsig + [predList, origin, SUBST("%", origin, nsig)] + +modemap2SigConds conds == + conds is ['OR,:r] => modemap2SigConds first r + conds is ['AND,:r] => r + [conds] + +hasPatternVar x == + IDENTP x and (x ^= "**") => isPatternVar x + atom x => false + or/[hasPatternVar y for y in x] + +getDcForm(dc, condlist) == + [ofWord,id,cform] := or/[x for x in condlist | x is [k,=dc,:.] + and MEMQ(k, '(ofCategory isDomain))] or return nil + conform := getConstructorForm opOf cform + ofWord = 'ofCategory => + [conform, ["*1", :rest cform], ["%", :rest conform]] + ofWord = 'isDomain => + [conform, ["*1", :rest cform], ["%", :rest conform]] + systemError() + +getSigSubst(u, pl, vl, fl) == + u is [item, :r] => + item is ['AND,:s] => + [pl, vl, fl] := getSigSubst(s, pl, vl, fl) + getSigSubst(r, pl, vl, fl) + [key, v, f] := item + key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl]) + key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl]) + key = 'ofType => getSigSubst(r, pl, vl, fl) + key = 'has => getSigSubst(r, [item, :pl], vl, fl) + key = 'not => getSigSubst(r, [item, :pl], vl, fl) + systemError() + [pl, vl, fl] + + +pairlis(u,v) == + null u or null v => nil + [[first u,:first v],:pairlis(rest u, rest v)] + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-prof.boot b/src/interp/br-prof.boot deleted file mode 100644 index 3db37c6e..00000000 --- a/src/interp/br-prof.boot +++ /dev/null @@ -1,265 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-prof.boot <================================ - ---============================================================================ --- Browser Code for Profiling ---============================================================================ -kciPage(htPage,junk) == - --info alist must have NEW format with [op,:sig] in its CAARs - which:= '"operation" - htpSetProperty(htPage,'which,which) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - heading := ['"Capsule Cross Reference for ",:htpProperty(htPage,'heading)] - page := htInitPage(heading,htCopyProplist htPage) - conname := opOf conform - htpSetProperty(page,'infoAlist,infoAlist := getInfoAlist conname) - dbGetExpandedOpAlist page --expand opAlist "in place" - opAlist := kciReduceOpAlist(htpProperty(page,'opAlist),infoAlist) - dbShowOperationsFromConform(page,which,opAlist) - -kciReduceOpAlist(opAlist,infoAlist) == ---count opAlist - res := [pair for [op,:items] in opAlist | pair] where pair == - u := LASSOC(op,infoAlist) => - y := [x for x in items - | x is [sig,:.] and or/[sig = sig1 for [sig1,:.] in u]] => [op,:y] - nil - nil - res - -displayInfoOp(htPage,infoAlist,op,sig) == - (sigAlist := LASSOC(op,infoAlist)) and (itemlist := LASSOC(sig,sigAlist)) => - dbShowInfoOp(htPage,op,sig,itemlist) - nil - -dbShowInfoOp(htPage,op,sig,alist) == - heading := htpProperty(htPage,'heading) - domname := htpProperty(htPage,'domname) - conform := htpProperty(htPage,'conform) - opAlist := htpProperty(htPage,'opAlist) - conname := opOf conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - honestConform := - kind = 'category => - [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform] - conform - faTypes := CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) - - conArgTypes := - SUBLISLIS(IFCDR conform,TAKE(#faTypes,$FormalMapVariableList),faTypes) - conform := htpProperty(htPage,'conform) - conname := opOf conform ---argTypes := REVERSE ASSOCRIGHT LASSOC('arguments,alist) ---sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes] - ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op - oppart := ['"{\em ", ops, '"}"] - head := - sig => [:oppart,'": ",:dbConformGen dbInfoSig sig] - oppart - heading := [:head,'" from {\sf ",form2HtString conform,'"}"] - for u in alist repeat - [x,:y] := u - x = 'locals => locals := y - x = 'arguments => arguments := y - fromAlist := [[x,:zeroOneConvertAlist y], :fromAlist] - fromAlist := - cons := args := nil - for (p := [x,:y]) in fromAlist repeat - x = $ => dollar := [[honestConform,:y]] - x = 'Rep => rep := [['Rep,:y]] - IDENTP x => args := [dbInfoFindCat(conform,conArgTypes,p), :args] - cons := [dbInfoTran(x,y), :cons] - [:mySort args, :dollar, :rep, :mySort cons] - sigAlist := LASSOC(op,opAlist) - item := or/[x for x in sigAlist | x is [sig1,:.] and sig1 = sig] or - systemError '"cannot find signature" - --item is [sig,pred,origin,exposeFlag,comments] - [sig,pred,origin,exposeFlag,doc] := item - htpSetProperty(htPage,'fromAlist,fromAlist) - htSayHline() - htSay('"\center{Cross Reference for definition of {\em ",ops,'"}}\beginmenu ") --- if arguments then --- htSay '"\item\menuitemstyle{}{\em arguments:}\newline" --- dbShowInfoList(arguments,0,false) - if locals then - htSay '"\item\menuitemstyle{}{\em local variables:}\newline" - dbShowInfoList(locals,8192,false) - bincount := 2 - for [con,:fns] in fromAlist repeat - htSay '"\item" - if IDENTP con then - htSay '"\menuitemstyle{} {\em calls to} " - if con ^= 'Rep then htSay '"{\em argument} " - htSay con - if and/[fn is ['origin,orig,.] and - (null origin and (origin := orig) or origin = orig) for fn in fns] then - htSay '" {\em of type} " - bcConform orig - buttonForOp := false - else - htMakePage [['bcLinks,['"\menuitemstyle{}",'"",'dbInfoChoose,bincount]]] - htSay '"{\em calls to} " - bcConform con - buttonForOp := true - htSay('":\newline ") - dbShowInfoList(fns, bincount * 8192,buttonForOp) - bincount := bincount + 1 - htSay '"\endmenu " - -dbShowInfoList(dataItems,count,buttonForOp?) == ---dataItems are [op,:sig] - single? := null rest dataItems - htSay '"\table{" - for item in dataItems repeat - [op,:sig] := - item is ['origin,.,s] => - buttonForOp? := true - s - item - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" - if count < 16384 or not buttonForOp? then - htSay [ops,'": "] - atom sig => bcConform sig - bcConform dbInfoSig sig - else - htMakePage [['bcLinks,[ops,'"",'dbInfoChooseSingle,count]]] - htSay '": " - if atom sig then htSay sig else - bcConform dbInfoSig sig - htSay '"}" - count := count + 1 - htSay '"} " - count - -dbInfoFindCat(conform,conArgTypes,u) == - [argName,:opSigList] := u - n := POSITION(argName,IFCDR conform) or systemError() - t := conArgTypes . n - [argName,:[dbInfoWrapOrigin(x,t) for x in opSigList]] - -dbInfoWrapOrigin(x, t) == - [op, :sig] := x - origin := dbInfoOrigin(op,sig,t) => ['origin, origin, x] - x - -dbInfoOrigin(op,sig,t) == - t is ['Join, :r] => or/[dbInfoOrigin(op,sig,x) for x in r] - t is ['CATEGORY,:.] => false - [sig = sig1 for [sig1,:.] in LASSOC(op, koOps(t,nil))] => t - false - -dbInfoTran(con,opSigList) == [con,:SUBST("$",con,mySort opSigList)] - -zeroOneConvertAlist u == [[zeroOneConvert x,:y] for [x,:y] in u] - -dbInfoChoose(htPage,count) == - fromAlist := htpProperty(htPage,'fromAlist) - index := count - 2 - [con, :alist] := fromAlist.index - dbInfoChoose1(htPage,con,alist) - -dbInfoChooseSingle(htPage,count) == - fromAlist := htpProperty(htPage,'fromAlist) - [index, binkey] := DIVIDE(count, 8192) - [con, :alist] := fromAlist.(index - 2) - item := alist . binkey - alist := - item is ['origin,origin,s] => - con := origin - [s] - [item] - dbInfoChoose1(htPage,con,alist) - -dbInfoChoose1(htPage,con,alist) == - $conform: local := con - opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)] - page := htInitPage(nil,nil) - htpSetProperty(page,'conform,con) - htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND)) - dbShowOperationsFromConform(page,'"operation",opAlist) - -dbInfoSigMatch(x,alist) == - [op,:sigAlist] := x - candidates := [sig for [op1,:sig] in alist | op1 = op] or return nil - sigs := [s for s in sigAlist | "or"/[first s = s1 for s1 in candidates] or - (s2 := SUBST($conform,"$",s)) and "or"/[first s2 = s1 for s1 in candidates]] - sigs and [op,:sigs] - - -dbInfoSig sig == - null rest sig => first sig - ['Mapping,:sig] - ---============================================================================ --- Code to Expand opAlist ---============================================================================ -dbGetExpandedOpAlist htPage == - expand := htpProperty(htPage,'expandOperations) - if expand ^= 'fullyExpanded then - if null expand then htpSetProperty(htPage,'expandOperations,'lists) - opAlist := koOps(htpProperty(htPage,'conform),nil) - htpSetProperty(htPage,'opAlist,opAlist) - dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",false,false) - htpProperty(htPage,'opAlist) - ---============================================================================ --- Get Info File Alist ---============================================================================ -hasNewInfoAlist conname == - (u := getInfoAlist conname) and hasNewInfoText u - -hasNewInfoText u == - and/[ATOM op and and/[item is [sig,:alist] and - null sig or null atom sig and null atom alist for item in items] for [op,:items] in u] - -getInfoAlist conname == - cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category - if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&") - abb := constructor? conname or return '"not a constructor" - fs := STRCONC(PNAME abb,'".NRLIB/info") - inStream := - PROBE_-FILE fs => OPEN fs - filename := STRCONC('"/spad/int/algebra/",PNAME abb,'".NRLIB/info") - PROBE_-FILE filename => OPEN filename - return nil - alist := mySort READ inStream - if cat? then - [.,dollarName,:.] := GETDATABASE(conname,'CONSTRUCTORFORM) - alist := SUBST("$",dollarName,alist) - alist - - - diff --git a/src/interp/br-prof.boot.pamphlet b/src/interp/br-prof.boot.pamphlet new file mode 100644 index 00000000..cf1d0e58 --- /dev/null +++ b/src/interp/br-prof.boot.pamphlet @@ -0,0 +1,288 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp br-prof.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ + +<<*>>= +<> + +--====================> WAS b-prof.boot <================================ + +--============================================================================ +-- Browser Code for Profiling +--============================================================================ +kciPage(htPage,junk) == + --info alist must have NEW format with [op,:sig] in its CAARs + which:= '"operation" + htpSetProperty(htPage,'which,which) + domname := htpProperty(htPage,'domname) + conform := htpProperty(htPage,'conform) + heading := ['"Capsule Cross Reference for ",:htpProperty(htPage,'heading)] + page := htInitPage(heading,htCopyProplist htPage) + conname := opOf conform + htpSetProperty(page,'infoAlist,infoAlist := getInfoAlist conname) + dbGetExpandedOpAlist page --expand opAlist "in place" + opAlist := kciReduceOpAlist(htpProperty(page,'opAlist),infoAlist) + dbShowOperationsFromConform(page,which,opAlist) + +kciReduceOpAlist(opAlist,infoAlist) == +--count opAlist + res := [pair for [op,:items] in opAlist | pair] where pair == + u := LASSOC(op,infoAlist) => + y := [x for x in items + | x is [sig,:.] and or/[sig = sig1 for [sig1,:.] in u]] => [op,:y] + nil + nil + res + +displayInfoOp(htPage,infoAlist,op,sig) == + (sigAlist := LASSOC(op,infoAlist)) and (itemlist := LASSOC(sig,sigAlist)) => + dbShowInfoOp(htPage,op,sig,itemlist) + nil + +dbShowInfoOp(htPage,op,sig,alist) == + heading := htpProperty(htPage,'heading) + domname := htpProperty(htPage,'domname) + conform := htpProperty(htPage,'conform) + opAlist := htpProperty(htPage,'opAlist) + conname := opOf conform + kind := GETDATABASE(conname,'CONSTRUCTORKIND) + honestConform := + kind = 'category => + [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform] + conform + faTypes := CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) + + conArgTypes := + SUBLISLIS(IFCDR conform,TAKE(#faTypes,$FormalMapVariableList),faTypes) + conform := htpProperty(htPage,'conform) + conname := opOf conform +--argTypes := REVERSE ASSOCRIGHT LASSOC('arguments,alist) +--sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes] + ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op + oppart := ['"{\em ", ops, '"}"] + head := + sig => [:oppart,'": ",:dbConformGen dbInfoSig sig] + oppart + heading := [:head,'" from {\sf ",form2HtString conform,'"}"] + for u in alist repeat + [x,:y] := u + x = 'locals => locals := y + x = 'arguments => arguments := y + fromAlist := [[x,:zeroOneConvertAlist y], :fromAlist] + fromAlist := + cons := args := nil + for (p := [x,:y]) in fromAlist repeat + x = $ => dollar := [[honestConform,:y]] + x = 'Rep => rep := [['Rep,:y]] + IDENTP x => args := [dbInfoFindCat(conform,conArgTypes,p), :args] + cons := [dbInfoTran(x,y), :cons] + [:mySort args, :dollar, :rep, :mySort cons] + sigAlist := LASSOC(op,opAlist) + item := or/[x for x in sigAlist | x is [sig1,:.] and sig1 = sig] or + systemError '"cannot find signature" + --item is [sig,pred,origin,exposeFlag,comments] + [sig,pred,origin,exposeFlag,doc] := item + htpSetProperty(htPage,'fromAlist,fromAlist) + htSayHline() + htSay('"\center{Cross Reference for definition of {\em ",ops,'"}}\beginmenu ") +-- if arguments then +-- htSay '"\item\menuitemstyle{}{\em arguments:}\newline" +-- dbShowInfoList(arguments,0,false) + if locals then + htSay '"\item\menuitemstyle{}{\em local variables:}\newline" + dbShowInfoList(locals,8192,false) + bincount := 2 + for [con,:fns] in fromAlist repeat + htSay '"\item" + if IDENTP con then + htSay '"\menuitemstyle{} {\em calls to} " + if con ^= 'Rep then htSay '"{\em argument} " + htSay con + if and/[fn is ['origin,orig,.] and + (null origin and (origin := orig) or origin = orig) for fn in fns] then + htSay '" {\em of type} " + bcConform orig + buttonForOp := false + else + htMakePage [['bcLinks,['"\menuitemstyle{}",'"",'dbInfoChoose,bincount]]] + htSay '"{\em calls to} " + bcConform con + buttonForOp := true + htSay('":\newline ") + dbShowInfoList(fns, bincount * 8192,buttonForOp) + bincount := bincount + 1 + htSay '"\endmenu " + +dbShowInfoList(dataItems,count,buttonForOp?) == +--dataItems are [op,:sig] + single? := null rest dataItems + htSay '"\table{" + for item in dataItems repeat + [op,:sig] := + item is ['origin,.,s] => + buttonForOp? := true + s + item + ops := escapeSpecialChars STRINGIMAGE op + htSay '"{" + if count < 16384 or not buttonForOp? then + htSay [ops,'": "] + atom sig => bcConform sig + bcConform dbInfoSig sig + else + htMakePage [['bcLinks,[ops,'"",'dbInfoChooseSingle,count]]] + htSay '": " + if atom sig then htSay sig else + bcConform dbInfoSig sig + htSay '"}" + count := count + 1 + htSay '"} " + count + +dbInfoFindCat(conform,conArgTypes,u) == + [argName,:opSigList] := u + n := POSITION(argName,IFCDR conform) or systemError() + t := conArgTypes . n + [argName,:[dbInfoWrapOrigin(x,t) for x in opSigList]] + +dbInfoWrapOrigin(x, t) == + [op, :sig] := x + origin := dbInfoOrigin(op,sig,t) => ['origin, origin, x] + x + +dbInfoOrigin(op,sig,t) == + t is ['Join, :r] => or/[dbInfoOrigin(op,sig,x) for x in r] + t is ['CATEGORY,:.] => false + [sig = sig1 for [sig1,:.] in LASSOC(op, koOps(t,nil))] => t + false + +dbInfoTran(con,opSigList) == [con,:SUBST("$",con,mySort opSigList)] + +zeroOneConvertAlist u == [[zeroOneConvert x,:y] for [x,:y] in u] + +dbInfoChoose(htPage,count) == + fromAlist := htpProperty(htPage,'fromAlist) + index := count - 2 + [con, :alist] := fromAlist.index + dbInfoChoose1(htPage,con,alist) + +dbInfoChooseSingle(htPage,count) == + fromAlist := htpProperty(htPage,'fromAlist) + [index, binkey] := DIVIDE(count, 8192) + [con, :alist] := fromAlist.(index - 2) + item := alist . binkey + alist := + item is ['origin,origin,s] => + con := origin + [s] + [item] + dbInfoChoose1(htPage,con,alist) + +dbInfoChoose1(htPage,con,alist) == + $conform: local := con + opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)] + page := htInitPage(nil,nil) + htpSetProperty(page,'conform,con) + htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND)) + dbShowOperationsFromConform(page,'"operation",opAlist) + +dbInfoSigMatch(x,alist) == + [op,:sigAlist] := x + candidates := [sig for [op1,:sig] in alist | op1 = op] or return nil + sigs := [s for s in sigAlist | "or"/[first s = s1 for s1 in candidates] or + (s2 := SUBST($conform,"$",s)) and "or"/[first s2 = s1 for s1 in candidates]] + sigs and [op,:sigs] + + +dbInfoSig sig == + null rest sig => first sig + ['Mapping,:sig] + +--============================================================================ +-- Code to Expand opAlist +--============================================================================ +dbGetExpandedOpAlist htPage == + expand := htpProperty(htPage,'expandOperations) + if expand ^= 'fullyExpanded then + if null expand then htpSetProperty(htPage,'expandOperations,'lists) + opAlist := koOps(htpProperty(htPage,'conform),nil) + htpSetProperty(htPage,'opAlist,opAlist) + dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",false,false) + htpProperty(htPage,'opAlist) + +--============================================================================ +-- Get Info File Alist +--============================================================================ +hasNewInfoAlist conname == + (u := getInfoAlist conname) and hasNewInfoText u + +hasNewInfoText u == + and/[ATOM op and and/[item is [sig,:alist] and + null sig or null atom sig and null atom alist for item in items] for [op,:items] in u] + +getInfoAlist conname == + cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category + if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&") + abb := constructor? conname or return '"not a constructor" + fs := STRCONC(PNAME abb,'".NRLIB/info") + inStream := + PROBE_-FILE fs => OPEN fs + filename := STRCONC('"/spad/int/algebra/",PNAME abb,'".NRLIB/info") + PROBE_-FILE filename => OPEN filename + return nil + alist := mySort READ inStream + if cat? then + [.,dollarName,:.] := GETDATABASE(conname,'CONSTRUCTORFORM) + alist := SUBST("$",dollarName,alist) + alist + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot deleted file mode 100644 index afab398d..00000000 --- a/src/interp/br-saturn.boot +++ /dev/null @@ -1,1890 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-saturn.boot <================================ --- New file as of 6/95 -$aixTestSaturn := false ---These will be set in patches.lisp: ---$saturn := false --true to write SATURN output to $browserOutputStream ---$standard:= true --true to write browser output on AIX -$saturnAmpersand := '"\&\&" -$saturnFileNumber --true to write DOS files for Thinkpad (testing only) - := false -$kPageSaturnArguments := nil --bound by $kPageSaturn -$atLeastOneUnexposed := false -$saturnContextMenuLines := nil -$saturnContextMenuIndex := 0 -$saturnMacros := '( - "\def\unixcommand#1#2{{\em #1}}"_ - "\def\lispFunctionLink#1#2{\lispLink[d]{#1}{{\bf #2}}}"_ - "\def\lispTypeLink#1#2{\lispLink[d]{#1}{{\sf #2}}}"_ - "\def\menuitemstyle{\menubutton}"_ - "\def\browseTitle#1{\windowTitle{#1}\section{#1}}"_ - "\def\ttrarrow{$\rightarrow$}"_ - "\def\spadtype#1{\lispLink[d]{\verb!(|spadtype| '|#1|)!}{\sf #1}}"_ - "\def\spad#1{{\em #1}}"_ - "\def\spadfun#1{{\em #1}}"_ -) -$FormalFunctionParameterList := '(_#_#1 _#_#2 _#_#3 _#_#4 _#_#5 _#_#6 _#_#7 _#_#8 _#_#9 _#_#10 _#_#11 _#_#12 _#_#13 _#_#14 _#_#15) - -on() == - $saturn := true - $standard := false -off()== - $saturn := false - $standard := true - ---======================================================================= --- Function for testing SATURN output ---======================================================================= --- protectedEVAL x == --- $saturn => --- protectedEVAL0(x, true, false) --- if $aixTestSaturn then protectedEVAL0(x, false, true) --- protectedEVAL1 x --- ---protectedEVAL0(x, $saturn, $standard) == --- protectedEVAL1 x --- ---protectedEVAL1 x == --- error := true --- val := NIL --- UNWIND_-PROTECT((val := saturnEVAL x; error := NIL), --- error => (resetStackLimits(); sendHTErrorSignal())) --- val --- ---saturnEVAL x == --- fn := --- $aixTestSaturn => '"/tmp/sat.text" --- '"/windows/temp/browser.text" --- $saturn => --- saturnEvalToFile(x, fn) --- OBEY '"cat /tmp/sat.text" --- EVAL x - - ---======================================================================= --- Functions to write DOS files to disk ---======================================================================= -ts(command) == - $saturn := true - $saturnFileNumber := false - $standard := false - saturnEvalToFile(command, '"/tmp/sat.text") - -ut() == - $saturn := false - $standard := true - 'done - -onDisk() == - $saturnFileNumber := 1 - obey '"dosdir" - -offDisk() == - $saturnFileNumber := false - -page() == - $standard => $curPage - $saturnPage ---======================================================================= --- Functions that affect $saturnPage ---======================================================================= - ---------------------> OLD DEFINITION (override in br-util.boot.pamphlet) -htSay(x,:options) == --say for possibly both $saturn and standard code - htSayBind(x, options) - -htSayCold x == - htSay '"\lispLink{}{" - htSay x - htSay '"}" - -htSayIfStandard(x, :options) == --do only for $standard - $standard => htSayBind(x,options) - -htSayStandard(x, :options) == --do AT MOST for $standard - $saturn: local := nil - htSayBind(x, options) - -htSaySaturn(x, :options) == --do AT MOST for $saturn - $standard: local := nil - htSayBind(x, options) - -htSayBind(x, options) == - bcHt x - for y in options repeat bcHt y - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -bcHt line == - $newPage => --this path affects both saturn and old lines - text := - PAIRP line => [['text, :line]] - STRINGP line => line - [['text, line]] - if $saturn then htpAddToPageDescription($saturnPage, text) - if $standard then htpAddToPageDescription($curPage, text) - PAIRP line => - $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) - $htLineList := [basicStringize line, :$htLineList] - ---======================================================================= --- New issueHT ---======================================================================= - ---------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htShowPage() == --- show the page which has been computed - htSayStandard '"\endscroll" - htShowPageNoScroll() - -------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htShowPageNoScroll() == --- show the page which has been computed - htSayStandard '"\autobuttons" - if $standard then - htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) - if $saturn then - htpSetPageDescription($saturnPage, nreverse htpPageDescription $saturnPage) - $newPage := false - ---------------------- - if $standard then - $htLineList := nil - htMakePage htpPageDescription $curPage - if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) - issueHTStandard line - ---------------------- - if $saturn then - $htLineList := nil - htMakePage htpPageDescription $saturnPage - if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) - issueHTSaturn line - ---------------------- - endHTPage() - ---------------------> NEW DEFINITION <-------------------------- -issueHTSaturn line == --called by htMakePageNoScroll and htMakeErrorPage - if $saturn then - $marg : local := 0 - $linelength: local := 80 - writeSaturn '"\inputonce{/doc/browser/browmacs.tex}" - writeSaturnPrefix() - writeSaturn(line) - writeSaturnSuffix() - if $saturnFileNumber then - fn := STRCONC('"sat", STRINGIMAGE $saturnFileNumber, '".tex") - obey STRCONC('"doswrite -a saturn.tex ",fn, '".tex") - $saturnFileNumber := $saturnFileNumber + 1 - -writeSaturnPrefix() == - $saturnContextMenuLines => - index := - STRINGIMAGE ($saturnContextMenuIndex := $saturnContextMenuIndex + 1) - writeSaturnLines - ['"\newmenu{BCM", index, - '"}{",:nreverse $saturnContextMenuLines, - '"}\usemenu{BCM", index,'"}{\vbox{"] - -writeSaturnSuffix() == - $saturnContextMenuLines => saturnPRINTEXP '"}}" - -issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage - if $standard then - --unescapeStringsInForm line - sockSendInt($MenuServer, $SendLine) - sockSendString($MenuServer, line) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakeErrorPage htPage == - $newPage := false - $htLineList := nil - if $standard then $curPage := htPage - if $saturn then $saturnPage := htPage - htMakePage htpPageDescription htPage - line := APPLY(function CONCAT, nreverse $htLineList) - issueHT line - endHTPage() - -writeSaturnLines lines == - for line in lines repeat - if line ^= '"" and line.0 = char '_\ then saturnTERPRI() - saturnPRINTEXP line - -writeSaturn(line) == - k := 0 - n := MAXINDEX line - while --advance k if true - k > n => false - line.k ^= char '_\ => true - code := isBreakSegment?(line, k + 1,n) => false - true - repeat (k := k + 1) - k > n => writeSaturnPrint(line) - segment := SUBSTRING(line,0,k) - writeSaturnPrint(segment) - code = 1 => - writeSaturnPrint('"\\") - writeSaturn SUBSTRING(line,k + 2, nil) - code = 2 => - writeSaturnPrint('" &") - writeSaturn SUBSTRING(line,k + 4, nil) - code = 3 => - writeSaturnPrint('"\item") - writeSaturn SUBSTRING(line,k + 5,nil) - code = 4 => - writeSaturnPrint('"\newline") - writeSaturn SUBSTRING(line,k + 8,nil) - code = 5 => - writeSaturnPrint('"\table{") - $marg := $marg + 3 - writeSaturnTable SUBSTRING(line,k + 7,nil) - code = 6 => - i := charPosition(char '_},line,k + 4) - tabCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint tabCode - line := SUBSTRING(line,i + 1, nil) - writeSaturn line - code = 7 => - saturnTERPRI() - writeSaturn SUBSTRING(line, k + 2,nil) - code = 8 => - i := - substring?('"\beginmenu", line,k) => k + 9 - substring?('"\beginscroll",line,k) => k + 11 - charPosition(char '_},line,k) - if char '_[ = line.(i + 1) then - i := charPosition(char '_], line, i + 2) - beginCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint(beginCode) - line := SUBSTRING(line,i + 1,nil) - writeSaturn line - code = 9 => - i := - substring?('"\endmenu",line,k) => k + 7 - substring?('"\endscroll",line,k) => k + 9 - charPosition(char '_},line,k) - endCode := SUBSTRING(line,k, i - k + 1) - writeSaturnPrint(endCode) - line := SUBSTRING(line,i + 1,nil) - $marg := $marg - 3 - writeSaturn line - systemError code - -isBreakSegment?(line, k, n) == - k > n => nil - char2 := line . k - char2 = (char '_\) => 1 - char2 = (char '_&) => - substring?('"&\&", line, k) => 2 - nil - char2 = char 'i => - substring?('"item",line,k) => 3 - nil - char2 = char 'n => - substring?('"newline",line,k) => 4 - nil - char2 = char 't => - (k := k + 2) > n => nil - line.(k - 1) = char 'a and line.k = char 'b => - (k := k + 1) > n => nil - line.k = char "{" => 6 - substring?('"table",line,k - 3) => 5 - nil - char2 = (char '_!) => 7 - char2 = char 'b => - substring?('"begin",line,k) => 8 - nil - char2 = (char 'e) => - substring?('"end",line,k) => 9 - nil - nil - -writeSaturnPrint s == - for i in 0..($marg - 1) repeat saturnPRINTEXP '" " - saturnPRINTEXP s - saturnTERPRI() - -saturnPRINTEXP s == - $browserOutputStream => PRINTEXP(s,$browserOutputStream) - PRINTEXP s - -saturnTERPRI() == - $browserOutputStream => TERPRI($browserOutputStream) - TERPRI() - -writeSaturnTable line == - open := charPosition(char '"_{",line,0) - close:= charPosition(char '"_}",line,0) - open < close => - close := findBalancingBrace(line,open + 1,MAXINDEX line,0) or error '"no balancing brace" - writeSaturnPrint SUBSTRING(line,0,close + 1) - writeSaturnTable SUBSTRING(line,close + 1,nil) - $marg := $marg - 3 - writeSaturnPrint SUBSTRING(line,0,close + 1) - writeSaturn SUBSTRING(line, close + 1,nil) - -findBalancingBrace(s,k,n,level) == - k > n => nil - c := s . k - c = char '_{ => findBalancingBrace(s, k + 1, n, level + 1) - c = char '_} => - level = 0 => k - findBalancingBrace(s, k + 1, n, level - 1) - findBalancingBrace(s, k + 1, n, level) - ---======================================================================= --- htMakePage and friends ---======================================================================= -htMakePageStandard itemList == - $saturn => nil - htMakePage itemList - -htMakePageSaturn itemList == - $standard => nil - htMakePage itemList - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakePage itemList == - if $newPage then - if $saturn then htpAddToPageDescription($saturnPage, saturnTran itemList) - if $standard then htpAddToPageDescription($curPage, itemList) - htMakePage1 itemList - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htMakePage1 itemList == --- make a page given the description in itemList - for u in itemList repeat - itemType := 'text - items := - STRINGP u => u - ATOM u => STRINGIMAGE u - STRINGP first u => u - u is ['text, :s] => s - itemType := first u - rest u - itemType = 'text => iht items --- $saturn => bcHt items --- $standard => iht items - itemType = 'lispLinks => htLispLinks items - itemType = 'lispmemoLinks => htLispMemoLinks items - itemType = 'bcLinks => htBcLinks items ---> - itemType = 'bcLinksNS => htBcLinks(items,true) - itemType = 'bcLispLinks => htBcLispLinks items ---> - itemType = 'radioButtons => htRadioButtons items - itemType = 'bcRadioButtons => htBcRadioButtons items - itemType = 'inputStrings => htInputStrings items - itemType = 'domainConditions => htProcessDomainConditions items - itemType = 'bcStrings => htProcessBcStrings items - itemType = 'toggleButtons => htProcessToggleButtons items - itemType = 'bcButtons => htProcessBcButtons items - itemType = 'doneButton => htProcessDoneButton items - itemType = 'doitButton => htProcessDoitButton items - systemError '"unexpected branch" - -saturnTran x == - x is [[kind, [s1, s2, :callTail]]] and MEMQ(kind,'(bcLinks bcLispLinks)) => - text := saturnTranText s2 - fs := getCallBackFn callTail - y := isMenuItemStyle? s1 => ----> y is text for button in 2nd column - t1 := mkDocLink(fs, mkMenuButton()) - y = '"" => - s2 = '"" => t1 - mkTabularItem [t1, text] - t2 := mkDocLink(fs, y) - mkTabularItem [t1, t2, text] - t := mkDocLink(fs, s1) - [:t, :text] - x is [['text,:r],:.] => r - error nil - -mkBold s == - secondPart := - atom s => [s, '"}"] - [:s, '"}"] - ['"{\bf ", :secondPart] - -mkMenuButton() == [menuButton()] - -menuButton() == '"\menuitemstyle{}" --- Saturn must translate \menuitemstyle ==> {\menuButton} - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) ---replaces htMakeButton -getCallBackFn form == - func := mkCurryFun(first form, rest form) - STRCONC('"(|htDoneButton| '|", func, '"| ",htpName page(), '")") - -mkDocLink(code,s) == - if atom code then code := [code] - if atom s then s := [s] - ['"\lispLink[d]{\verb!", :code, '"!}{", :s, '"}"] - -saturnTranText x == - STRINGP x => [unTab x] - null x => nil - r is [s,fn,:.] and s = '"\unixcommand{" => ['"{\it ",s,'".spad}"] - x is [['text, :s],:r] => unTab [:s, :saturnTranText r] - error nil - -isMenuItemStyle? s == - 15 = STRING_<('"\menuitemstyle{", s) => SUBSTRING(s,15,(MAXINDEX s) - 15) - nil - -getCallBack callTail == - LASSOC(callTail, $callTailList) or - callTail is [fn] => callTail - error nil - ---======================================================================= --- Redefinitions from hypertex.boot ---======================================================================= ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -endHTPage() == - $standard => sockSendInt($MenuServer, $EndOfPage) - nil - ---======================================================================= --- Redefinitions from ht-util.boot ---======================================================================= -htSayHrule() == bcHt - $saturn => '"\hrule{}\newline{}" - '"\horizontalline{}\newline{}" - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htpAddInputAreaProp(htPage, label, prop) == -------------> Add STRINGIMAGE - SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htpSetLabelInputString(htPage, label, val) == -------------> Add STRINGIMAGE --- value user typed as input string on page - props := LASSOC(label, htpInputAreaAlist htPage) - props => SETELT(props, 0, STRINGIMAGE val) - nil - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htDoneButton(func, htPage, :optionalArgs) == -------> Handle argument values passed from page if present - if optionalArgs then - htpSetInputAreaAlist(htPage,CAR optionalArgs) - typeCheckInputAreas htPage => - htMakeErrorPage htPage - NULL FBOUNDP func => - systemError ['"unknown function", func] - FUNCALL(SYMBOL_-FUNCTION func, htPage) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htBcLinks(links,:options) == - skipStateInfo? := IFCAR options - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - link := - $saturn => '"\lispLink[d]" - '"\lispdownlink" - htMakeButton(link,message, - mkCurryFun(func, value),skipStateInfo?) - bcIssueHt info - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htBcLispLinks links == - [links,options] := beforeAfter('options,links) - for [message, info, func, :value] in links repeat - link := - $saturn => '"\lispLink[n]" - '"\lisplink" - htMakeButton(link ,message, mkCurryFun(func, value)) - bcIssueHt info - -htMakeButton(htCommand, message, func,:options) == - $saturn => htMakeButtonSaturn(htCommand, message, func, options) - skipStateInfo? := IFCAR options - iht [htCommand, '"{"] - bcIssueHt message - skipStateInfo? => - iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] - iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] - for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat - iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] - if type = 'string then - iht ['"_"\stringvalue{", id, '"}_""] - else - iht ['"_"\boxvalue{", id, '"}_""] - iht '") " - iht [htpName $curPage, '"))}"] - -htMakeButtonSaturn(htCommand, message, func,options) == - skipStateInfo? := IFCAR options - iht htCommand - skipStateInfo? => - iht ['"{\verb!(|htDoneButton| '|", func, '"| ",htpName page(), '")!}{"] - bcIssueHt message - iht '"}" - iht ['"{\verb!(|htDoneButton| '|", func, '"| "] - if $kPageSaturnArguments then - iht '"(PROGN " - for id in $kPageSaturnArguments for var in $PatternVariableList repeat - iht ['"(|htpSetLabelInputString| ", htpName page(), '"'|", var, '"| "] - iht ["'|!\", id, '"\verb!|"] - iht '")" - iht htpName $saturnPage - iht '")" - else - iht htpName $saturnPage - iht '")!}{" - bcIssueHt message - iht '"}" - -htpAddToPageDescription(htPage, pageDescrip) == - newDescript := - STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)] - nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7)) - SETELT(htPage, 7, newDescript) - - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htProcessBcStrings strings == - for [numChars, default, stringName, spadType, :filter] in strings repeat - mess2 := '"" - if NULL LASSOC(stringName, htpInputAreaAlist page()) then - setUpDefault(stringName, ['string, default, spadType, filter]) - if htpLabelErrorMsg(page(), stringName) then - iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"] - mess2 := CONCAT(mess2, bcSadFaces()) - htpSetLabelErrorMsg(page(), stringName, nil) - iht ['"\inputstring{", stringName, '"}{", - numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2] - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -setUpDefault(name, props) == - htpAddInputAreaProp(page(), name, props) - ---------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) -htInitPage(title, propList) == --- start defining a hyperTeX page - htInitPageNoScroll(propList, title) - htSayStandard '"\beginscroll " - page() - ---------------------> NEW DEFINITION <-------------------------- -htInitPageNoScroll(propList, :options) == ---start defining a hyperTeX page - $atLeastOneUnexposed := nil --reset every time a new page is initialized - $saturnContextMenuLines := nil - title := IFCAR options - $curPage := - $standard => htpMakeEmptyPage(propList) - nil - if $saturn then $saturnPage := htpMakeEmptyPage(propList) - $newPage := true - $htLineList := nil - if title then - if $standard then htSayStandard ['"\begin{page}{", htpName $curPage, '"}{"] - htSaySaturn '"\browseTitle{" - htSay title - htSaySaturn '"}" - htSayStandard '"} " - page() ---------------------> NEW DEFINITION <-------------------------- -htInitPageNoHeading(propList) == ---start defining a hyperTeX page - $curPage := - $standard => htpMakeEmptyPage(propList) - if $saturn then $saturnPage := htpMakeEmptyPage(propList) - $newPage := true - $htLineList := nil - page() - ---------------------> NEW DEFINITION <-------------------------- -htpMakeEmptyPage(propList,:options) == - name := IFCAR options or GENTEMP() - if not $saturn then - $activePageList := [name, :$activePageList] - SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil)) - val - ---======================================================================= --- Redefinitions from br-con.boot ---======================================================================= -kPage(line,:options) == --any cat, dom, package, default package ---constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) - parts := dbXParts(line,7,1) - [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts - form := IFCAR options - isFile := null kind - kind := kind or '"package" - RPLACA(parts,kind) - conform := mkConform(kind,name,args) - $kPageSaturnArguments: local := rest conform - conname := opOf conform - capitalKind := capitalize kind - signature := ncParseFromString sig - sourceFileName := dbSourceFile INTERN name - constrings := - KDR form => dbConformGenUnder form - [STRCONC(name,args)] - emString := ['"{\sf ",:constrings,'"}"] - heading := [capitalKind,'" ",:emString] - if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] - if name=abbrev then abbrev := asyAbbreviation(conname,nargs) - page := htInitPageNoScroll nil - htAddHeading heading - htSayStandard("\beginscroll ") - htpSetProperty(page,'argSublis,mkConArgSublis rest conform) - htpSetProperty(page,'isFile,true) - htpSetProperty(page,'parts,parts) - htpSetProperty(page,'heading,heading) - htpSetProperty(page,'kind,kind) - if asharpConstructorName? conname then - htpSetProperty(page,'isAsharpConstructor,true) - htpSetProperty(page,'conform,conform) - htpSetProperty(page,'signature,signature) - ---what follows is stuff from kiPage with domain = nil - $conformsAreDomains := nil - dbShowConsDoc1(page,conform,nil) - if kind ^= 'category and nargs > 0 then addParameterTemplates(page,conform) - if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed" - htSayStandard("\endscroll ") - kPageContextMenu page - htShowPageNoScroll() - -kPageContextMenu page == - $saturn => kPageContextMenuSaturn page - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) - conform := htpProperty(page,'conform) - conname := opOf conform - htBeginTable() - htSay '"{" - htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Attributes,'"",'koPage,'"attribute"]]] - if kind = '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]] - if not asharpConstructorName? conname then - htSay '"}{" - htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]] - if kind = '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]] - if kind = '"category" then - htSay '"}{" - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]] - else htSay '"{\em Domains}" - htSay '"}{" - if kind ^= '"category" and (pathname := dbHasExamplePage conname) - then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]] - else htSay '"{\em Examples}" - htSay '"}{" - htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]] - htSay '"}{" - htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]] - if kind ^= '"category" then - htSay '"}{" - if not asharpConstructorName? conname - then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]] - else htSay '"{\em Search Path}" - if kind ^= '"category" then - htSay '"}{" - htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]] - htSay '"}{" - htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]] - htSay '"}" - if $standard then htEndTable() - -kPageContextMenuSaturn page == - $newPage : local := nil - [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) - $htLineList : local := nil - conform := htpProperty(page,'conform) - conname := opOf conform - htMakePage [['bcLinks,['"\&Ancestors",'"",'kcaPage,nil]]] - htMakePage [['bcLinks,['"Attri\&butes",'"",'koPage,'"attribute"]]] - if kind = '"category" then - htMakePage [['bcLinks,['"\&Children",'"",'kccPage,nil]]] - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['"\&Dependents",'"",'kcdePage,nil]]] - if kind = '"category" then - htMakePage [['bcLinks,['"Desce\&ndents",'"",'kcdPage,nil]]] - if kind = '"category" then - if not asharpConstructorName? conname then - htMakePage [['bcLinks,['"Do\&mains",'"",'kcdoPage,nil]]] - else htSayCold '"Do\&mains" - if kind ^= '"category" and (name := saturnHasExamplePage conname) - then saturnExampleLink name - else htSayCold '"E\&xamples" - htMakePage [['bcLinks,['"\&Exports",'"",'kePage,nil]]] - htMakePage [['bcLinks,['"\&Operations",'"",'koPage,'"operation"]]] - htMakePage [['bcLinks,['"\&Parents",'"",'kcpPage,'"operation"]]] - if not asharpConstructorName? conname - then htMakePage [['bcLinks,['"Search O\&rder",'"",'ksPage,nil]]] - else htSayCold '"Search Order" - if kind ^= '"category" or dbpHasDefaultCategory? xpart - then - htMakePage [['bcLinks,['"\&Users",'"",'kcuPage,nil]]] - htMakePage [['bcLinks,['"U\&ses",'"",'kcnPage,nil]]] - else - htSayCold '"\&Users" - htSayCold '"U\&ses" - $saturnContextMenuLines := $htLineList - -saturnExampleLink lname == - htSay '"\docLink{\csname " - htSay STRCONC(CAR(CDR(lname)), '"\endcsname}{E&xamples}") - -$exampleConstructors := nil - -saturnHasExamplePage conname == - if not $exampleConstructors then - $exampleConstructors := getSaturnExampleList() - ASSQ(conname, $exampleConstructors) - -getSaturnExampleList() == - file := STRCONC( getEnv('"AXIOM"), "/doc/axug/examples.lsp") - not PROBE_-FILE file => nil - fp := MAKE_-INSTREAM file - lst := READ fp - SHUT fp - lst - ---------------------> NEW DEFINITION (see br-con.boot.pamphlet) -dbPresentCons(htPage,kind,:exclusions) == - $saturn => dbPresentConsSaturn(htPage,kind,exclusions) - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - one? := null CDR cAlist - one? := empty? or one? - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - if $standard then htBeginTable() - htSay '"{" - if one? or member('abbrs,exclusions) - then htSay '"{\em Abbreviations}" - else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]] - htSay '"}{" - if one? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSay '"{\em Conditions}" - else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]] - htSay '"}{" - if empty? or member('documentation,exclusions) - then htSay '"{\em Descriptions}" - else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]] - htSay '"}{" - if one? or null CDR cAlist - then htSay '"{\em Filter}" - else htMakePage - [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]] - htSay '"}{" - if one? or member('kinds,exclusions) or kind ^= 'constructor - then htSay '"{\em Kinds}" - else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]] - htSay '"}{" - if one? or member('names,exclusions) - then htSay '"{\em Names}" - else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]] - htSay '"}{" - if one? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSay '"{\em Parameters}" - else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]] - htSay '"}{" - if $exposedOnlyIfTrue - then - if one? - then htSay '"{\em Unexposed Also}" - else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowCons,'exposureOff]]] - else - if one? - then htSay '"{\em Exposed Only}" - else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]] - htSay '"}" - if $standard then htEndTable() - -dbPresentConsSaturn(htPage,kind,exclusions) == - $htLineList : local := nil - $newPage : local := nil - htpSetProperty(htPage,'exclusion,first exclusions) - cAlist := htpProperty(htPage,'cAlist) - empty? := null cAlist - one? := null KDR cAlist - one? := empty? or one? - exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 - star? := true --always include information on exposed/unexposed 4/92 - if $standard then htBeginTable() - if one? or member('abbrs,exclusions) - then htSayCold '"\&Abbreviations" - else htMakePage [['bcLispLinks,['"\&Abbreviations",'"",'dbShowCons,'abbrs]]] - if one? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] - then htSayCold '"\&Conditions" - else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowCons,'conditions]]] - if empty? or member('documentation,exclusions) - then htSayCold '"\&Descriptions" - else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowCons,'documentation]]] - if one? or null CDR cAlist - then htSayCold '"\&Filter" - else htMakeSaturnFilterPage ['dbShowCons, 'filter] - if one? or member('kinds,exclusions) or kind ^= 'constructor - then htSayCold '"\&Kinds" - else htMakePage [['bcLispLinks,['"\&Kinds",'"",'dbShowCons,'kinds]]] - if one? or member('names,exclusions) - then htSayCold '"\&Names" - else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowCons,'names]]] - if one? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] - then htSayCold '"\&Parameters" - else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowCons,'parameters]]] - htSaySaturn '"\hrule" - if $exposedOnlyIfTrue - then - if one? then htSayCold '"\&Unexposed Also" - else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowCons,'exposureOff]]] - else - if one? then htSayCold '"\Exposed Only\&y" - else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowCons,'exposureOn]]] - if $standard then htEndTable() - $saturnContextMenuLines := $htLineList - -htFilterPage(htPage,args) == - htInitPage("Filter String",htCopyProplist htPage) - htSay "\centerline{Enter filter string (use {\em *} for wild card):}" - htSay '"\centerline{" - htMakePage [['bcStrings, [50,'"",'filter,'EM]]] - htSay '"}\vspace{1}\centerline{" - htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]] - htSay '"}" - htShowPage() - -htMakeSaturnFilterPage [fn2Call,:args] == - htSay '"\inputboxLink[\lispLink[d]{\verb+(|" - htSay fn2Call - htSay '"| " - htSay htpName $saturnPage - for x in args repeat - htSay '" '|" - htSay x - htSay '"|" - htSay '" _"+_\FILTERSTRING\verb+_")+}{}]{\FILTERSTRING}{*}" - htSay '"{\centerline{Enter filter string (use {\em *} for wild card):}}" - htSay '"{Filter Page}{\&Filter}" - -dbShowConsKinds cAlist == - cats := doms := paks := defs := nil - for x in cAlist repeat - op := CAAR x - kind := dbConstructorKind op - kind = 'category => cats := [x,:cats] - kind = 'domain => doms := [x,:doms] - kind = 'package => paks := [x,:paks] - defs := [x,:defs] - lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] - htBeginMenu 'description - htSayStandard '"\indent{1}" - kinds := +/[1 for x in lists | #x > 0] - firstTime := true - for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat - if firstTime then firstTime := false - else htSaySaturn '"\\" - htSaySaturn '"\item[" - htSayStandard '"\item" - if kinds = 1 - then htSay menuButton() - else htMakePage - [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] - htSaySaturn '"]" - htSayStandard '"\tab{1}" - htSay('"{\em ",c := #x,'" ") - htSay(c > 1 => pluralize kind; kind) - htSay '":}" - htSaySaturn '"\\" - bcConTable REMDUP [CAAR y for y in x] - htEndMenu 'description - htSayStandard '"\indent{0}" - -addParameterTemplates(page, conform) == ----------------> from kPage <----------------------- - parlist := [STRINGIMAGE par for par in rest conform] - manuelsCode? := "MAX"/[#s for s in parlist] > 10 - w := (manuelsCode? => 55; 23) - htSaySaturn '"\colorbuttonbox{lightgray}{" - htSay '"Optional argument value" - htSay - CDR parlist => '"s:" - '":" - htSaySaturn '"}" - if CDR conform then htSaySaturn '"\newline{}" - htSaySaturn '"\begin{tabular}{p{.25in}l}" - firstTime := true - odd := false - argSublis := htpProperty(page,'argSublis) - for parname in $PatternVariableList for par in rest conform repeat - htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}") - if firstTime then firstTime := false - else htSaySaturn '"\\" - odd := not odd - argstring := - $conArgstrings is [a,:r] => ($conArgstrings := r; a) - '"" - htMakePageStandard [['text,'"{\em ",par,'"} = "], - ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]] - if $saturn then - setUpDefault(parname, ['string, '"", 'EM, nil]) - htSaySaturn '"{\em " - htSaySaturn par - htSaySaturn '" = }" - htSaySaturnAmpersand() - htSaySaturn '"\colorbuttonbox{lightgray}{\inputbox[2.5in]{\" - htSaySaturn SUBLIS(argSublis,par) - htSaySaturn '"}{" - htSaySaturn argstring - htSaySaturn '"}}" - htEndTabular() - ---------------------> NEW DEFINITION (see br-con.boot.pamphlet) -kPageArgs([op,:args],[.,.,:source]) == - htSaySaturn '"\begin{tabular}{p{.25in}lp{0in}}" - firstTime := true - coSig := rest GETDATABASE(op,'COSIG) - for x in args for t in source for pred in coSig repeat - if firstTime then firstTime := false - else - htSaySaturn '"\\" - htSayStandard '", and" - htSayStandard '"\newline " - htSaySaturnAmpersand() - typeForm := (t is [":",.,t1] => t1; t) - if pred = true - then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] - else htSay('"{\em ",x,'"}") - htSayStandard( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") - htSaySaturnAmpersand() - htSay - pred => '"a domain of category " - '"an element of the domain " - bcConform(typeForm,true) - htEndTabular() - ---======================================================================= --- Redefinitions from br-op1.boot ---======================================================================= ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbConform form == ---one button for the main constructor page of a type - $saturn => ["\lispLink[d]{\verb!(|conPage| '",:form2Fence dbOuttran form,'")!}{", - :form2StringList opOf form,"}"] - ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -htTab s == if $standard then htSayStandard ('"\tab{",s,'"}") - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == - single? := null rest data - htBeginMenu 'description - bincount := 0 - for [thing,exposeFlag,:items] in data repeat - htSaySaturn '"\item[" - htSayStandard ('"\item") - if single? then htSay(menuButton()) - else - htMakePageStandard - [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] - button := mkButtonBox (1 + bincount) - htMakePageSaturn [['bcLinks,[button,'"",'dbShowOps,which,bincount]]] - htSaySaturn '"]" - htSay '"{\em " - htSay - thing = 'nowhere => '"implemented nowhere" - thing = 'constant => '"constant" - thing = '_$ => '"by the domain" - INTEGERP thing => '"unexported" - constructorIfTrue => - htSay word - atom thing => '" an unknown constructor" - '"" - atom thing => '"unconditional" - '"" - htSay '"}" - if null atom thing then - if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") - htSay '" " - FUNCALL(fn,thing) - htSay('":\newline ") - dbShowOpSigList(which,items,(1 + bincount) * 8192) - bincount := bincount + 1 - htEndMenu 'description - ---------------------> NEW DEFINITION (see br-op1.boot.pamphlet) -dbPresentOps(htPage,which,:exclusions) == - $saturn => dbPresentOpsSaturn(htPage,which,exclusions) - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := nil - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - one? := opAlist is [entry] and 2 = #entry - one? := empty? or one? - htBeginTable() - htSay '"{" - if one? or member('conditions,exclusions) - or (htpProperty(htPage,'condition?) = 'no) - then htSay '"{\em Conditions}" - else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]] - htSay '"}{" - if empty? or member('documentation,exclusions) - then htSay '"{\em Descriptions}" - else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]] - htSay '"}{" - if null IFCDR opAlist - then htSay '"{\em Filter}" - else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]] - htSay '"}{" - if one? or member('names,exclusions) or null KDR opAlist - then htSay '"{\em Names}" - else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]] - if not star? then - htSay '"}{" - if not implementation? or member('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSay '"{\em Implementations}" - else htMakePage - [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] - htSay '"}{" - if one? or member('origins,exclusions) - then htSay '"{\em Origins}" - else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]] - htSay '"}{" - if one? or member('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSay '"{\em Parameters}" - else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]] - htSay '"}{" - if which ^= '"attribute" then - if one? or member('signatures,exclusions) - then htSay '"{\em Signatures}" - else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]] - htSay '"}" - if star? then - htSay '"{" - if $exposedOnlyIfTrue - then if one? - then htSay '"{\em Unexposed Also}" - else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] - else if one? - then htSay '"{\em Exposed Only}" - else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]] - htSay '"}" - htEndTable() - -dbPresentOpsSaturn(htPage,which,exclusions) == - $htLineList : local := nil - $newPage : local := nil - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := nil - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - one? := opAlist is [entry] and 2 = #entry - one? := empty? or one? - if one? or member('conditions,exclusions) - or (htpProperty(htPage,'condition?) = 'no) - then htSayCold '"\&Conditions" - else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowOps,which,'conditions]]] - if empty? or member('documentation,exclusions) - then htSayCold '"\&Descriptions" - else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowOps,which,'documentation]]] - if null IFCDR opAlist - then htSayCold '"\&Filter" - else htMakeSaturnFilterPage ['dbShowOps, which, 'filter] - if not implementation? or member('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSayCold '"\&Implementations" - else htMakePage - [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]] - if one? or member('names,exclusions) or null KDR opAlist - then htSayCold '"\&Names" - else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowOps,which,'names]]] - if one? or member('origins,exclusions) - then htSayCold '"\&Origins" - else htMakePage [['bcLispLinks,['"\&Origins",'"",'dbShowOps,which,'origins]]] - if one? or member('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSayCold '"\&Parameters" - else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowOps,which,'parameters]]] - if which ^= '"attribute" then - if one? or member('signatures,exclusions) - then htSayCold '"\&Signatures" - else htMakePage [['bcLispLinks,['"\&Signatures",'"",'dbShowOps,which,'signatures]]] - if star? then - htSay '"\hrule" - if $exposedOnlyIfTrue - then if one? then htSayCold '"\&Unexposed Also" - else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] - else - if one? then htSayCold '"Exposed Onl\&y" - else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowOps,which,'exposureOn]]] - $saturnContextMenuLines := $htLineList - ---======================================================================= --- Redefinitions from br-search.boot ---======================================================================= ----------------------> OLD DEFINITION (override in br-search.boot.pamphlet) -htShowPageStar() == - $saturn => htShowPageStarSaturn() - htSayStandard '"\endscroll " - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] - else - htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] - htShowPageNoScroll() - -htShowPageStarSaturn() == - $newPage : local := nil - $htLineList : local := nil - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] - else - htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] - $saturnContextMenuLines := $htLineList - htShowPageNoScroll() - ---======================================================================= --- Redefinitions from br-op2.boot ---======================================================================= - ---------------> NEW DEFINITION (see br-op2.boot.pamphlet) -displayDomainOp(htPage,which,origin,op,sig,predicate, - doc,index,chooseFn,unexposed?,$generalSearch?) == - $chooseDownCaseOfType : local := true --see dbGetContrivedForm - $whereList : local := nil - $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) - $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) - $FunctionList:local := '(f g h d e F G H) - $DomainList: local := '(D R S E T A B C M N P Q U V W) - exactlyOneOpSig := null index - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - or origin - if $generalSearch? then $DomainList := rest $DomainList - opform := - which = '"attribute" => - null sig => [op] - [op,sig] - which = '"constructor" => origin - dbGetDisplayFormForOp(op,sig,doc) - htSayStandard('"\newline") - ----------------------------------------------------------- - htSaySaturn '"\item[" - if exactlyOneOpSig - then htSay menuButton() - else htMakePage - [['bcLinks,[menuButton(),'"",chooseFn,which,index]]] - htSaySaturn '"]" - htSayStandard '"\tab{2}" - op := IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - n := #sig - do - n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") - if unexposed? and $includeUnexposed? then - htSayUnexposed() - htSay(ops) - predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip - which = '"attribute" and null args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",quickForm2HtString x,'"}") - htSay('")") - -----------prepare to print description--------------------- - constring := form2HtString conform - conname := first conform - $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" - or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) - $conlength : local := #constring - $conform : local := conform - $conargs : local := rest conform - if which = '"operation" then - $signature : local := - MEMQ(conname,$Primitives) => nil - CDAR getConstructorModemap conname - --RDJ: this next line is necessary until compiler bug is fixed - --that forgets to substitute #variables for t#variables; - --check the signature for SegmentExpansionCategory, e.g. - tvarlist := TAKE(# $conargs,$TriangleVariableList) - $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) - $sig := - which = '"attribute" or which = '"constructor" => sig - $conkind ^= '"package" => sig - symbolsUsed := [x for x in rest conform | IDENTP x] - $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) - getSubstSigIfPossible sig - ----------------------------------------------------------- - htSaySaturn '"\begin{tabular}{lp{0in}}" - ----------------------------------------------------------- - if member(which,'("operation" "constructor")) then - $displayReturnValue: local := nil - if args then - htSayStandard('"\newline\tab{2}{\em Arguments:}") - htSaySaturn '"{\em Arguments:}" - htSaySaturnAmpersand() - firstTime := true - coSig := KDR GETDATABASE(op,'COSIG) --check if op is constructor - for a in args for t in rest $sig repeat - if not firstTime then - htSaySaturn '"\\ " - htSaySaturnAmpersand() - firstTime := false - htSayIndentRel(15, true) - position := KAR relatives - relatives := KDR relatives - if KAR coSig and t ^= '(Type) - then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]] - else htSay('"{\em ",form2HtString(a),'"}") - htSay ", " - coSig := KDR coSig - htSayValue t - htSayIndentRel(-15,true) - htSayStandard('"\newline ") - htSaySaturn '"\\" - if first $sig then - $displayReturnValue := true - htSayStandard('"\newline\tab{2}") - htSay '"{\em Returns:}" - htSaySaturnAmpersand() - htSayIndentRel(15, true) - htSayValue first $sig - htSayIndentRel(-15, true) - htSaySaturn '"\\" - ----------------------------------------------------------- - if origin and ($generalSearch? or origin ^= conform) and op^=opOf origin then - htSaySaturn '"{\em Origin:}" - htSaySaturnAmpersand() - htSayStandard('"\newline\tab{2}{\em Origin:}") - htSayIndentRel(15) - if not isExposedConstructor opOf origin and $includeUnexposed? - then htSayUnexposed() - bcConform(origin,true) - htSayIndentRel(-15) - htSaySaturn '"\\" - ----------------------------------------------------------- - if not MEMQ(predicate,'(T ASCONST)) then - pred := sublisFormal(KDR conform,predicate) - count := #pred - htSaySaturn '"{\em Conditions:}" - htSayStandard('"\newline\tab{2}{\em Conditions:}") - firstTime := true - for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat - if not firstTime then htSaySaturn '"\\" - htSayIndentRel(15,count > 1) - firstTime := false - htSaySaturnAmpersand() - bcPred(p,$conform,true) - htSayIndentRel(-15,count > 1) - htSayStandard('"\newline ") - htSaySaturn '"\\" - ----------------------------------------------------------- - if $whereList then - count := #$whereList - htSaySaturn '"{\em Where:}" - htSayStandard('"\newline\tab{2}{\em Where:}") - firstTime := true - if ASSOC("$",$whereList) then - htSayIndentRel(15,true) - htSaySaturnAmpersand() - htSayStandard '"{\em \$} is " - htSaySaturn '"{\em \%} is " - htSay - $conkind = '"category" => '"of category " - '"the domain " - bcConform(conform,true,true) - firstTime := false - htSayIndentRel(-15,true) - for [d,key,:t] in $whereList | d ^= "$" repeat - htSayIndentRel(15,count > 1) - if not firstTime then htSaySaturn '"\\ " - htSaySaturnAmpersand() - firstTime := false - htSay("{\em ",d,"} is ") - htSayConstructor(key,sublisFormal(KDR conform,t)) - htSayIndentRel(-15,count > 1) - htSaySaturn '"\\" - ----------------------------------------------------------- - if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then - htSaySaturn '"{\em Description:}" - htSaySaturnAmpersand() - htSayStandard('"\newline\tab{2}{\em Description:}") - htSayIndentRel(15) - if doc = $charFauxNewline then htSay $charNewline - else - ndoc:= - -- we are confused whether doc is a string or a list of strings - CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] - SUBSTITUTE($charNewline, $charFauxNewline,doc) - htSay ndoc --- htSaySaturn '"\\" - htSayIndentRel(-15) - --------> print abbr and source file for constructors <--------- - if which = '"constructor" then - if (abbr := GETDATABASE(conname,'ABBREVIATION)) then - htSaySaturn '"\\" - htSaySaturn '"{\em Abbreviation:}" - htSaySaturnAmpersand() - htSayStandard('"\tab{2}{\em Abbreviation:}") - htSayIndentRel(15) - htSay abbr - htSayIndentRel(-15) - htSayStandard('"\newline{}") - if ( $saturn and (link := saturnHasExamplePage conname)) then - htSaySaturn '"\\" - htSaySaturn '"{\em Examples:}" - htSaySaturnAmpersand() - htSayIndentRel(15) - htSay '"\spadref{" - htSay CAR(CDR(link)) - htSay '"}" - htSayIndentRel(-15) - htSayStandard('"\newline{}") - htSaySaturn '"\\" - htSaySaturn '"{\em Source File:}" - htSaySaturnAmpersand() - htSayStandard('"\tab{2}{\em Source File:}") - htSayIndentRel(15) - htSaySourceFile conname - htSayIndentRel(-15) - ------------------> remove profile printouts for now <------------------- - if $standard and - exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then - displayInfoOp(htPage,infoAlist,op,sig) - ----------------------------------------------------------- - htSaySaturn '"\end{tabular}" - -htSaySourceFile conname == - sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none") - filename := extractFileNameFromPath sourceFileName - htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", - sourceFileName, '" ", conname, '"}"]] - ---------------------> NEW DEFINITION (see br-op2.boot.pamphlet) -htSayIndentRel(n,:options) == - flag := IFCAR options - m := ABSVAL n - if flag then m := m + 2 - if $standard then htSayStandard - n > 0 => - flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] - ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] - n < 0 => ['"\indent{0}\newline "] - -htSayUnexposed() == - htSay '"{\em *}" - $atLeastOneUnexposed := true ---======================================================================= --- Page Operations ---======================================================================= - -htEndTabular() == - htSaySaturn '"\end{tabular}" - -htPopSaturn s == - pageDescription := ELT($saturnPage, 7) - pageDescription is [=s,:b] => SETELT($saturnPage, 7, CDR pageDescription) - nil - -htBeginTable() == - htSaySaturn '"\begin{dirlist}[lv]" - htSayStandard '"\table{" - -htEndTable() == - htSaySaturn '"\end{dirlist}" - htSayStandard '"}" - -htBeginMenu(kind,:options) == - skip := IFCAR options - if $saturn then - kind = 'description => htSaySaturn '"\begin{description}" - htSaySaturn '"\begin{tabular}" - htSaySaturn - kind = 3 => '"{llp{0in}}" - kind = 2 => '"{lp{0in}}" - error nil - null skip => htSayStandard '"\beginmenu " - nil - -htEndMenu(kind) == - if $saturn then - kind = 'description => htSaySaturn '"\end{description}" - htPopSaturn '"\\" - htSaySaturn '"\end{tabular}" - htSayStandard '"\endmenu " - -htSayConstructorName(nameShown, name) == - if $saturn then - code := ['"(|conPage| '|", name, '"|)"] - htSaySaturn mkDocLink(code,nameShown) - if $standard then - htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"] - ---------------------> NEW DEFINITION (see ht-util.boot.pamphlet) -htAddHeading(title) == - htNewPage title - page() - -------------> called by htAddHeading, htInitPageNoScroll <----------- -htNewPage title == - if $saturn then - htSaySaturn '"\browseTitle{" - htSaySaturn title - htSaySaturn '"}" - if $standard then htSayStandard('"\begin{page}{", htpName $curPage, '"}{") - htSayStandard title - htSayStandard '"}" - ---======================================================================= --- Utilities ---======================================================================= -mkTabularItem u == [:first u,:fn rest u] where fn x == - null x => nil - [$saturnAmpersand, x,:fn rest x] - -htSaySaturnAmpersand() == htSaySaturn $saturnAmpersand - -htBlank(:options) == - options is [n] => - htSaySaturn("STRCONC"/['"\phantom{*}" for i in 1..n]) - htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}") - htSaySaturn '"\phantom{*}" - htSayStandard '"\space{1}" - -unTab s == - STRINGP s => unTab1 s - atom s => s - [unTab1 first s, :rest s] - -unTab1 s == - STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) => - SUBSTRING(s, k + 1, nil) - s - -satBreak() == - htSaySaturn '"\\ " - htSayStandard '"\item " - -htBigSkip() == - htSaySaturn '"\bigskip{}" - htSayStandard '"\vspace{1}\newline " - -htSaturnBreak() == htSaySaturn '"\!" - -satDownLink(s,code) == - htSaySaturn '"\lispFunctionLink{\verb!" - htSaySaturn code - htSaySaturn '"!}{" - htSaySaturn s - htSaySaturn '"}" - ------------------ - htSayStandard '"\lispdownlink{" - htSayStandard s - htSayStandard '"}{" - htSayStandard code - htSayStandard '"}" - -satTypeDownLink(s,code) == - htSaySaturn '"\lispLink[d]{\verb!" - htSaySaturn code - htSaySaturn '"!}{" - htSaySaturn s - htSaySaturn '"}" - ------------------ - htSayStandard '"\lispdownlink{" - htSayStandard s - htSayStandard '"}{" - htSayStandard code - htSayStandard '"}" - -mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}") - ---======================================================================= --- Create separate databases for operations, constructors ---======================================================================= ------------> use br-data.boot definition ---dbSplitLibdb() == ---This function splits lidbd.text into files to make searching quicker. --- alibdb.text attributes --- clibdb.text categories --- dlibdb.text domains --- plibdb.text packages --- olibdb.text operations --- xlibdb.text default packages ---These files have the same format as the single file libdb.text did in old --- version: e.g. `````` --- for constructors where is a single character, one of acdopx --- (identifying it as an attribute, category, domain, operator, package, --- or default package), its name, number of arguments, whether exposed or --- unexposed, its signature (sometimes abbreviated), its arguments as given --- in the original definition, its abbreviation, and documentation. --- For example, domain Matrix has line "dMatrix`1`x``(R)`MATRIX`" --- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". --- The comment field contains the character address of the comments --- for Matrix in file comdb.text. ---There is thus ONE file comdb.text for documentation of all structures --- (to facilitate a general search through all documentation) --- into for comments. The format of entries in comdb.text are lines with --- two fields of the form d`, where is the character --- address of the line "dMatrix`.." in dlibdb.text (the first character --- "d" tells which lidbdb file it comes from, the is the --- documentation for Matrix. ---NOTE: In each file, the first character, one of acdpox, is retained --- so that lines have the same format as the previous version of the browser --- (this minimized the number of lines of code that had to be changed from --- previous version of the browser). --- key := nil --dummy first key --- instream := MAKE_-INSTREAM '"libdb.text" --- comstream := MAKE_-OUTSTREAM '"comdb.text" --- PRINTEXP(0, comstream) --- PRINTEXP($tick,comstream) --- PRINTEXP('"", comstream) --- TERPRI(comstream) --- while not EOFP instream repeat --- line := READLINE instream --- comP := FILE_-POSITION comstream --- if key ^= line.0 then --- if outstream then SHUT outstream --- key := line . 0 --- outstream := MAKE_-OUTSTREAM STRCONC(STRINGIMAGE key,'"libdb.text") --- outP := FILE_-POSITION outstream --- [prefix,:comments] := dbSplit(line,6,1) --- PRINTEXP(prefix,outstream) --- PRINTEXP($tick ,outstream) --- null comments => --- PRINTEXP(0,outstream) --- TERPRI(outstream) --- PRINTEXP(comP,outstream) --- TERPRI(outstream) --- PRINTEXP(key, comstream) --identifies file the backpointer is to --- PRINTEXP(outP ,comstream) --- PRINTEXP($tick ,comstream) --- PRINTEXP(first comments,comstream) --- TERPRI(comstream) --- for c in rest comments repeat --- PRINTEXP(key, comstream) --identifies file the backpointer is to --- PRINTEXP(outP ,comstream) --- PRINTEXP($tick ,comstream) --- PRINTEXP(c, comstream) --- TERPRI(comstream) --- SHUT instream --- SHUT outstream --- SHUT comstream ---OBEY '"rm libdb.text" - -dbSort(x,y) == - sin := STRINGIMAGE x - sout:= STRINGIMAGE y - OBEY STRCONC('"sort -f _"",sin,'".text_" > _"", sout, '".text_"") - OBEY STRCONC('"rm ", sin, '".text") - - ---======================================================================= --- from define.boot ---======================================================================= -----------------------> (override in define.boot.pamphlet) -compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], - m,oldE,$prefix,$formalArgList) == - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - - --replace ##1,.. in signature by arguments --- pp signature' - signature':= SUBLISLIS(argl,$FormalFunctionParameterList,signature') --- pp '"------after----" --- pp signature' - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null member($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not member($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] - - if $newComp = true then - wholeBody := ['DEF, form, signature', specialCases, body] - T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) - or [" ",rettype,e] - T := [T.expr.2.2, rettype, T.env] - if $newCompCompare=true then - oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] - SAY '"The old compiler generates:" - prTriple oldT - SAY '"The new compiler generates:" - prTriple T - else - T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] ---+ - NRTassignCapsuleFunctionSlot($op,signature') - if $newCompCompare=true then - SAY '"The old compiler generates:" - prTriple T --- A THROW to the above CATCH occurs if too many semantic errors occur --- see stackSemanticError - catchTag:= MKQ GENSYM() - fun:= - body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) - body':= addArgumentConditions(body',$op) - finalBody:= ["CATCH",catchTag,body'] - compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) - $functorStats:= addStats($functorStats,$functionStats) - - --- 7. give operator a 'value property - val:= [fun,signature',e] - [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) - ---from postpar ---------------------> NEW DEFINITION (override in postpar.boot.pamphlet) -postSignature ['Signature,op,sig] == - sig is ["->",:.] => - sig1:= postType sig - op:= postAtom (STRINGP op => INTERN op; op) - ["SIGNATURE",op,:removeSuperfluousMapping killColons postDoubleSharp sig1] - -postDoubleSharp sig == - sig is [['Mapping,target,:r]] => - -- replace #1,... by ##1,... - [['Mapping, SUBLISLIS($FormalFunctionParameterList, $FormalMapVariableList, target), - :r]] - sig - --- override in br-util.boot.pamphlet -bcConform1 form == main where - main == - form is ['ifp,form1,:pred] => - hd form1 - bcPred pred - hd form - hd form == - atom form => - not MEMQ(form,$Primitives) and null constructor? form => - s := STRINGIMAGE form - (s.0 = char '_#) => - (n := POSN1(form, $FormalFunctionParameterList)) => - htSay form2HtString ($FormalMapVariableList . n) - htSay '"\" - htSay form - htSay escapeSpecialChars STRINGIMAGE form - s := STRINGIMAGE form - $italicHead? => htSayItalics s - $bcMultipleNames => - satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) - satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) - (head := QCAR form) = 'QUOTE => - htSay('"'") - hd CADR form - head = 'SIGNATURE => - htSay(CADR form,'": ") - mapping CADDR form - head = 'Mapping and rest form => rest form => mapping rest form - head = ":" => - hd CADR form - htSay '": " - hd CADDR form - QCDR form and dbEvalableConstructor? form - => bcConstructor(form,head) - hd head - null (r := QCDR form) => nil - tl QCDR form - mapping [target,:source] == - tuple source - bcHt - $saturn => '" {\ttrarrow} " - '" -> " - hd target - tuple u == - null u => bcHt '"()" - null rest u => hd u - bcHt '"(" - hd first u - for x in rest u repeat - bcHt '"," - hd x - bcHt '")" - tl u == - bcHt '"(" - firstTime := true - for x in u repeat - if not firstTime then bcHt '"," - firstTime := false - hd x - bcHt '")" - say x == - if $italics? then bcHt '"{\em " - if x = 'etc then x := '"..." - bcHt escapeSpecialIds STRINGIMAGE x - if $italics? then bcHt '"}" - ---======================================================================= --- Code for Private Libdbs ---======================================================================= ---extendLocalLibdb conlist == --called by function "compiler"(see above) --- buildLibdb conlist --> puts datafile into temp.text --- $newConstructorList := union(conlist, $newConstructorList) --- localLibdb := '"libdb.text" --- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text") --- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) --- newlines := dbReadLines '"temp.text" --- dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text") --- deleteFile '"temp.text" - -purgeNewConstructorLines(lines, conlist) == - [x for x in lines | not screenLocalLine(x, conlist)] - --- Got rid of debugging statement and deleted screenLocalLine1, MCD 26/3/96 ---screenLocalLine(line,conlist) == --- u := screenLocalLine1(line,conlist) --- if u then --- sayBrightly ['"Purging--->", line] --- u - --- screenLocalLine1(line, conlist) == -screenLocalLine(line, conlist) == - k := dbKind line - con := INTERN - k = char 'o or k = char 'a => - s := dbPart(line,5,1) - k := charPosition(char '_(,s,1) - SUBSTRING(s,1,k - 1) - dbName line - MEMQ(con, conlist) - ---------------> NEW DEFINITION (see br-data.boot.pamphlet) -purgeLocalLibdb() == --called by the user through a clear command? - $newConstructorList := nil - deleteFile '"libdb.text" - ---moveFile(before,after) == --- $saturn => MOVE_-FILE(before, after) --- RENAME_-FILE(before, after) --- --obey STRCONC('"mv ", before, '" ", after) - --- deleted JHD/MCD, since already one in pathname.boot ---deleteFile fn == --- $saturn => DELETE_-FILE fn --- obey STRCONC('"rm ",fn) - ---======================================================================= --- from DAASE.LISP ---======================================================================= ---library(args) == --- $newConlist: local := nil --- LOCALDATABASE(args,$options) --- extendLocalLibdb $newConlist --- TERSYSCOMMAND() - - diff --git a/src/interp/br-saturn.boot.pamphlet b/src/interp/br-saturn.boot.pamphlet new file mode 100644 index 00000000..46b53f9d --- /dev/null +++ b/src/interp/br-saturn.boot.pamphlet @@ -0,0 +1,1916 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-saturn.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS b-saturn.boot <================================ +-- New file as of 6/95 +$aixTestSaturn := false +--These will be set in patches.lisp: +--$saturn := false --true to write SATURN output to $browserOutputStream +--$standard:= true --true to write browser output on AIX +$saturnAmpersand := '"\&\&" +$saturnFileNumber --true to write DOS files for Thinkpad (testing only) + := false +$kPageSaturnArguments := nil --bound by $kPageSaturn +$atLeastOneUnexposed := false +$saturnContextMenuLines := nil +$saturnContextMenuIndex := 0 +$saturnMacros := '( + "\def\unixcommand#1#2{{\em #1}}"_ + "\def\lispFunctionLink#1#2{\lispLink[d]{#1}{{\bf #2}}}"_ + "\def\lispTypeLink#1#2{\lispLink[d]{#1}{{\sf #2}}}"_ + "\def\menuitemstyle{\menubutton}"_ + "\def\browseTitle#1{\windowTitle{#1}\section{#1}}"_ + "\def\ttrarrow{$\rightarrow$}"_ + "\def\spadtype#1{\lispLink[d]{\verb!(|spadtype| '|#1|)!}{\sf #1}}"_ + "\def\spad#1{{\em #1}}"_ + "\def\spadfun#1{{\em #1}}"_ +) +$FormalFunctionParameterList := '(_#_#1 _#_#2 _#_#3 _#_#4 _#_#5 _#_#6 _#_#7 _#_#8 _#_#9 _#_#10 _#_#11 _#_#12 _#_#13 _#_#14 _#_#15) + +on() == + $saturn := true + $standard := false +off()== + $saturn := false + $standard := true + +--======================================================================= +-- Function for testing SATURN output +--======================================================================= +-- protectedEVAL x == +-- $saturn => +-- protectedEVAL0(x, true, false) +-- if $aixTestSaturn then protectedEVAL0(x, false, true) +-- protectedEVAL1 x +-- +--protectedEVAL0(x, $saturn, $standard) == +-- protectedEVAL1 x +-- +--protectedEVAL1 x == +-- error := true +-- val := NIL +-- UNWIND_-PROTECT((val := saturnEVAL x; error := NIL), +-- error => (resetStackLimits(); sendHTErrorSignal())) +-- val +-- +--saturnEVAL x == +-- fn := +-- $aixTestSaturn => '"/tmp/sat.text" +-- '"/windows/temp/browser.text" +-- $saturn => +-- saturnEvalToFile(x, fn) +-- OBEY '"cat /tmp/sat.text" +-- EVAL x + + +--======================================================================= +-- Functions to write DOS files to disk +--======================================================================= +ts(command) == + $saturn := true + $saturnFileNumber := false + $standard := false + saturnEvalToFile(command, '"/tmp/sat.text") + +ut() == + $saturn := false + $standard := true + 'done + +onDisk() == + $saturnFileNumber := 1 + obey '"dosdir" + +offDisk() == + $saturnFileNumber := false + +page() == + $standard => $curPage + $saturnPage +--======================================================================= +-- Functions that affect $saturnPage +--======================================================================= + +--------------------> OLD DEFINITION (override in br-util.boot.pamphlet) +htSay(x,:options) == --say for possibly both $saturn and standard code + htSayBind(x, options) + +htSayCold x == + htSay '"\lispLink{}{" + htSay x + htSay '"}" + +htSayIfStandard(x, :options) == --do only for $standard + $standard => htSayBind(x,options) + +htSayStandard(x, :options) == --do AT MOST for $standard + $saturn: local := nil + htSayBind(x, options) + +htSaySaturn(x, :options) == --do AT MOST for $saturn + $standard: local := nil + htSayBind(x, options) + +htSayBind(x, options) == + bcHt x + for y in options repeat bcHt y + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +bcHt line == + $newPage => --this path affects both saturn and old lines + text := + PAIRP line => [['text, :line]] + STRINGP line => line + [['text, line]] + if $saturn then htpAddToPageDescription($saturnPage, text) + if $standard then htpAddToPageDescription($curPage, text) + PAIRP line => + $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) + $htLineList := [basicStringize line, :$htLineList] + +--======================================================================= +-- New issueHT +--======================================================================= + +--------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +htShowPage() == +-- show the page which has been computed + htSayStandard '"\endscroll" + htShowPageNoScroll() + +------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +htShowPageNoScroll() == +-- show the page which has been computed + htSayStandard '"\autobuttons" + if $standard then + htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) + if $saturn then + htpSetPageDescription($saturnPage, nreverse htpPageDescription $saturnPage) + $newPage := false + ---------------------- + if $standard then + $htLineList := nil + htMakePage htpPageDescription $curPage + if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) + issueHTStandard line + ---------------------- + if $saturn then + $htLineList := nil + htMakePage htpPageDescription $saturnPage + if $htLineList then line := APPLY(function CONCAT, nreverse $htLineList) + issueHTSaturn line + ---------------------- + endHTPage() + +--------------------> NEW DEFINITION <-------------------------- +issueHTSaturn line == --called by htMakePageNoScroll and htMakeErrorPage + if $saturn then + $marg : local := 0 + $linelength: local := 80 + writeSaturn '"\inputonce{/doc/browser/browmacs.tex}" + writeSaturnPrefix() + writeSaturn(line) + writeSaturnSuffix() + if $saturnFileNumber then + fn := STRCONC('"sat", STRINGIMAGE $saturnFileNumber, '".tex") + obey STRCONC('"doswrite -a saturn.tex ",fn, '".tex") + $saturnFileNumber := $saturnFileNumber + 1 + +writeSaturnPrefix() == + $saturnContextMenuLines => + index := + STRINGIMAGE ($saturnContextMenuIndex := $saturnContextMenuIndex + 1) + writeSaturnLines + ['"\newmenu{BCM", index, + '"}{",:nreverse $saturnContextMenuLines, + '"}\usemenu{BCM", index,'"}{\vbox{"] + +writeSaturnSuffix() == + $saturnContextMenuLines => saturnPRINTEXP '"}}" + +issueHTStandard line == --called by htMakePageNoScroll and htMakeErrorPage + if $standard then + --unescapeStringsInForm line + sockSendInt($MenuServer, $SendLine) + sockSendString($MenuServer, line) + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htMakeErrorPage htPage == + $newPage := false + $htLineList := nil + if $standard then $curPage := htPage + if $saturn then $saturnPage := htPage + htMakePage htpPageDescription htPage + line := APPLY(function CONCAT, nreverse $htLineList) + issueHT line + endHTPage() + +writeSaturnLines lines == + for line in lines repeat + if line ^= '"" and line.0 = char '_\ then saturnTERPRI() + saturnPRINTEXP line + +writeSaturn(line) == + k := 0 + n := MAXINDEX line + while --advance k if true + k > n => false + line.k ^= char '_\ => true + code := isBreakSegment?(line, k + 1,n) => false + true + repeat (k := k + 1) + k > n => writeSaturnPrint(line) + segment := SUBSTRING(line,0,k) + writeSaturnPrint(segment) + code = 1 => + writeSaturnPrint('"\\") + writeSaturn SUBSTRING(line,k + 2, nil) + code = 2 => + writeSaturnPrint('" &") + writeSaturn SUBSTRING(line,k + 4, nil) + code = 3 => + writeSaturnPrint('"\item") + writeSaturn SUBSTRING(line,k + 5,nil) + code = 4 => + writeSaturnPrint('"\newline") + writeSaturn SUBSTRING(line,k + 8,nil) + code = 5 => + writeSaturnPrint('"\table{") + $marg := $marg + 3 + writeSaturnTable SUBSTRING(line,k + 7,nil) + code = 6 => + i := charPosition(char '_},line,k + 4) + tabCode := SUBSTRING(line,k, i - k + 1) + writeSaturnPrint tabCode + line := SUBSTRING(line,i + 1, nil) + writeSaturn line + code = 7 => + saturnTERPRI() + writeSaturn SUBSTRING(line, k + 2,nil) + code = 8 => + i := + substring?('"\beginmenu", line,k) => k + 9 + substring?('"\beginscroll",line,k) => k + 11 + charPosition(char '_},line,k) + if char '_[ = line.(i + 1) then + i := charPosition(char '_], line, i + 2) + beginCode := SUBSTRING(line,k, i - k + 1) + writeSaturnPrint(beginCode) + line := SUBSTRING(line,i + 1,nil) + writeSaturn line + code = 9 => + i := + substring?('"\endmenu",line,k) => k + 7 + substring?('"\endscroll",line,k) => k + 9 + charPosition(char '_},line,k) + endCode := SUBSTRING(line,k, i - k + 1) + writeSaturnPrint(endCode) + line := SUBSTRING(line,i + 1,nil) + $marg := $marg - 3 + writeSaturn line + systemError code + +isBreakSegment?(line, k, n) == + k > n => nil + char2 := line . k + char2 = (char '_\) => 1 + char2 = (char '_&) => + substring?('"&\&", line, k) => 2 + nil + char2 = char 'i => + substring?('"item",line,k) => 3 + nil + char2 = char 'n => + substring?('"newline",line,k) => 4 + nil + char2 = char 't => + (k := k + 2) > n => nil + line.(k - 1) = char 'a and line.k = char 'b => + (k := k + 1) > n => nil + line.k = char "{" => 6 + substring?('"table",line,k - 3) => 5 + nil + char2 = (char '_!) => 7 + char2 = char 'b => + substring?('"begin",line,k) => 8 + nil + char2 = (char 'e) => + substring?('"end",line,k) => 9 + nil + nil + +writeSaturnPrint s == + for i in 0..($marg - 1) repeat saturnPRINTEXP '" " + saturnPRINTEXP s + saturnTERPRI() + +saturnPRINTEXP s == + $browserOutputStream => PRINTEXP(s,$browserOutputStream) + PRINTEXP s + +saturnTERPRI() == + $browserOutputStream => TERPRI($browserOutputStream) + TERPRI() + +writeSaturnTable line == + open := charPosition(char '"_{",line,0) + close:= charPosition(char '"_}",line,0) + open < close => + close := findBalancingBrace(line,open + 1,MAXINDEX line,0) or error '"no balancing brace" + writeSaturnPrint SUBSTRING(line,0,close + 1) + writeSaturnTable SUBSTRING(line,close + 1,nil) + $marg := $marg - 3 + writeSaturnPrint SUBSTRING(line,0,close + 1) + writeSaturn SUBSTRING(line, close + 1,nil) + +findBalancingBrace(s,k,n,level) == + k > n => nil + c := s . k + c = char '_{ => findBalancingBrace(s, k + 1, n, level + 1) + c = char '_} => + level = 0 => k + findBalancingBrace(s, k + 1, n, level - 1) + findBalancingBrace(s, k + 1, n, level) + +--======================================================================= +-- htMakePage and friends +--======================================================================= +htMakePageStandard itemList == + $saturn => nil + htMakePage itemList + +htMakePageSaturn itemList == + $standard => nil + htMakePage itemList + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htMakePage itemList == + if $newPage then + if $saturn then htpAddToPageDescription($saturnPage, saturnTran itemList) + if $standard then htpAddToPageDescription($curPage, itemList) + htMakePage1 itemList + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htMakePage1 itemList == +-- make a page given the description in itemList + for u in itemList repeat + itemType := 'text + items := + STRINGP u => u + ATOM u => STRINGIMAGE u + STRINGP first u => u + u is ['text, :s] => s + itemType := first u + rest u + itemType = 'text => iht items +-- $saturn => bcHt items +-- $standard => iht items + itemType = 'lispLinks => htLispLinks items + itemType = 'lispmemoLinks => htLispMemoLinks items + itemType = 'bcLinks => htBcLinks items ---> + itemType = 'bcLinksNS => htBcLinks(items,true) + itemType = 'bcLispLinks => htBcLispLinks items ---> + itemType = 'radioButtons => htRadioButtons items + itemType = 'bcRadioButtons => htBcRadioButtons items + itemType = 'inputStrings => htInputStrings items + itemType = 'domainConditions => htProcessDomainConditions items + itemType = 'bcStrings => htProcessBcStrings items + itemType = 'toggleButtons => htProcessToggleButtons items + itemType = 'bcButtons => htProcessBcButtons items + itemType = 'doneButton => htProcessDoneButton items + itemType = 'doitButton => htProcessDoitButton items + systemError '"unexpected branch" + +saturnTran x == + x is [[kind, [s1, s2, :callTail]]] and MEMQ(kind,'(bcLinks bcLispLinks)) => + text := saturnTranText s2 + fs := getCallBackFn callTail + y := isMenuItemStyle? s1 => ----> y is text for button in 2nd column + t1 := mkDocLink(fs, mkMenuButton()) + y = '"" => + s2 = '"" => t1 + mkTabularItem [t1, text] + t2 := mkDocLink(fs, y) + mkTabularItem [t1, t2, text] + t := mkDocLink(fs, s1) + [:t, :text] + x is [['text,:r],:.] => r + error nil + +mkBold s == + secondPart := + atom s => [s, '"}"] + [:s, '"}"] + ['"{\bf ", :secondPart] + +mkMenuButton() == [menuButton()] + +menuButton() == '"\menuitemstyle{}" +-- Saturn must translate \menuitemstyle ==> {\menuButton} + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +--replaces htMakeButton +getCallBackFn form == + func := mkCurryFun(first form, rest form) + STRCONC('"(|htDoneButton| '|", func, '"| ",htpName page(), '")") + +mkDocLink(code,s) == + if atom code then code := [code] + if atom s then s := [s] + ['"\lispLink[d]{\verb!", :code, '"!}{", :s, '"}"] + +saturnTranText x == + STRINGP x => [unTab x] + null x => nil + r is [s,fn,:.] and s = '"\unixcommand{" => ['"{\it ",s,'".spad}"] + x is [['text, :s],:r] => unTab [:s, :saturnTranText r] + error nil + +isMenuItemStyle? s == + 15 = STRING_<('"\menuitemstyle{", s) => SUBSTRING(s,15,(MAXINDEX s) - 15) + nil + +getCallBack callTail == + LASSOC(callTail, $callTailList) or + callTail is [fn] => callTail + error nil + +--======================================================================= +-- Redefinitions from hypertex.boot +--======================================================================= +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +endHTPage() == + $standard => sockSendInt($MenuServer, $EndOfPage) + nil + +--======================================================================= +-- Redefinitions from ht-util.boot +--======================================================================= +htSayHrule() == bcHt + $saturn => '"\hrule{}\newline{}" + '"\horizontalline{}\newline{}" + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htpAddInputAreaProp(htPage, label, prop) == +------------> Add STRINGIMAGE + SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htpSetLabelInputString(htPage, label, val) == +------------> Add STRINGIMAGE +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 0, STRINGIMAGE val) + nil + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htDoneButton(func, htPage, :optionalArgs) == +------> Handle argument values passed from page if present + if optionalArgs then + htpSetInputAreaAlist(htPage,CAR optionalArgs) + typeCheckInputAreas htPage => + htMakeErrorPage htPage + NULL FBOUNDP func => + systemError ['"unknown function", func] + FUNCALL(SYMBOL_-FUNCTION func, htPage) + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htBcLinks(links,:options) == + skipStateInfo? := IFCAR options + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + link := + $saturn => '"\lispLink[d]" + '"\lispdownlink" + htMakeButton(link,message, + mkCurryFun(func, value),skipStateInfo?) + bcIssueHt info + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htBcLispLinks links == + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + link := + $saturn => '"\lispLink[n]" + '"\lisplink" + htMakeButton(link ,message, mkCurryFun(func, value)) + bcIssueHt info + +htMakeButton(htCommand, message, func,:options) == + $saturn => htMakeButtonSaturn(htCommand, message, func, options) + skipStateInfo? := IFCAR options + iht [htCommand, '"{"] + bcIssueHt message + skipStateInfo? => + iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] + iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] + for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat + iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] + if type = 'string then + iht ['"_"\stringvalue{", id, '"}_""] + else + iht ['"_"\boxvalue{", id, '"}_""] + iht '") " + iht [htpName $curPage, '"))}"] + +htMakeButtonSaturn(htCommand, message, func,options) == + skipStateInfo? := IFCAR options + iht htCommand + skipStateInfo? => + iht ['"{\verb!(|htDoneButton| '|", func, '"| ",htpName page(), '")!}{"] + bcIssueHt message + iht '"}" + iht ['"{\verb!(|htDoneButton| '|", func, '"| "] + if $kPageSaturnArguments then + iht '"(PROGN " + for id in $kPageSaturnArguments for var in $PatternVariableList repeat + iht ['"(|htpSetLabelInputString| ", htpName page(), '"'|", var, '"| "] + iht ["'|!\", id, '"\verb!|"] + iht '")" + iht htpName $saturnPage + iht '")" + else + iht htpName $saturnPage + iht '")!}{" + bcIssueHt message + iht '"}" + +htpAddToPageDescription(htPage, pageDescrip) == + newDescript := + STRINGP pageDescrip => [pageDescrip, :ELT(htPage, 7)] + nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7)) + SETELT(htPage, 7, newDescript) + + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htProcessBcStrings strings == + for [numChars, default, stringName, spadType, :filter] in strings repeat + mess2 := '"" + if NULL LASSOC(stringName, htpInputAreaAlist page()) then + setUpDefault(stringName, ['string, default, spadType, filter]) + if htpLabelErrorMsg(page(), stringName) then + iht ['"\centerline{{\em ", htpLabelErrorMsg(page(), stringName), '"}}"] + mess2 := CONCAT(mess2, bcSadFaces()) + htpSetLabelErrorMsg(page(), stringName, nil) + iht ['"\inputstring{", stringName, '"}{", + numChars, '"}{", htpLabelDefault(page(),stringName), '"} ", mess2] + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +setUpDefault(name, props) == + htpAddInputAreaProp(page(), name, props) + +--------------------> NEW DEFINITION (override in ht-util.boot.pamphlet) +htInitPage(title, propList) == +-- start defining a hyperTeX page + htInitPageNoScroll(propList, title) + htSayStandard '"\beginscroll " + page() + +--------------------> NEW DEFINITION <-------------------------- +htInitPageNoScroll(propList, :options) == +--start defining a hyperTeX page + $atLeastOneUnexposed := nil --reset every time a new page is initialized + $saturnContextMenuLines := nil + title := IFCAR options + $curPage := + $standard => htpMakeEmptyPage(propList) + nil + if $saturn then $saturnPage := htpMakeEmptyPage(propList) + $newPage := true + $htLineList := nil + if title then + if $standard then htSayStandard ['"\begin{page}{", htpName $curPage, '"}{"] + htSaySaturn '"\browseTitle{" + htSay title + htSaySaturn '"}" + htSayStandard '"} " + page() +--------------------> NEW DEFINITION <-------------------------- +htInitPageNoHeading(propList) == +--start defining a hyperTeX page + $curPage := + $standard => htpMakeEmptyPage(propList) + if $saturn then $saturnPage := htpMakeEmptyPage(propList) + $newPage := true + $htLineList := nil + page() + +--------------------> NEW DEFINITION <-------------------------- +htpMakeEmptyPage(propList,:options) == + name := IFCAR options or GENTEMP() + if not $saturn then + $activePageList := [name, :$activePageList] + SET(name, val := VECTOR(name, nil, nil, nil, nil, nil, propList, nil)) + val + +--======================================================================= +-- Redefinitions from br-con.boot +--======================================================================= +kPage(line,:options) == --any cat, dom, package, default package +--constructors Cname\#\E\sig \args \abb \comments (C is C, D, P, X) + parts := dbXParts(line,7,1) + [kind,name,nargs,xflag,sig,args,abbrev,comments] := parts + form := IFCAR options + isFile := null kind + kind := kind or '"package" + RPLACA(parts,kind) + conform := mkConform(kind,name,args) + $kPageSaturnArguments: local := rest conform + conname := opOf conform + capitalKind := capitalize kind + signature := ncParseFromString sig + sourceFileName := dbSourceFile INTERN name + constrings := + KDR form => dbConformGenUnder form + [STRCONC(name,args)] + emString := ['"{\sf ",:constrings,'"}"] + heading := [capitalKind,'" ",:emString] + if not isExposedConstructor conname then heading := ['"Unexposed ",:heading] + if name=abbrev then abbrev := asyAbbreviation(conname,nargs) + page := htInitPageNoScroll nil + htAddHeading heading + htSayStandard("\beginscroll ") + htpSetProperty(page,'argSublis,mkConArgSublis rest conform) + htpSetProperty(page,'isFile,true) + htpSetProperty(page,'parts,parts) + htpSetProperty(page,'heading,heading) + htpSetProperty(page,'kind,kind) + if asharpConstructorName? conname then + htpSetProperty(page,'isAsharpConstructor,true) + htpSetProperty(page,'conform,conform) + htpSetProperty(page,'signature,signature) + ---what follows is stuff from kiPage with domain = nil + $conformsAreDomains := nil + dbShowConsDoc1(page,conform,nil) + if kind ^= 'category and nargs > 0 then addParameterTemplates(page,conform) + if $atLeastOneUnexposed then htSay '"\newline{}{\em *} = unexposed" + htSayStandard("\endscroll ") + kPageContextMenu page + htShowPageNoScroll() + +kPageContextMenu page == + $saturn => kPageContextMenuSaturn page + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) + conform := htpProperty(page,'conform) + conname := opOf conform + htBeginTable() + htSay '"{" + htMakePage [['bcLinks,['Ancestors,'"",'kcaPage,nil]]] + htSay '"}{" + htMakePage [['bcLinks,['Attributes,'"",'koPage,'"attribute"]]] + if kind = '"category" then + htSay '"}{" + htMakePage [['bcLinks,['Children,'"",'kccPage,nil]]] + if not asharpConstructorName? conname then + htSay '"}{" + htMakePage [['bcLinks,['Dependents,'"",'kcdePage,nil]]] + if kind = '"category" then + htSay '"}{" + htMakePage [['bcLinks,['Descendents,'"",'kcdPage,nil]]] + if kind = '"category" then + htSay '"}{" + if not asharpConstructorName? conname then + htMakePage [['bcLinks,['Domains,'"",'kcdoPage,nil]]] + else htSay '"{\em Domains}" + htSay '"}{" + if kind ^= '"category" and (pathname := dbHasExamplePage conname) + then htMakePage [['bcLinks,['Examples,'"",'kxPage,pathname]]] + else htSay '"{\em Examples}" + htSay '"}{" + htMakePage [['bcLinks,['Exports,'"",'kePage,nil]]] + htSay '"}{" + htMakePage [['bcLinks,['Operations,'"",'koPage,'"operation"]]] + htSay '"}{" + htMakePage [['bcLinks,['Parents,'"",'kcpPage,'"operation"]]] + if kind ^= '"category" then + htSay '"}{" + if not asharpConstructorName? conname + then htMakePage [['bcLinks,["Search Path",'"",'ksPage,nil]]] + else htSay '"{\em Search Path}" + if kind ^= '"category" then + htSay '"}{" + htMakePage [['bcLinks,['Users,'"",'kcuPage,nil]]] + htSay '"}{" + htMakePage [['bcLinks,['Uses,'"",'kcnPage,nil]]] + htSay '"}" + if $standard then htEndTable() + +kPageContextMenuSaturn page == + $newPage : local := nil + [kind,name,nargs,xpart,sig,args,abbrev,comments] := htpProperty(page,'parts) + $htLineList : local := nil + conform := htpProperty(page,'conform) + conname := opOf conform + htMakePage [['bcLinks,['"\&Ancestors",'"",'kcaPage,nil]]] + htMakePage [['bcLinks,['"Attri\&butes",'"",'koPage,'"attribute"]]] + if kind = '"category" then + htMakePage [['bcLinks,['"\&Children",'"",'kccPage,nil]]] + if not asharpConstructorName? conname then + htMakePage [['bcLinks,['"\&Dependents",'"",'kcdePage,nil]]] + if kind = '"category" then + htMakePage [['bcLinks,['"Desce\&ndents",'"",'kcdPage,nil]]] + if kind = '"category" then + if not asharpConstructorName? conname then + htMakePage [['bcLinks,['"Do\&mains",'"",'kcdoPage,nil]]] + else htSayCold '"Do\&mains" + if kind ^= '"category" and (name := saturnHasExamplePage conname) + then saturnExampleLink name + else htSayCold '"E\&xamples" + htMakePage [['bcLinks,['"\&Exports",'"",'kePage,nil]]] + htMakePage [['bcLinks,['"\&Operations",'"",'koPage,'"operation"]]] + htMakePage [['bcLinks,['"\&Parents",'"",'kcpPage,'"operation"]]] + if not asharpConstructorName? conname + then htMakePage [['bcLinks,['"Search O\&rder",'"",'ksPage,nil]]] + else htSayCold '"Search Order" + if kind ^= '"category" or dbpHasDefaultCategory? xpart + then + htMakePage [['bcLinks,['"\&Users",'"",'kcuPage,nil]]] + htMakePage [['bcLinks,['"U\&ses",'"",'kcnPage,nil]]] + else + htSayCold '"\&Users" + htSayCold '"U\&ses" + $saturnContextMenuLines := $htLineList + +saturnExampleLink lname == + htSay '"\docLink{\csname " + htSay STRCONC(CAR(CDR(lname)), '"\endcsname}{E&xamples}") + +$exampleConstructors := nil + +saturnHasExamplePage conname == + if not $exampleConstructors then + $exampleConstructors := getSaturnExampleList() + ASSQ(conname, $exampleConstructors) + +getSaturnExampleList() == + file := STRCONC( getEnv('"AXIOM"), "/doc/axug/examples.lsp") + not PROBE_-FILE file => nil + fp := MAKE_-INSTREAM file + lst := READ fp + SHUT fp + lst + +--------------------> NEW DEFINITION (see br-con.boot.pamphlet) +dbPresentCons(htPage,kind,:exclusions) == + $saturn => dbPresentConsSaturn(htPage,kind,exclusions) + htpSetProperty(htPage,'exclusion,first exclusions) + cAlist := htpProperty(htPage,'cAlist) + empty? := null cAlist + one? := null CDR cAlist + one? := empty? or one? + exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 + star? := true --always include information on exposed/unexposed 4/92 + if $standard then htBeginTable() + htSay '"{" + if one? or member('abbrs,exclusions) + then htSay '"{\em Abbreviations}" + else htMakePage [['bcLispLinks,['"Abbreviations",'"",'dbShowCons,'abbrs]]] + htSay '"}{" + if one? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] + then htSay '"{\em Conditions}" + else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowCons,'conditions]]] + htSay '"}{" + if empty? or member('documentation,exclusions) + then htSay '"{\em Descriptions}" + else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowCons,'documentation]]] + htSay '"}{" + if one? or null CDR cAlist + then htSay '"{\em Filter}" + else htMakePage + [['bcLinks,['"Filter",'"",'htFilterPage,['dbShowCons,'filter]]]] + htSay '"}{" + if one? or member('kinds,exclusions) or kind ^= 'constructor + then htSay '"{\em Kinds}" + else htMakePage [['bcLispLinks,['"Kinds",'"",'dbShowCons,'kinds]]] + htSay '"}{" + if one? or member('names,exclusions) + then htSay '"{\em Names}" + else htMakePage [['bcLispLinks,['"Names",'"",'dbShowCons,'names]]] + htSay '"}{" + if one? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] + then htSay '"{\em Parameters}" + else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowCons,'parameters]]] + htSay '"}{" + if $exposedOnlyIfTrue + then + if one? + then htSay '"{\em Unexposed Also}" + else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowCons,'exposureOff]]] + else + if one? + then htSay '"{\em Exposed Only}" + else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowCons,'exposureOn]]] + htSay '"}" + if $standard then htEndTable() + +dbPresentConsSaturn(htPage,kind,exclusions) == + $htLineList : local := nil + $newPage : local := nil + htpSetProperty(htPage,'exclusion,first exclusions) + cAlist := htpProperty(htPage,'cAlist) + empty? := null cAlist + one? := null KDR cAlist + one? := empty? or one? + exposedUnexposedFlag := $includeUnexposed? --used to be star? 4/92 + star? := true --always include information on exposed/unexposed 4/92 + if $standard then htBeginTable() + if one? or member('abbrs,exclusions) + then htSayCold '"\&Abbreviations" + else htMakePage [['bcLispLinks,['"\&Abbreviations",'"",'dbShowCons,'abbrs]]] + if one? or member('conditions,exclusions) or and/[CDR x = true for x in cAlist] + then htSayCold '"\&Conditions" + else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowCons,'conditions]]] + if empty? or member('documentation,exclusions) + then htSayCold '"\&Descriptions" + else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowCons,'documentation]]] + if one? or null CDR cAlist + then htSayCold '"\&Filter" + else htMakeSaturnFilterPage ['dbShowCons, 'filter] + if one? or member('kinds,exclusions) or kind ^= 'constructor + then htSayCold '"\&Kinds" + else htMakePage [['bcLispLinks,['"\&Kinds",'"",'dbShowCons,'kinds]]] + if one? or member('names,exclusions) + then htSayCold '"\&Names" + else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowCons,'names]]] + if one? or member('parameters,exclusions) or not or/[CDAR x for x in cAlist] + then htSayCold '"\&Parameters" + else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowCons,'parameters]]] + htSaySaturn '"\hrule" + if $exposedOnlyIfTrue + then + if one? then htSayCold '"\&Unexposed Also" + else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowCons,'exposureOff]]] + else + if one? then htSayCold '"\Exposed Only\&y" + else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowCons,'exposureOn]]] + if $standard then htEndTable() + $saturnContextMenuLines := $htLineList + +htFilterPage(htPage,args) == + htInitPage("Filter String",htCopyProplist htPage) + htSay "\centerline{Enter filter string (use {\em *} for wild card):}" + htSay '"\centerline{" + htMakePage [['bcStrings, [50,'"",'filter,'EM]]] + htSay '"}\vspace{1}\centerline{" + htMakePage [['bcLispLinks,['"\fbox{Filter}",'"",:args]]] + htSay '"}" + htShowPage() + +htMakeSaturnFilterPage [fn2Call,:args] == + htSay '"\inputboxLink[\lispLink[d]{\verb+(|" + htSay fn2Call + htSay '"| " + htSay htpName $saturnPage + for x in args repeat + htSay '" '|" + htSay x + htSay '"|" + htSay '" _"+_\FILTERSTRING\verb+_")+}{}]{\FILTERSTRING}{*}" + htSay '"{\centerline{Enter filter string (use {\em *} for wild card):}}" + htSay '"{Filter Page}{\&Filter}" + +dbShowConsKinds cAlist == + cats := doms := paks := defs := nil + for x in cAlist repeat + op := CAAR x + kind := dbConstructorKind op + kind = 'category => cats := [x,:cats] + kind = 'domain => doms := [x,:doms] + kind = 'package => paks := [x,:paks] + defs := [x,:defs] + lists := [NREVERSE cats,NREVERSE doms,NREVERSE paks,NREVERSE defs] + htBeginMenu 'description + htSayStandard '"\indent{1}" + kinds := +/[1 for x in lists | #x > 0] + firstTime := true + for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat + if firstTime then firstTime := false + else htSaySaturn '"\\" + htSaySaturn '"\item[" + htSayStandard '"\item" + if kinds = 1 + then htSay menuButton() + else htMakePage + [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] + htSaySaturn '"]" + htSayStandard '"\tab{1}" + htSay('"{\em ",c := #x,'" ") + htSay(c > 1 => pluralize kind; kind) + htSay '":}" + htSaySaturn '"\\" + bcConTable REMDUP [CAAR y for y in x] + htEndMenu 'description + htSayStandard '"\indent{0}" + +addParameterTemplates(page, conform) == +---------------> from kPage <----------------------- + parlist := [STRINGIMAGE par for par in rest conform] + manuelsCode? := "MAX"/[#s for s in parlist] > 10 + w := (manuelsCode? => 55; 23) + htSaySaturn '"\colorbuttonbox{lightgray}{" + htSay '"Optional argument value" + htSay + CDR parlist => '"s:" + '":" + htSaySaturn '"}" + if CDR conform then htSaySaturn '"\newline{}" + htSaySaturn '"\begin{tabular}{p{.25in}l}" + firstTime := true + odd := false + argSublis := htpProperty(page,'argSublis) + for parname in $PatternVariableList for par in rest conform repeat + htSayStandard (odd or manuelsCode? => "\newline";"\tab{29}") + if firstTime then firstTime := false + else htSaySaturn '"\\" + odd := not odd + argstring := + $conArgstrings is [a,:r] => ($conArgstrings := r; a) + '"" + htMakePageStandard [['text,'"{\em ",par,'"} = "], + ['bcStrings,[w - #STRINGIMAGE par,argstring,parname,'EM]]] + if $saturn then + setUpDefault(parname, ['string, '"", 'EM, nil]) + htSaySaturn '"{\em " + htSaySaturn par + htSaySaturn '" = }" + htSaySaturnAmpersand() + htSaySaturn '"\colorbuttonbox{lightgray}{\inputbox[2.5in]{\" + htSaySaturn SUBLIS(argSublis,par) + htSaySaturn '"}{" + htSaySaturn argstring + htSaySaturn '"}}" + htEndTabular() + +--------------------> NEW DEFINITION (see br-con.boot.pamphlet) +kPageArgs([op,:args],[.,.,:source]) == + htSaySaturn '"\begin{tabular}{p{.25in}lp{0in}}" + firstTime := true + coSig := rest GETDATABASE(op,'COSIG) + for x in args for t in source for pred in coSig repeat + if firstTime then firstTime := false + else + htSaySaturn '"\\" + htSayStandard '", and" + htSayStandard '"\newline " + htSaySaturnAmpersand() + typeForm := (t is [":",.,t1] => t1; t) + if pred = true + then htMakePage [['bcLinks,[x,'"",'kArgPage,x]]] + else htSay('"{\em ",x,'"}") + htSayStandard( '"\tab{",STRINGIMAGE( # PNAME x),'"}, ") + htSaySaturnAmpersand() + htSay + pred => '"a domain of category " + '"an element of the domain " + bcConform(typeForm,true) + htEndTabular() + +--======================================================================= +-- Redefinitions from br-op1.boot +--======================================================================= +--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +dbConform form == +--one button for the main constructor page of a type + $saturn => ["\lispLink[d]{\verb!(|conPage| '",:form2Fence dbOuttran form,'")!}{", + :form2StringList opOf form,"}"] + ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] + +--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +htTab s == if $standard then htSayStandard ('"\tab{",s,'"}") + +--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == + single? := null rest data + htBeginMenu 'description + bincount := 0 + for [thing,exposeFlag,:items] in data repeat + htSaySaturn '"\item[" + htSayStandard ('"\item") + if single? then htSay(menuButton()) + else + htMakePageStandard + [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] + button := mkButtonBox (1 + bincount) + htMakePageSaturn [['bcLinks,[button,'"",'dbShowOps,which,bincount]]] + htSaySaturn '"]" + htSay '"{\em " + htSay + thing = 'nowhere => '"implemented nowhere" + thing = 'constant => '"constant" + thing = '_$ => '"by the domain" + INTEGERP thing => '"unexported" + constructorIfTrue => + htSay word + atom thing => '" an unknown constructor" + '"" + atom thing => '"unconditional" + '"" + htSay '"}" + if null atom thing then + if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") + htSay '" " + FUNCALL(fn,thing) + htSay('":\newline ") + dbShowOpSigList(which,items,(1 + bincount) * 8192) + bincount := bincount + 1 + htEndMenu 'description + +--------------------> NEW DEFINITION (see br-op1.boot.pamphlet) +dbPresentOps(htPage,which,:exclusions) == + $saturn => dbPresentOpsSaturn(htPage,which,exclusions) + asharp? := htpProperty(htPage,'isAsharpConstructor) + fromConPage? := (conname := opOf htpProperty(htPage,'conform)) + usage? := nil + star? := not fromConPage? or which = '"package operation" + implementation? := not asharp? and + $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? + rightmost? := star? or (implementation? and not $includeUnexposed?) + if INTEGERP first exclusions then exclusions := ['documentation] + htpSetProperty(htPage,'exclusion,first exclusions) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + empty? := null opAlist + one? := opAlist is [entry] and 2 = #entry + one? := empty? or one? + htBeginTable() + htSay '"{" + if one? or member('conditions,exclusions) + or (htpProperty(htPage,'condition?) = 'no) + then htSay '"{\em Conditions}" + else htMakePage [['bcLispLinks,['"Conditions",'"",'dbShowOps,which,'conditions]]] + htSay '"}{" + if empty? or member('documentation,exclusions) + then htSay '"{\em Descriptions}" + else htMakePage [['bcLispLinks,['"Descriptions",'"",'dbShowOps,which,'documentation]]] + htSay '"}{" + if null IFCDR opAlist + then htSay '"{\em Filter}" + else htMakePage [['bcLinks,['"Filter ",'"",'htFilterPage,['dbShowOps,which,'filter]]]] + htSay '"}{" + if one? or member('names,exclusions) or null KDR opAlist + then htSay '"{\em Names}" + else htMakePage [['bcLispLinks,['"Names",'"",'dbShowOps,which,'names]]] + if not star? then + htSay '"}{" + if not implementation? or member('implementation,exclusions) or which = '"attribute" or + ((conname := opOf htpProperty(htPage,'conform)) + and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + then htSay '"{\em Implementations}" + else htMakePage + [['bcLispLinks,['"Implementations",'"",'dbShowOps,which,'implementation]]] + htSay '"}{" + if one? or member('origins,exclusions) + then htSay '"{\em Origins}" + else htMakePage [['bcLispLinks,['"Origins",'"",'dbShowOps,which,'origins]]] + htSay '"}{" + if one? or member('parameters,exclusions) --also test for some parameter + or not dbDoesOneOpHaveParameters? opAlist + then htSay '"{\em Parameters}" + else htMakePage [['bcLispLinks,['"Parameters",'"",'dbShowOps,which,'parameters]]] + htSay '"}{" + if which ^= '"attribute" then + if one? or member('signatures,exclusions) + then htSay '"{\em Signatures}" + else htMakePage [['bcLispLinks,['"Signatures",'"",'dbShowOps,which,'signatures]]] + htSay '"}" + if star? then + htSay '"{" + if $exposedOnlyIfTrue + then if one? + then htSay '"{\em Unexposed Also}" + else htMakePage [['bcLinks,['"Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] + else if one? + then htSay '"{\em Exposed Only}" + else htMakePage [['bcLinks,['"Exposed Only",'"",'dbShowOps, which,'exposureOn]]] + htSay '"}" + htEndTable() + +dbPresentOpsSaturn(htPage,which,exclusions) == + $htLineList : local := nil + $newPage : local := nil + asharp? := htpProperty(htPage,'isAsharpConstructor) + fromConPage? := (conname := opOf htpProperty(htPage,'conform)) + usage? := nil + star? := not fromConPage? or which = '"package operation" + implementation? := not asharp? and + $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed? + rightmost? := star? or (implementation? and not $includeUnexposed?) + if INTEGERP first exclusions then exclusions := ['documentation] + htpSetProperty(htPage,'exclusion,first exclusions) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + empty? := null opAlist + one? := opAlist is [entry] and 2 = #entry + one? := empty? or one? + if one? or member('conditions,exclusions) + or (htpProperty(htPage,'condition?) = 'no) + then htSayCold '"\&Conditions" + else htMakePage [['bcLispLinks,['"\&Conditions",'"",'dbShowOps,which,'conditions]]] + if empty? or member('documentation,exclusions) + then htSayCold '"\&Descriptions" + else htMakePage [['bcLispLinks,['"\&Descriptions",'"",'dbShowOps,which,'documentation]]] + if null IFCDR opAlist + then htSayCold '"\&Filter" + else htMakeSaturnFilterPage ['dbShowOps, which, 'filter] + if not implementation? or member('implementation,exclusions) or which = '"attribute" or + ((conname := opOf htpProperty(htPage,'conform)) + and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + then htSayCold '"\&Implementations" + else htMakePage + [['bcLispLinks,['"\&Implementations",'"",'dbShowOps,which,'implementation]]] + if one? or member('names,exclusions) or null KDR opAlist + then htSayCold '"\&Names" + else htMakePage [['bcLispLinks,['"\&Names",'"",'dbShowOps,which,'names]]] + if one? or member('origins,exclusions) + then htSayCold '"\&Origins" + else htMakePage [['bcLispLinks,['"\&Origins",'"",'dbShowOps,which,'origins]]] + if one? or member('parameters,exclusions) --also test for some parameter + or not dbDoesOneOpHaveParameters? opAlist + then htSayCold '"\&Parameters" + else htMakePage [['bcLispLinks,['"\&Parameters",'"",'dbShowOps,which,'parameters]]] + if which ^= '"attribute" then + if one? or member('signatures,exclusions) + then htSayCold '"\&Signatures" + else htMakePage [['bcLispLinks,['"\&Signatures",'"",'dbShowOps,which,'signatures]]] + if star? then + htSay '"\hrule" + if $exposedOnlyIfTrue + then if one? then htSayCold '"\&Unexposed Also" + else htMakePage [['bcLinks,['"\&Unexposed Also",'"",'dbShowOps,which,'exposureOff]]] + else + if one? then htSayCold '"Exposed Onl\&y" + else htMakePage [['bcLinks,['"Exposed Onl\&y",'"",'dbShowOps,which,'exposureOn]]] + $saturnContextMenuLines := $htLineList + +--======================================================================= +-- Redefinitions from br-search.boot +--======================================================================= +---------------------> OLD DEFINITION (override in br-search.boot.pamphlet) +htShowPageStar() == + $saturn => htShowPageStarSaturn() + htSayStandard '"\endscroll " + if $exposedOnlyIfTrue then + htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] + else + htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] + htShowPageNoScroll() + +htShowPageStarSaturn() == + $newPage : local := nil + $htLineList : local := nil + if $exposedOnlyIfTrue then + htMakePage [['bcLinks,['"Unexposed Also",'"",'repeatSearch,NIL]]] + else + htMakePage [['bcLinks,['"Exposed Only",'"",'repeatSearch,'T]]] + $saturnContextMenuLines := $htLineList + htShowPageNoScroll() + +--======================================================================= +-- Redefinitions from br-op2.boot +--======================================================================= + +--------------> NEW DEFINITION (see br-op2.boot.pamphlet) +displayDomainOp(htPage,which,origin,op,sig,predicate, + doc,index,chooseFn,unexposed?,$generalSearch?) == + $chooseDownCaseOfType : local := true --see dbGetContrivedForm + $whereList : local := nil + $NumberList : local := '(i j k l m n i1 j1 k1 l1 m1 n1 i2 j2 k2 l2 m2 n2 i3 j3 k3 l3 m3 n3 i4 j4 k4 l4 m4 n4 ) + $ElementList: local := '(x y z u v w x1 y1 z1 u1 v1 w1 x2 y2 z2 u2 v2 w2 x3 y3 z3 u3 v3 w3 x4 y4 z4 u4 v4 w4 ) + $FunctionList:local := '(f g h d e F G H) + $DomainList: local := '(D R S E T A B C M N P Q U V W) + exactlyOneOpSig := null index + conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + or origin + if $generalSearch? then $DomainList := rest $DomainList + opform := + which = '"attribute" => + null sig => [op] + [op,sig] + which = '"constructor" => origin + dbGetDisplayFormForOp(op,sig,doc) + htSayStandard('"\newline") + ----------------------------------------------------------- + htSaySaturn '"\item[" + if exactlyOneOpSig + then htSay menuButton() + else htMakePage + [['bcLinks,[menuButton(),'"",chooseFn,which,index]]] + htSaySaturn '"]" + htSayStandard '"\tab{2}" + op := IFCAR opform + args := IFCDR opform + ops := escapeSpecialChars STRINGIMAGE op + n := #sig + do + n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") + n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") + if unexposed? and $includeUnexposed? then + htSayUnexposed() + htSay(ops) + predicate='ASCONST or GETDATABASE(op,'NILADIC) or member(op,'(0 1)) => 'skip + which = '"attribute" and null args => 'skip + htSay('"(") + if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}") + for x in IFCDR args repeat + htSay('",{\em ",quickForm2HtString x,'"}") + htSay('")") + -----------prepare to print description--------------------- + constring := form2HtString conform + conname := first conform + $conkind : local := htpProperty(htPage,'kind) -- a string e.g. "category" + or STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND) + $conlength : local := #constring + $conform : local := conform + $conargs : local := rest conform + if which = '"operation" then + $signature : local := + MEMQ(conname,$Primitives) => nil + CDAR getConstructorModemap conname + --RDJ: this next line is necessary until compiler bug is fixed + --that forgets to substitute #variables for t#variables; + --check the signature for SegmentExpansionCategory, e.g. + tvarlist := TAKE(# $conargs,$TriangleVariableList) + $signature := SUBLISLIS($FormalMapVariableList,tvarlist,$signature) + $sig := + which = '"attribute" or which = '"constructor" => sig + $conkind ^= '"package" => sig + symbolsUsed := [x for x in rest conform | IDENTP x] + $DomainList := SETDIFFERENCE($DomainList,symbolsUsed) + getSubstSigIfPossible sig + ----------------------------------------------------------- + htSaySaturn '"\begin{tabular}{lp{0in}}" + ----------------------------------------------------------- + if member(which,'("operation" "constructor")) then + $displayReturnValue: local := nil + if args then + htSayStandard('"\newline\tab{2}{\em Arguments:}") + htSaySaturn '"{\em Arguments:}" + htSaySaturnAmpersand() + firstTime := true + coSig := KDR GETDATABASE(op,'COSIG) --check if op is constructor + for a in args for t in rest $sig repeat + if not firstTime then + htSaySaturn '"\\ " + htSaySaturnAmpersand() + firstTime := false + htSayIndentRel(15, true) + position := KAR relatives + relatives := KDR relatives + if KAR coSig and t ^= '(Type) + then htMakePage [['bcLinks,[a,'"",'kArgPage,a]]] + else htSay('"{\em ",form2HtString(a),'"}") + htSay ", " + coSig := KDR coSig + htSayValue t + htSayIndentRel(-15,true) + htSayStandard('"\newline ") + htSaySaturn '"\\" + if first $sig then + $displayReturnValue := true + htSayStandard('"\newline\tab{2}") + htSay '"{\em Returns:}" + htSaySaturnAmpersand() + htSayIndentRel(15, true) + htSayValue first $sig + htSayIndentRel(-15, true) + htSaySaturn '"\\" + ----------------------------------------------------------- + if origin and ($generalSearch? or origin ^= conform) and op^=opOf origin then + htSaySaturn '"{\em Origin:}" + htSaySaturnAmpersand() + htSayStandard('"\newline\tab{2}{\em Origin:}") + htSayIndentRel(15) + if not isExposedConstructor opOf origin and $includeUnexposed? + then htSayUnexposed() + bcConform(origin,true) + htSayIndentRel(-15) + htSaySaturn '"\\" + ----------------------------------------------------------- + if not MEMQ(predicate,'(T ASCONST)) then + pred := sublisFormal(KDR conform,predicate) + count := #pred + htSaySaturn '"{\em Conditions:}" + htSayStandard('"\newline\tab{2}{\em Conditions:}") + firstTime := true + for p in displayBreakIntoAnds SUBST($conform,"$",pred) repeat + if not firstTime then htSaySaturn '"\\" + htSayIndentRel(15,count > 1) + firstTime := false + htSaySaturnAmpersand() + bcPred(p,$conform,true) + htSayIndentRel(-15,count > 1) + htSayStandard('"\newline ") + htSaySaturn '"\\" + ----------------------------------------------------------- + if $whereList then + count := #$whereList + htSaySaturn '"{\em Where:}" + htSayStandard('"\newline\tab{2}{\em Where:}") + firstTime := true + if ASSOC("$",$whereList) then + htSayIndentRel(15,true) + htSaySaturnAmpersand() + htSayStandard '"{\em \$} is " + htSaySaturn '"{\em \%} is " + htSay + $conkind = '"category" => '"of category " + '"the domain " + bcConform(conform,true,true) + firstTime := false + htSayIndentRel(-15,true) + for [d,key,:t] in $whereList | d ^= "$" repeat + htSayIndentRel(15,count > 1) + if not firstTime then htSaySaturn '"\\ " + htSaySaturnAmpersand() + firstTime := false + htSay("{\em ",d,"} is ") + htSayConstructor(key,sublisFormal(KDR conform,t)) + htSayIndentRel(-15,count > 1) + htSaySaturn '"\\" + ----------------------------------------------------------- + if doc and (doc ^= '"" and (doc isnt [d] or d ^= '"")) then + htSaySaturn '"{\em Description:}" + htSaySaturnAmpersand() + htSayStandard('"\newline\tab{2}{\em Description:}") + htSayIndentRel(15) + if doc = $charFauxNewline then htSay $charNewline + else + ndoc:= + -- we are confused whether doc is a string or a list of strings + CONSP doc => [SUBSTITUTE($charNewline, $charFauxNewline, i) for i in doc] + SUBSTITUTE($charNewline, $charFauxNewline,doc) + htSay ndoc +-- htSaySaturn '"\\" + htSayIndentRel(-15) + --------> print abbr and source file for constructors <--------- + if which = '"constructor" then + if (abbr := GETDATABASE(conname,'ABBREVIATION)) then + htSaySaturn '"\\" + htSaySaturn '"{\em Abbreviation:}" + htSaySaturnAmpersand() + htSayStandard('"\tab{2}{\em Abbreviation:}") + htSayIndentRel(15) + htSay abbr + htSayIndentRel(-15) + htSayStandard('"\newline{}") + if ( $saturn and (link := saturnHasExamplePage conname)) then + htSaySaturn '"\\" + htSaySaturn '"{\em Examples:}" + htSaySaturnAmpersand() + htSayIndentRel(15) + htSay '"\spadref{" + htSay CAR(CDR(link)) + htSay '"}" + htSayIndentRel(-15) + htSayStandard('"\newline{}") + htSaySaturn '"\\" + htSaySaturn '"{\em Source File:}" + htSaySaturnAmpersand() + htSayStandard('"\tab{2}{\em Source File:}") + htSayIndentRel(15) + htSaySourceFile conname + htSayIndentRel(-15) + ------------------> remove profile printouts for now <------------------- + if $standard and + exactlyOneOpSig and (infoAlist := htpProperty(htPage,'infoAlist)) then + displayInfoOp(htPage,infoAlist,op,sig) + ----------------------------------------------------------- + htSaySaturn '"\end{tabular}" + +htSaySourceFile conname == + sourceFileName := (GETDATABASE(conname,'SOURCEFILE) or '"none") + filename := extractFileNameFromPath sourceFileName + htMakePage [['text,'"\unixcommand{",filename,'"}{_\$AXIOM/lib/SPADEDIT ", + sourceFileName, '" ", conname, '"}"]] + +--------------------> NEW DEFINITION (see br-op2.boot.pamphlet) +htSayIndentRel(n,:options) == + flag := IFCAR options + m := ABSVAL n + if flag then m := m + 2 + if $standard then htSayStandard + n > 0 => + flag => ['"\indent{",STRINGIMAGE m,'"}\tab{-2}"] + ['"\indent{",STRINGIMAGE m,'"}\tab{0}"] + n < 0 => ['"\indent{0}\newline "] + +htSayUnexposed() == + htSay '"{\em *}" + $atLeastOneUnexposed := true +--======================================================================= +-- Page Operations +--======================================================================= + +htEndTabular() == + htSaySaturn '"\end{tabular}" + +htPopSaturn s == + pageDescription := ELT($saturnPage, 7) + pageDescription is [=s,:b] => SETELT($saturnPage, 7, CDR pageDescription) + nil + +htBeginTable() == + htSaySaturn '"\begin{dirlist}[lv]" + htSayStandard '"\table{" + +htEndTable() == + htSaySaturn '"\end{dirlist}" + htSayStandard '"}" + +htBeginMenu(kind,:options) == + skip := IFCAR options + if $saturn then + kind = 'description => htSaySaturn '"\begin{description}" + htSaySaturn '"\begin{tabular}" + htSaySaturn + kind = 3 => '"{llp{0in}}" + kind = 2 => '"{lp{0in}}" + error nil + null skip => htSayStandard '"\beginmenu " + nil + +htEndMenu(kind) == + if $saturn then + kind = 'description => htSaySaturn '"\end{description}" + htPopSaturn '"\\" + htSaySaturn '"\end{tabular}" + htSayStandard '"\endmenu " + +htSayConstructorName(nameShown, name) == + if $saturn then + code := ['"(|conPage| '|", name, '"|)"] + htSaySaturn mkDocLink(code,nameShown) + if $standard then + htSayStandard ["\lispdownlink{",nameShown,'"}{(|conPage| '|",name,'"|)}"] + +--------------------> NEW DEFINITION (see ht-util.boot.pamphlet) +htAddHeading(title) == + htNewPage title + page() + +------------> called by htAddHeading, htInitPageNoScroll <----------- +htNewPage title == + if $saturn then + htSaySaturn '"\browseTitle{" + htSaySaturn title + htSaySaturn '"}" + if $standard then htSayStandard('"\begin{page}{", htpName $curPage, '"}{") + htSayStandard title + htSayStandard '"}" + +--======================================================================= +-- Utilities +--======================================================================= +mkTabularItem u == [:first u,:fn rest u] where fn x == + null x => nil + [$saturnAmpersand, x,:fn rest x] + +htSaySaturnAmpersand() == htSaySaturn $saturnAmpersand + +htBlank(:options) == + options is [n] => + htSaySaturn("STRCONC"/['"\phantom{*}" for i in 1..n]) + htSayStandard STRCONC('"\space{",STRINGIMAGE n,'"}") + htSaySaturn '"\phantom{*}" + htSayStandard '"\space{1}" + +unTab s == + STRINGP s => unTab1 s + atom s => s + [unTab1 first s, :rest s] + +unTab1 s == + STRING_<('"\tab{", s) = 5 and (k := charPosition(char '_}, s, 4)) => + SUBSTRING(s, k + 1, nil) + s + +satBreak() == + htSaySaturn '"\\ " + htSayStandard '"\item " + +htBigSkip() == + htSaySaturn '"\bigskip{}" + htSayStandard '"\vspace{1}\newline " + +htSaturnBreak() == htSaySaturn '"\!" + +satDownLink(s,code) == + htSaySaturn '"\lispFunctionLink{\verb!" + htSaySaturn code + htSaySaturn '"!}{" + htSaySaturn s + htSaySaturn '"}" + ------------------ + htSayStandard '"\lispdownlink{" + htSayStandard s + htSayStandard '"}{" + htSayStandard code + htSayStandard '"}" + +satTypeDownLink(s,code) == + htSaySaturn '"\lispLink[d]{\verb!" + htSaySaturn code + htSaySaturn '"!}{" + htSaySaturn s + htSaySaturn '"}" + ------------------ + htSayStandard '"\lispdownlink{" + htSayStandard s + htSayStandard '"}{" + htSayStandard code + htSayStandard '"}" + +mkButtonBox n == STRCONC('"\buttonbox{", STRINGIMAGE n, '"}") + +--======================================================================= +-- Create separate databases for operations, constructors +--======================================================================= +-----------> use br-data.boot definition +--dbSplitLibdb() == +--This function splits lidbd.text into files to make searching quicker. +-- alibdb.text attributes +-- clibdb.text categories +-- dlibdb.text domains +-- plibdb.text packages +-- olibdb.text operations +-- xlibdb.text default packages +--These files have the same format as the single file libdb.text did in old +-- version: e.g. `````` +-- for constructors where is a single character, one of acdopx +-- (identifying it as an attribute, category, domain, operator, package, +-- or default package), its name, number of arguments, whether exposed or +-- unexposed, its signature (sometimes abbreviated), its arguments as given +-- in the original definition, its abbreviation, and documentation. +-- For example, domain Matrix has line "dMatrix`1`x``(R)`MATRIX`" +-- where is "(Ring)->Join(MatrixCategory(R,Vector(R),Vector(R)),etc)". +-- The comment field contains the character address of the comments +-- for Matrix in file comdb.text. +--There is thus ONE file comdb.text for documentation of all structures +-- (to facilitate a general search through all documentation) +-- into for comments. The format of entries in comdb.text are lines with +-- two fields of the form d`, where is the character +-- address of the line "dMatrix`.." in dlibdb.text (the first character +-- "d" tells which lidbdb file it comes from, the is the +-- documentation for Matrix. +--NOTE: In each file, the first character, one of acdpox, is retained +-- so that lines have the same format as the previous version of the browser +-- (this minimized the number of lines of code that had to be changed from +-- previous version of the browser). +-- key := nil --dummy first key +-- instream := MAKE_-INSTREAM '"libdb.text" +-- comstream := MAKE_-OUTSTREAM '"comdb.text" +-- PRINTEXP(0, comstream) +-- PRINTEXP($tick,comstream) +-- PRINTEXP('"", comstream) +-- TERPRI(comstream) +-- while not EOFP instream repeat +-- line := READLINE instream +-- comP := FILE_-POSITION comstream +-- if key ^= line.0 then +-- if outstream then SHUT outstream +-- key := line . 0 +-- outstream := MAKE_-OUTSTREAM STRCONC(STRINGIMAGE key,'"libdb.text") +-- outP := FILE_-POSITION outstream +-- [prefix,:comments] := dbSplit(line,6,1) +-- PRINTEXP(prefix,outstream) +-- PRINTEXP($tick ,outstream) +-- null comments => +-- PRINTEXP(0,outstream) +-- TERPRI(outstream) +-- PRINTEXP(comP,outstream) +-- TERPRI(outstream) +-- PRINTEXP(key, comstream) --identifies file the backpointer is to +-- PRINTEXP(outP ,comstream) +-- PRINTEXP($tick ,comstream) +-- PRINTEXP(first comments,comstream) +-- TERPRI(comstream) +-- for c in rest comments repeat +-- PRINTEXP(key, comstream) --identifies file the backpointer is to +-- PRINTEXP(outP ,comstream) +-- PRINTEXP($tick ,comstream) +-- PRINTEXP(c, comstream) +-- TERPRI(comstream) +-- SHUT instream +-- SHUT outstream +-- SHUT comstream +--OBEY '"rm libdb.text" + +dbSort(x,y) == + sin := STRINGIMAGE x + sout:= STRINGIMAGE y + OBEY STRCONC('"sort -f _"",sin,'".text_" > _"", sout, '".text_"") + OBEY STRCONC('"rm ", sin, '".text") + + +--======================================================================= +-- from define.boot +--======================================================================= +----------------------> (override in define.boot.pamphlet) +compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], + m,oldE,$prefix,$formalArgList) == + [lineNumber,:specialCases] := specialCases + e := oldE + --1. bind global variables + $form: local + $op: local + $functionStats: local:= [0,0] + $argumentConditionList: local + $finalEnv: local + --used by ReplaceExitEtc to get a common environment + $initCapsuleErrorCount: local:= #$semanticErrorStack + $insideCapsuleFunctionIfTrue: local:= true + $CapsuleModemapFrame: local:= e + $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) + $insideExpressionIfTrue: local:= true + $returnMode:= m + [$op,:argl]:= form + $form:= [$op,:argl] + argl:= stripOffArgumentConditions argl + $formalArgList:= [:argl,:$formalArgList] + + --let target and local signatures help determine modes of arguments + argModeList:= + identSig:= hasSigInTargetCategory(argl,form,first signature,e) => + (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + [getArgumentModeOrMoan(a,form,e) for a in argl] + argModeList:= stripOffSubdomainConditions(argModeList,argl) + signature':= [first signature,:argModeList] + if null identSig then --make $op a local function + oldE := put($op,'mode,['Mapping,:signature'],oldE) + + --obtain target type if not given + if null first signature' then signature':= + identSig => identSig + getSignature($op,rest signature',e) or return nil + + --replace ##1,.. in signature by arguments +-- pp signature' + signature':= SUBLISLIS(argl,$FormalFunctionParameterList,signature') +-- pp '"------after----" +-- pp signature' + e:= giveFormalParametersValues(argl,e) + + $signatureOfForm:= signature' --this global is bound in compCapsuleItems + $functionLocations := [[[$op,$signatureOfForm],:lineNumber], + :$functionLocations] + e:= addDomain(first signature',e) + e:= compArgumentConditions e + + if $profileCompiler then + for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) + + + --4. introduce needed domains into extendedEnv + for domain in signature' repeat e:= addDomain(domain,e) + + --6. compile body in environment with extended environment + rettype:= resolve(signature'.target,$returnMode) + + localOrExported := + null member($op,$formalArgList) and + getmode($op,e) is ['Mapping,:.] => 'local + 'exported + + --6a skip if compiling only certain items but not this one + -- could be moved closer to the top + formattedSig := formatUnabbreviated ['Mapping,:signature'] + $compileOnlyCertainItems and _ + not member($op, $compileOnlyCertainItems) => + sayBrightly ['" skipping ", localOrExported,:bright $op] + [nil,['Mapping,:signature'],oldE] + sayBrightly ['" compiling ",localOrExported, + :bright $op,'": ",:formattedSig] + + if $newComp = true then + wholeBody := ['DEF, form, signature', specialCases, body] + T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) + or [" ",rettype,e] + T := [T.expr.2.2, rettype, T.env] + if $newCompCompare=true then + oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) + or [" ",rettype,e] + SAY '"The old compiler generates:" + prTriple oldT + SAY '"The new compiler generates:" + prTriple T + else + T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) + or [" ",rettype,e] +--+ + NRTassignCapsuleFunctionSlot($op,signature') + if $newCompCompare=true then + SAY '"The old compiler generates:" + prTriple T +-- A THROW to the above CATCH occurs if too many semantic errors occur +-- see stackSemanticError + catchTag:= MKQ GENSYM() + fun:= + body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) + body':= addArgumentConditions(body',$op) + finalBody:= ["CATCH",catchTag,body'] + compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) + $functorStats:= addStats($functorStats,$functionStats) + + +-- 7. give operator a 'value property + val:= [fun,signature',e] + [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) + +--from postpar +--------------------> NEW DEFINITION (override in postpar.boot.pamphlet) +postSignature ['Signature,op,sig] == + sig is ["->",:.] => + sig1:= postType sig + op:= postAtom (STRINGP op => INTERN op; op) + ["SIGNATURE",op,:removeSuperfluousMapping killColons postDoubleSharp sig1] + +postDoubleSharp sig == + sig is [['Mapping,target,:r]] => + -- replace #1,... by ##1,... + [['Mapping, SUBLISLIS($FormalFunctionParameterList, $FormalMapVariableList, target), + :r]] + sig + +-- override in br-util.boot.pamphlet +bcConform1 form == main where + main == + form is ['ifp,form1,:pred] => + hd form1 + bcPred pred + hd form + hd form == + atom form => + not MEMQ(form,$Primitives) and null constructor? form => + s := STRINGIMAGE form + (s.0 = char '_#) => + (n := POSN1(form, $FormalFunctionParameterList)) => + htSay form2HtString ($FormalMapVariableList . n) + htSay '"\" + htSay form + htSay escapeSpecialChars STRINGIMAGE form + s := STRINGIMAGE form + $italicHead? => htSayItalics s + $bcMultipleNames => + satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) + satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) + (head := QCAR form) = 'QUOTE => + htSay('"'") + hd CADR form + head = 'SIGNATURE => + htSay(CADR form,'": ") + mapping CADDR form + head = 'Mapping and rest form => rest form => mapping rest form + head = ":" => + hd CADR form + htSay '": " + hd CADDR form + QCDR form and dbEvalableConstructor? form + => bcConstructor(form,head) + hd head + null (r := QCDR form) => nil + tl QCDR form + mapping [target,:source] == + tuple source + bcHt + $saturn => '" {\ttrarrow} " + '" -> " + hd target + tuple u == + null u => bcHt '"()" + null rest u => hd u + bcHt '"(" + hd first u + for x in rest u repeat + bcHt '"," + hd x + bcHt '")" + tl u == + bcHt '"(" + firstTime := true + for x in u repeat + if not firstTime then bcHt '"," + firstTime := false + hd x + bcHt '")" + say x == + if $italics? then bcHt '"{\em " + if x = 'etc then x := '"..." + bcHt escapeSpecialIds STRINGIMAGE x + if $italics? then bcHt '"}" + +--======================================================================= +-- Code for Private Libdbs +--======================================================================= +--extendLocalLibdb conlist == --called by function "compiler"(see above) +-- buildLibdb conlist --> puts datafile into temp.text +-- $newConstructorList := union(conlist, $newConstructorList) +-- localLibdb := '"libdb.text" +-- not isExistingFile '"libdb.text" => RENAME_-FILE('"temp.text",'"libdb.text") +-- oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) +-- newlines := dbReadLines '"temp.text" +-- dbWriteLines(MSORT union(oldlines,newlines), '"libdb.text") +-- deleteFile '"temp.text" + +purgeNewConstructorLines(lines, conlist) == + [x for x in lines | not screenLocalLine(x, conlist)] + +-- Got rid of debugging statement and deleted screenLocalLine1, MCD 26/3/96 +--screenLocalLine(line,conlist) == +-- u := screenLocalLine1(line,conlist) +-- if u then +-- sayBrightly ['"Purging--->", line] +-- u + +-- screenLocalLine1(line, conlist) == +screenLocalLine(line, conlist) == + k := dbKind line + con := INTERN + k = char 'o or k = char 'a => + s := dbPart(line,5,1) + k := charPosition(char '_(,s,1) + SUBSTRING(s,1,k - 1) + dbName line + MEMQ(con, conlist) + +--------------> NEW DEFINITION (see br-data.boot.pamphlet) +purgeLocalLibdb() == --called by the user through a clear command? + $newConstructorList := nil + deleteFile '"libdb.text" + +--moveFile(before,after) == +-- $saturn => MOVE_-FILE(before, after) +-- RENAME_-FILE(before, after) +-- --obey STRCONC('"mv ", before, '" ", after) + +-- deleted JHD/MCD, since already one in pathname.boot +--deleteFile fn == +-- $saturn => DELETE_-FILE fn +-- obey STRCONC('"rm ",fn) + +--======================================================================= +-- from DAASE.LISP +--======================================================================= +--library(args) == +-- $newConlist: local := nil +-- LOCALDATABASE(args,$options) +-- extendLocalLibdb $newConlist +-- TERSYSCOMMAND() + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-search.boot b/src/interp/br-search.boot deleted file mode 100644 index 0fb651b6..00000000 --- a/src/interp/br-search.boot +++ /dev/null @@ -1,1014 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-search.boot <================================ - ---======================================================================= --- Grepping Database libdb.text --- Redone 12/95 for Saturn; previous function grep renamed as grepFile --- This function now either returns a filename or a list of strings ---======================================================================= -grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) ---Called from genSearch with key = "." and "w" ---key = "." means a o c d p x ---option1 = true means return the result as a file ---All searches of the database call this function to get relevant lines ---from libdb.text. Returns either a list of lines (usual case) or else ---an alist of the form ((kind . ) ...) - $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" - lines := grepConstruct1(s,key) - IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor - MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o - lines - -grepConstruct1(s,key) == ---returns the name of file (WITHOUT .text.$SPADNUM on the end) - $key : local := key - if key = 'k and --convert 'k to 'y if name contains an "&" - or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y - filter := pmTransFilter STRINGIMAGE s --parses and-or-not form - filter is ['error,:.] => filter --exit on parser error - pattern := mkGrepPattern(filter,key) --create string to pass to "grep" - grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot - -grepConstructDo(x, key) == - $orCount := 0 ---atom x => grepFile(x, key,'i) - $localLibdb => - oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) - newLines := grepf(x,$localLibdb,false) - union(oldLines, newLines) - grepf(x,key,false) - -dbExposed?(line,kind) == -- does line come from an unexposed constructor? - conname := INTERN - kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle - dbName line - isExposedConstructor conname - -dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] - -isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x - -grepForAbbrev(s,key) == ---checks that filter s is not * and is all uppercase; if so, look for abbrevs - u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first - s := STRINGIMAGE s - someLowerCaseChar := false - someUpperCaseChar := false - for i in 0..MAXINDEX s repeat - c := s . i - LOWER_-CASE_-P c => return (someLowerCaseChar := true) - UPPER_-CASE_-P c => someUpperCaseChar := true - someLowerCaseChar or not someUpperCaseChar => false - pattern := DOWNCASE s - ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) - for x in allConstructors() | test]] where test == - not $includeUnexposed? and not isExposedConstructor x => false - a := GETDATABASE(x,'ABBREVIATION) - match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) - -applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn - atom x => grepFile(x,filename,'i) - $localLibdb => - a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) - b := grepf(x,$localLibdb,false) - grepCombine(a,b) - grepf(x,filename,false) - -grepCombine(a,b) == MSORT union(a,b) - -grepf(pattern,s,not?) == --s=sourceFile or list of strings - pattern is [op,:argl] => - op = "and" => - while argl is [arg,:argl] repeat - s := grepf(arg,s,not?) -- filter by successive greps - s - op = "or" => - targetStack := nil - "union"/[grepf(arg,s,not?) for arg in argl] - op = "not" => - not? => grepf(first argl,s,false) - --could be the first time so have to get all of same $key - lines := grepf(mkGrepPattern('"*",$key),s,false) - grepf(first argl,lines,true) - systemError nil - option := - not? => 'iv - 'i - source := - LISTP s => dbWriteLines s - s - grepFile(pattern,source,option) - -pmTransFilter s == ---result is either a string or (op ..) where op= and,or,not and arg are results - if $browseMixedCase = true then s := DOWNCASE s - or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] - => (parse := pmParseFromString s) and checkPmParse parse or - ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] - or/[s . i = char '_* and s.(i + 1) = char '_* - and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] - => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] - s - -checkPmParse parse == - STRINGP parse => parse - fn parse => parse where fn(u) == - u is [op,:args] => - MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] - STRINGP u => true - false - nil - -dnForm x == - STRINGP x => x - x is ['not,argl] => - argl is ['or,:orargs]=> - ['and, :[dnForm negate u for u in orargs]] where negate s == - s is ['not,argx] => argx - ['not,s] - argl is ['and,:andargs]=> - ['or,:[dnForm negate u for u in andargs]] - argl is ['not,notargl]=> - dnForm notargl - x - x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] - x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] - x - -pmParseFromString s == - u := ncParseFromString pmPreparse s - dnForm flatten u where flatten s == - s is [op,:argl] => - STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) - [op,:[flatten x for x in argl]] - s - -pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse - hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) - fn(s,n,siz) == --main function: s is string, n is origin - n = siz => '"" - i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) - j := firstDelim(s,i + 1) or siz - t := gn(s,i,j - 1) - middle := - member(t,'("and" "or" "not")) => t - --the following 2 lines make commutative("*") parse correctly!!!! - t.0 = char '_" => t - j < siz - 1 and s.j = char '_( => t - STRCONC(char '_",t,char '_") - STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) - gn(s,i,j) == --replace each underscore by 4 underscores! - n := or/[k for k in i..j | s.k = $charUnderscore] => - STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) - SUBSTRING(s,i,j - i + 1) - -firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] -firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] - -isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) - -grepSplit(lines,doc?) == - if doc? then - instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") - cons := atts := doms := nil - while lines is [line, :lines] repeat - if doc? then - N:=PARSE_-INTEGER dbPart(line,1,-1) - if NUMBERP N then - FILE_-POSITION(instream2,N) - line := READLINE instream2 - kind := dbKind line - not $includeUnexposed? and not dbExposed?(line,kind) => 'skip - (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip - PROGN - kind = char 'c => cats := insert(line,cats) - kind = char 'd => doms := insert(line,doms) - kind = char 'x => defs := insert(line,defs) - kind = char 'p => paks := insert(line,paks) - kind = char 'a => atts := insert(line,atts) - kind = char 'o => ops := insert(line,ops) - kind = char '_- => 'skip --for now - systemError 'kind - if doc? then CLOSE instream2 - [['"attribute",:NREVERSE atts], - ['"operation",:NREVERSE ops], - ['"category",:NREVERSE cats], - ['"domain",:NREVERSE doms], - ['"package",:NREVERSE paks] --- ['"default_ package",:NREVERSE defs] -- drop defaults - ] - -mkUpDownPattern s == recurse(s,0,#s) where - recurse(s,i,n) == - i = n => '"" - STRCONC(fixchar(s.i),recurse(s,i + 1,n)) - fixchar(c) == - ALPHA_-CHAR_-P c => - STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) - c - -mkGrepPattern(s,key) == - --called by grepConstruct1 and grepf - atom s => mkGrepPattern1(s,key) - [first s,:[mkGrepPattern(x,key) for x in rest s]] - -mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) - $options : local := options - s := STRINGIMAGE x ---s := DOWNCASE STRINGIMAGE x - addOptions remUnderscores addWilds split(g s,char '_*) where - addWilds sl == --add wild cards (sl is list of parts between *'s) - IFCAR sl = '"" => h(IFCDR sl,[$wild1]) - h(sl,nil) - g s == --remove "*"s around pattern for text match - not MEMQ('w,$options) => s - if s.0 = char '_* then s := SUBSTRING(s,1,nil) - if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) - s - h(sl,res) == --helper for wild cards - sl is [s,:r] => h(r,[$wild1,s,:res]) - res := rest res - if not MEMQ('w,$options) then - if first res ^= '"" then res := ['"`",:res] - else if res is [.,p,:r] and p = $wild1 then res := r - "STRCONC"/NREVERSE res - remUnderscores s == - (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => - STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", - remUnderscores(SUBSTRING(s,k + 2,nil))) - s - split(s,char) == - max := MAXINDEX s + 1 - f := -1 - [SUBSTRING(s,i,f-i) - while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] - charPosition(c,t,startpos) == --honors underscores - n := SIZE t - if startpos < 0 or startpos > n then error "index out of range" - k:= startpos - for i in startpos .. n-1 while c ^= ELT(t,i) - or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) - k - addOptions s == --add front anchor - --options a o c d p x denote standard items - --options w means comments - --option t means text - --option s means signature - --option n means number of arguments - --option i means predicate - --option none means NO PREFIX - one := ($options is [x,:$options] and x => x; '"[^x]") - tick := '"[^`]*`" - one = 'w => s - one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) - prefix := - one = 't => STRCONC(tick,tick,tick,tick,tick,".*") - one = 'n => tick - one = 'i => STRCONC(tick,tick,tick,tick) - one = 's => STRCONC(tick,tick,tick) --- true => '"" ----> never put on following prefixes - one = 'k => '"[cdp]" - one = 'y => '"[cdpx]" - STRINGIMAGE one - s = $wild1 => STRCONC('"^",prefix) - STRCONC('"^",prefix,s) - -conform2OutputForm(form) == - [op,:args] := form - null args => form - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pp [x,atype,pred] - pred => conform2OutputForm x - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - algCoerceInteractive(x,typ,'(OutputForm)) - [op,:sargl] - -oPage(a,:b) == --called by \spadfun{opname} - oSearch (IFCAR b or a) --always take slow path - -oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} - htPage := htInitPage(nil,nil) --create empty page and fill in needed properties - htpSetProperty(htPage,'conform,conform := getConstructorForm conname) - htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) - itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" - null itemlist => systemError [conform,'" has no operation named ",opname] - opAlist := [itemlist] - dbShowOperationsFromConform(htPage,'"operation",opAlist) - -aPage(a,:b) == --called by \spadatt{a} - $attributeArgs : local := nil - arg := IFCAR b or a - s := pmParseFromString STRINGIMAGE arg - searchOn := - ATOM s => s - IFCAR s - $attributeArgs : local := IFCAR IFCDR s - aSearch searchOn ---must recognize that not all attributes can be found in database ---e.g. constant(deriv) is not but appears in a conditional in LODO - -spadType(x) == --called by \spadtype{x} from HyperDoc - s := PNAME x - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - if atom form then form := [form] - op := opOf form - looksLikeDomainForm form => APPLY(function conPage,form) - conPage(op) - -looksLikeDomainForm x == - entry := getCDTEntry(opOf x,true) or return false - coSig := LASSOC('coSig,CDDR entry) - k := #coSig - atom x => k = 1 - k ^= #x => false - and/[p for key in rest coSig for arg in rest x] where - p == - key => looksLikeDomainForm arg - not IDENTP arg - -spadSys(x) == --called by \spadsyscom{x} - s := PNAME x - if s.0 = char '_) then s := SUBSTRING(s,1,nil) - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - htSystemCommands PNAME opOf form - ---======================================================================= --- Name and General Search ---======================================================================= -aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) ---General search for constructs but NOT documentation - -genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch ---General + documentation search - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - includeDoc? := not IFCAR options ---give summaries for how many a o c d p x match filter - regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) - regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist - key := removeSurroundingStars filter - if includeDoc? then - docSearchAlist := grepConstruct(key,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults - genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) - -genSearchTran alist == [[x,y,:y] for [x,:y] in alist] - - -genSearch1(filter,reg,doc) == - regSearchAlist := searchDropUnexposedLines reg - docSearchAlist := searchDropUnexposedLines doc - key := removeSurroundingStars filter - regCount := searchCount regSearchAlist - docCount := searchCount docSearchAlist - count := regCount + docCount - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => - alist := (regCount = 1 => regSearchAlist; docSearchAlist) - showNamedConstruct(or/[x for x in alist | CADR x]) - summarize? := - docSearchAlist => true - nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] - not(nonEmpties is [pair]) - not summarize? => showNamedConstruct pair - -----------generate a summary page--------------------------- - plural := - $exposedOnlyIfTrue => '"exposed entries match" - '"entries match" - prefix := pluralSay(count,'"", plural) - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'regSearchAlist,regSearchAlist) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'filter,filter) - if docSearchAlist then - dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") - for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,summarize?,kind,i,'showConstruct) - if docSearchAlist then - htSaySaturn '"\bigskip{}" - dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt "\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() -searchDropUnexposedLines alist == - [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where - pred == - not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line - nil - -htShowPageStar() == -------------> OBSELETE - htSayStandard '"\endscroll " - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Exposed",'" {\em only}",'repeatSearch,NIL]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'repeatSearch,'T]]] - htShowPageNoScroll() - -repeatSearch(htPage,newValue) == - $exposedOnlyIfTrue := newValue - filter := htpProperty(htPage,'filter) - reg := htpProperty(htPage,'regSearchAlist) - doc := htpProperty(htPage,'docSearchAlist) - reg => genSearch1(filter,reg,doc) - docSearch1(filter,doc) - -searchCount u == +/[# y for [x,y,:.] in u] - -showDoc(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) - -showConstruct(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) - -showIt(htPage,index,searchAlist) == - filter := htpProperty(htPage,'filter) - [relativeIndex,n] := DIVIDE(index,8) - relativeIndex = 0 => showNamedConstruct(searchAlist.n) - [kind,items,:.] := searchAlist . n - for j in 1.. while j < relativeIndex repeat items := rest items - firstName := dbName first items --select name then gather all of same name - lines := [line for line in items while dbName line = firstName] - showNamedConstruct [kind,nil,:lines] - -showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") - -genSearchSay(pair,summarize,kind,who,fn) == - [u,:fullLineList] := pair - count := #u - uniqueCount := genSearchUniqueCount u - short := summarize and uniqueCount >= $browseCountThreshold - htMakePage - [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] - if count = 0 then htSay('"{\em No ",kind,'"} ") - else if count = 1 then - htSay('"{\em 1 ",kind,'"} ") - else - htSay('"{\em ",count,'" ",pluralize kind,'"} ") - short => 'done - if uniqueCount ^= 1 then - htSayStandard '"\indent{4}" - htSay '"\newline " - htBeginTable() - lastid := nil - groups := organizeByName u - i := 1 - for group in groups repeat - id := dbGetName first group - if $includeUnexposed? then - exposed? := or/[dbExposed?(item,dbKind item) for item in group] - bcHt '"{" - if $includeUnexposed? then - exposed? => htBlank() - htSayUnexposed() - htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] - i := i + #group - bcHt '"}" - if uniqueCount ^= 1 then - htEndTable() - htSayStandard '"\indent{0}" - -organizeByName u == - [[(u := rest u; x) while u and head = dbName (x := first u)] - while u and (head := dbName first u)] - -genSearchSayJump(htPage,[lines,kind]) == - filter := htpProperty(htPage,'filter) - dbSearch(lines,kind,filter) - -genSearchUniqueCount(u) == ---count the unique number of items (if less than $browseCountThreshold) - count := 0 - lastid := nil - for item in u while count < $browseCountThreshold repeat - id := dbGetName item - if id ^= lastid then - count := count + 1 - lastid := id - count - -dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) - -pluralSay(count,singular,plural,:options) == - item := (options is [x,:options] => x; '"") - colon := (IFCAR options => '":"; '"") - count = 0 => concat('"No ",singular,item) - count = 1 => concat('"1 ",singular,item,colon) - concat(count,'" ",plural,item,colon) - - ---======================================================================= --- Documentation Search ---======================================================================= -docSearch filter == --"Documentation" from HD (see man0.ht) - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - key := removeSurroundingStars filter - docSearchAlist := grepConstruct(filter,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults - docSearch1(filter,genSearchTran docSearchAlist) - -docSearch1(filter,doc) == - docSearchAlist := searchDropUnexposedLines doc - count := searchCount docSearchAlist - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) - prefix := pluralSay(count,'"entry matches",'"entries match") - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'regSearchAlist,nil) - htpSetProperty(page,'filter,filter) - dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() - -removeSurroundingStars filter == - key := STRINGIMAGE filter - if key.0 = char '_* then key := SUBSTRING(key,1,nil) - if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) - key - -showNamedDoc([kind,:lines],index) == - dbGather(kind,lines,index - 1,true) - -sayDocMessage message == - htSay('"{\em ") - if message is [leftEnd,left,middle,right,rightEnd] then - htSay(leftEnd,left,'"}") - if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() - htSay middle - if right ^= '"" and right.0 = $blank then htBlank() - htSay('"{\em ",right,rightEnd) - else - htSay message - htSay ('"}") - -stripOffSegments(s,n) == - progress := true - while n > 0 and progress = true repeat - n := n - 1 - k := charPosition(char '_`,s,0) - new := SUBSTRING(s,k + 1,nil) - #new < #s => s := new - progress := false - n = 0 => s - nil - -replaceTicksBySpaces s == - n := -1 - max := MAXINDEX s - while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) - s - -checkFilter filter == - filter := STRINGIMAGE filter - filter = '"" => '"*" - trimString filter - -aSearch filter == --called from HD (man0.ht): general attribute search - null (filter := checkFilter filter) => nil --in case of filter error - dbSearch(grepConstruct(filter,'a),'"attribute",filter) - -oSearch filter == -- called from HD (man0.ht): operation search - opAlist := opPageFastPath filter => opPageFast opAlist - key := 'o - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) - oSearchGrep(filter,key,'"operation") - -oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch - dbSearch(grepConstruct(filter,'o),kind,filter) - -grepSearchQuery(kind,items) == - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'items,items) - htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) - htShowPage() - -cSearch filter == --called from HD (man0.ht): category search - constructorSearch(checkFilter filter,'c,'"category") - -dSearch filter == --called from HD (man0.ht): domain search - constructorSearch(checkFilter filter,'d,'"domain") - -pSearch filter == --called from HD (man0.ht): package search - constructorSearch(checkFilter filter,'p,'"package") - -xSearch filter == --called from HD (man0.ht): default package search - constructorSearch(checkFilter filter,'x,'"default package") - -kSearch filter == --called from HD (man0.ht): constructor search (no defaults) - constructorSearch(checkFilter filter,'k,'"constructor") - -ySearch filter == --called from conPage: like kSearch but defaults included - constructorSearch(checkFilter filter,'y,'"constructor") - -constructorSearch(filter,key,kind) == - null filter => nil --in case of filter error - (parse := conSpecialString? filter) => conPage parse - pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => - downlink pageName - name := (STRINGP filter => INTERN filter; filter) - if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u - line := conPageFastPath DOWNCASE filter => - code := dbKind line - newkind := - code = char 'p => '"package" - code = char 'd => '"domain" - code = char 'c => '"category" - nil - kind = '"constructor" or kind = newkind => kPage line - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'line,line) - message := - ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", - newkind,'"}. Would you like to view it?\vspace{1}"] - htQuery(message, 'grepConstructorSearch,true) - htShowPage() - filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) - constructorSearchGrep(filter,key,kind) - -grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) - -conSpecialString?(filter,:options) == - secondTime := IFCAR options - parse := - words := string2Words filter is [s] => ncParseFromString s - and/[not member(x,'("and" "or" "not")) for x in words] => ncParseFromString filter - false - null parse => nil - form := conLowerCaseConTran parse - MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil - filter = '"Mapping" =>nil - u := kisValidType form => u - secondTime => false - u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] - conSpecialString?(u, true) - -dbString2Words l == - i := 0 - [w while dbWordFrom(l,i) is [w,i]] - -$dbDelimiters := [char " " , char "(", char ")"] - -dbWordFrom(l,i) == - maxIndex := MAXINDEX l - while maxIndex >= i and l.i = char " " repeat i := i + 1 - if maxIndex >= i and member(l.i, $dbDelimiters) then return [l.i, i + 1] - k := or/[j for j in i..maxIndex | not member(l.j, $dbDelimiters)] or return nil - buf := '"" - while k <= maxIndex and not member(c := l.k, $dbDelimiters) repeat - ch := - c = char '__ => l.(k := 1+k) --this may exceed bounds - c - buf := STRCONC(buf,ch) - k := k + 1 - [buf,k] - -conLowerCaseConTran x == - IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x - atom x => x - [conLowerCaseConTran y for y in x] - -string2Constructor x == - not STRINGP x => x - IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x - -conLowerCaseConTranTryHarder x == - IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x - atom x => x - [conLowerCaseConTranTryHarder y for y in x] - -constructorSearchGrep(filter,key,kind) == - dbSearch(grepConstruct(filter,key),kind,filter) - -grepSearchJump(htPage,yes) == - [filter,key,kind,fn] := htpProperty(htPage,'items) - FUNCALL(fn,filter,key,kind) - ---======================================================================= --- Branch Functions After Database Search ---======================================================================= -dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search - lines is ['error,:.] => bcErrorPage lines - null filter => nil --means filter error - lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) - if member(kind,'("attribute" "operation")) then --should not be necessary!! - lines := dbScreenForDefaultFunctions lines - count := #lines - count = 0 => emptySearchPage(kind,filter) - member(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) - dbShowConstructorLines lines - -dbSearchAbbrev([.,:conlist],kind,filter) == - null conlist => emptySearchPage('"abbreviation",filter) - kind := intern kind - if kind ^= 'constructor then - conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] - conlist is [[nam,:.]] => conPage DOWNCASE nam - cAlist := [[con,:true] for con in conlist] - htPage := htInitPage('"",nil) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,nil) - return dbShowCons(htPage,'names) - page := htInitPage([#conlist, - '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) - for [nam,abbr,:r] in conlist repeat - kind := LASSOC('kind,r) - htSay('"\newline{\em ",s := STRINGIMAGE abbr) - htSayStandard '"\tab{10}" - htSay '"}" - htSay kind - htSayStandard '"\tab{19}" - bcCon nam - htShowPage() - ---======================================================================= --- Selectable Search ---======================================================================= -detailedSearch(filter) == - page := htInitPage('"Detailed Search with Options",nil) - filter := escapeSpecialChars PNAME filter - bcHt '"Select what you want to search for, then click on {\em Search} below" - bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." - htSayHrule() - htMakePage '( - (text . "\newline") - (bcRadioButtons which - ( "\tab{3}{\em Operations}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" opname EM)) - (text . " \#args") (bcStrings (1 "*" opnargs EM)) - (text . " signature") (bcStrings (14 "*" opsig EM)) - (text . "\vspace{1}\newline ")) - ops) - ( "\tab{3}{\em Attributes}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" attrname EM)) - (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) - (text . " arguments ")(bcStrings (14 "*" attrargs EM)) - (text . "\vspace{1}\newline ")) - attrs) - ( "\tab{3}{\em Constructors}" - ((text . "\tab{17}") - (bcButtons (1 cats)) (text . " {\em categories} ") - (bcButtons (1 doms)) (text . " {\em domains} ") - (bcButtons (1 paks)) (text . " {\em packages} ") - (bcButtons (1 defs)) (text . " {\em defaults} ") - (text . "\newline\tab{3}") - (text . "name") (bcStrings (14 "*" conname EM)) - (text . " \#args") (bcStrings (1 "*" connargs EM)) - (text . "signature") (bcStrings (14 "*" consig EM)) - (text . "\vspace{1}\newline ")) - cons) --- ( "\tab{3}{\em Documentation}" --- ((text . "\tab{26}key") --- (bcStrings (28 "*" docfilter EM))) --- doc) - ) - (text . "\vspace{1}\newline\center{ ") - (bcLinks ("\box{Search}" "" generalSearchDo NIL)) - (text . "}")) - htShowPage() - -generalSearchDo(htPage,flag) == ---$exposedOnlyIfTrue := (flag => 'T; nil) - $htPage := htPage - alist := htpInputAreaAlist htPage - which := htpButtonValue(htPage,'which) - selectors := - which = 'cons => '(conname connargs consig) - which = 'ops => '(opname opnargs opsig) - '(attrname attrnargs attrargs) - name := generalSearchString(htPage,selectors.0) - nargs:= generalSearchString(htPage,selectors.1) - npat := standardizeSignature generalSearchString(htPage,selectors.2) - kindCode := - which = 'ops => char 'o - which = 'attrs => char 'a - acc := '"" - if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) - if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) - if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) - if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) - n := #acc - n = 0 or n = 4 => '"[cdpx]" - n = 1 => acc - STRCONC(char '_[,acc,char '_]) - form := mkDetailedGrepPattern(kindCode,name,nargs,npat) - lines := applyGrep(form,'libdb) ---lines := dbReadLines resultFile - if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines - kind := - which = 'cons => - n = 1 => - htButtonOn?(htPage,'cats) => '"category" - htButtonOn?(htPage,'doms) => '"domain" - htButtonOn?(htPage,'paks) => '"package" - '"default package" - '"constructor" - which = 'ops => '"operation" - '"attribute" - null lines => emptySearchPage(kind,nil) - dbSearch(lines,kind,'"filter") - -generalSearchString(htPage,sel) == - string := htpLabelInputString(htPage,sel) - string = '"" => '"*" - string - -htButtonOn?(htPage,key) == - LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" - -mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where - main == - nottick := '"[^`]" - name := replaceGrepStar name - firstPart := - $saturn => STRCONC(char '_^,name) - STRCONC(char '_^,kind,name) - nargsPart := replaceGrepStar nargs - exposedPart := char '_. --always get exposed/unexposed - patPart := replaceGrepStar argOrSig - simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) - conc(a,b) == - b = '"[^`]*" or b = char '_. => a - STRCONC(a,$tick,b) - simp a == - m := MAXINDEX a - m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ - and a.(m-3) = $tick and a.(m-2) = char '_] - and a.(m-1) = char '_* and a.m = $tick - => simp SUBSTRING(a,0,m-5) - a - -replaceGrepStar s == - s = "" => s - final := MAXINDEX s - i := charPosition(char '_*,s,0) - i > final => s - STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) - -standardizeSignature(s) == underscoreDollars - s.0 = char '_( => s - k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants - s.(k - 1) = char '_) => STRCONC(char '_(,s) - STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) - -underscoreDollars(s) == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => '"" - (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) - STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) - ---======================================================================= --- Code dependent on $saturn ---======================================================================= - -obey x == - $saturn and not $aixTestSaturn => nil - OBEY x - ---======================================================================= --- I/O Code ---======================================================================= - -getTempPath kind == - pathname := mkGrepFile kind - obey STRCONC('"rm -f ", pathname) - pathname - -dbWriteLines(s, :options) == - pathname := IFCAR options or getTempPath 'source - $outStream: local := MAKE_-OUTSTREAM pathname - for x in s repeat writedb x - SHUT $outStream - pathname - -dbReadLines target == --AIX only--called by grepFile - instream := OPEN target - lines := [READLINE instream while not EOFP instream] - CLOSE instream - lines - -dbGetCommentOrigin line == ---Given a comment line in comdb, returns line in libdb pointing to it ---Comment lines have format [dcpxoa]xxxxxx`ccccc... where ---x's give pointer into libdb, c's are comments - firstPart := dbPart(line,1,-1) - key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away - address := SUBSTRING(firstPart, 1, nil) --address in libdb - instream := OPEN grepSource key --this always returns libdb now - FILE_-POSITION(instream,PARSE_-INTEGER address) - line := READLINE instream - CLOSE instream - line - -grepSource key == - key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") - key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") - key = $localLibdb => $localLibdb - mkGrepTextfile - MEMQ(key, '(_. a c d k o p x)) => 'libdb - 'comdb - -mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") - -mkGrepFile s == --called to generate a path name for a temporary grep file - prefix := - $standard or $aixTestSaturn => '"/tmp/" - STRCONC($SPADROOT,'"/algebra/") - suffix := getEnv '"SPADNUM" - STRCONC(prefix, PNAME s,'".txt.", suffix) - ---======================================================================= --- Grepping Code ---======================================================================= - -grepFile(pattern,:options) == - key := (x := IFCAR options => (options := rest options; x); nil) - source := grepSource key - lines := - not PROBE_-FILE source => NIL - $standard or $aixTestSaturn => - -----AIX Version---------- - target := getTempPath 'target - casepart := - MEMQ('iv,options)=> '"-vi" - '"-i" - command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) - obey - member(key,'(a o c d p x)) => - STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) - STRCONC(command, '" > ",target) - dbReadLines target - ----Windows Version------ - invert? := MEMQ('iv, options) - GREP(source, pattern, false, not invert?) - dbUnpatchLines lines - -dbUnpatchLines lines == --concatenate long lines together, skip blank lines - dash := char '_- - acc := nil - while lines is [line, :lines] repeat - #line = 0 => 'skip --skip blank lines - acc := - line.0 = dash and line.1 = dash => - [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] - [line,:acc] - -- following call to NREVERSE needed to keep lines properly sorted - NREVERSE acc ------> added by BMT 12/95 - - - - diff --git a/src/interp/br-search.boot.pamphlet b/src/interp/br-search.boot.pamphlet new file mode 100644 index 00000000..f886a96a --- /dev/null +++ b/src/interp/br-search.boot.pamphlet @@ -0,0 +1,1040 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-search.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS b-search.boot <================================ + +--======================================================================= +-- Grepping Database libdb.text +-- Redone 12/95 for Saturn; previous function grep renamed as grepFile +-- This function now either returns a filename or a list of strings +--======================================================================= +grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) +--Called from genSearch with key = "." and "w" +--key = "." means a o c d p x +--option1 = true means return the result as a file +--All searches of the database call this function to get relevant lines +--from libdb.text. Returns either a list of lines (usual case) or else +--an alist of the form ((kind . ) ...) + $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" + lines := grepConstruct1(s,key) + IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor + MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o + lines + +grepConstruct1(s,key) == +--returns the name of file (WITHOUT .text.$SPADNUM on the end) + $key : local := key + if key = 'k and --convert 'k to 'y if name contains an "&" + or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y + filter := pmTransFilter STRINGIMAGE s --parses and-or-not form + filter is ['error,:.] => filter --exit on parser error + pattern := mkGrepPattern(filter,key) --create string to pass to "grep" + grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot + +grepConstructDo(x, key) == + $orCount := 0 +--atom x => grepFile(x, key,'i) + $localLibdb => + oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) + newLines := grepf(x,$localLibdb,false) + union(oldLines, newLines) + grepf(x,key,false) + +dbExposed?(line,kind) == -- does line come from an unexposed constructor? + conname := INTERN + kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle + dbName line + isExposedConstructor conname + +dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] + +isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x + +grepForAbbrev(s,key) == +--checks that filter s is not * and is all uppercase; if so, look for abbrevs + u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first + s := STRINGIMAGE s + someLowerCaseChar := false + someUpperCaseChar := false + for i in 0..MAXINDEX s repeat + c := s . i + LOWER_-CASE_-P c => return (someLowerCaseChar := true) + UPPER_-CASE_-P c => someUpperCaseChar := true + someLowerCaseChar or not someUpperCaseChar => false + pattern := DOWNCASE s + ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) + for x in allConstructors() | test]] where test == + not $includeUnexposed? and not isExposedConstructor x => false + a := GETDATABASE(x,'ABBREVIATION) + match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) + +applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn + atom x => grepFile(x,filename,'i) + $localLibdb => + a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) + b := grepf(x,$localLibdb,false) + grepCombine(a,b) + grepf(x,filename,false) + +grepCombine(a,b) == MSORT union(a,b) + +grepf(pattern,s,not?) == --s=sourceFile or list of strings + pattern is [op,:argl] => + op = "and" => + while argl is [arg,:argl] repeat + s := grepf(arg,s,not?) -- filter by successive greps + s + op = "or" => + targetStack := nil + "union"/[grepf(arg,s,not?) for arg in argl] + op = "not" => + not? => grepf(first argl,s,false) + --could be the first time so have to get all of same $key + lines := grepf(mkGrepPattern('"*",$key),s,false) + grepf(first argl,lines,true) + systemError nil + option := + not? => 'iv + 'i + source := + LISTP s => dbWriteLines s + s + grepFile(pattern,source,option) + +pmTransFilter s == +--result is either a string or (op ..) where op= and,or,not and arg are results + if $browseMixedCase = true then s := DOWNCASE s + or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] + => (parse := pmParseFromString s) and checkPmParse parse or + ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] + or/[s . i = char '_* and s.(i + 1) = char '_* + and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] + => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] + s + +checkPmParse parse == + STRINGP parse => parse + fn parse => parse where fn(u) == + u is [op,:args] => + MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] + STRINGP u => true + false + nil + +dnForm x == + STRINGP x => x + x is ['not,argl] => + argl is ['or,:orargs]=> + ['and, :[dnForm negate u for u in orargs]] where negate s == + s is ['not,argx] => argx + ['not,s] + argl is ['and,:andargs]=> + ['or,:[dnForm negate u for u in andargs]] + argl is ['not,notargl]=> + dnForm notargl + x + x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] + x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] + x + +pmParseFromString s == + u := ncParseFromString pmPreparse s + dnForm flatten u where flatten s == + s is [op,:argl] => + STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) + [op,:[flatten x for x in argl]] + s + +pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse + hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) + fn(s,n,siz) == --main function: s is string, n is origin + n = siz => '"" + i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) + j := firstDelim(s,i + 1) or siz + t := gn(s,i,j - 1) + middle := + member(t,'("and" "or" "not")) => t + --the following 2 lines make commutative("*") parse correctly!!!! + t.0 = char '_" => t + j < siz - 1 and s.j = char '_( => t + STRCONC(char '_",t,char '_") + STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) + gn(s,i,j) == --replace each underscore by 4 underscores! + n := or/[k for k in i..j | s.k = $charUnderscore] => + STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) + SUBSTRING(s,i,j - i + 1) + +firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] +firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] + +isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) + +grepSplit(lines,doc?) == + if doc? then + instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") + cons := atts := doms := nil + while lines is [line, :lines] repeat + if doc? then + N:=PARSE_-INTEGER dbPart(line,1,-1) + if NUMBERP N then + FILE_-POSITION(instream2,N) + line := READLINE instream2 + kind := dbKind line + not $includeUnexposed? and not dbExposed?(line,kind) => 'skip + (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip + PROGN + kind = char 'c => cats := insert(line,cats) + kind = char 'd => doms := insert(line,doms) + kind = char 'x => defs := insert(line,defs) + kind = char 'p => paks := insert(line,paks) + kind = char 'a => atts := insert(line,atts) + kind = char 'o => ops := insert(line,ops) + kind = char '_- => 'skip --for now + systemError 'kind + if doc? then CLOSE instream2 + [['"attribute",:NREVERSE atts], + ['"operation",:NREVERSE ops], + ['"category",:NREVERSE cats], + ['"domain",:NREVERSE doms], + ['"package",:NREVERSE paks] +-- ['"default_ package",:NREVERSE defs] -- drop defaults + ] + +mkUpDownPattern s == recurse(s,0,#s) where + recurse(s,i,n) == + i = n => '"" + STRCONC(fixchar(s.i),recurse(s,i + 1,n)) + fixchar(c) == + ALPHA_-CHAR_-P c => + STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) + c + +mkGrepPattern(s,key) == + --called by grepConstruct1 and grepf + atom s => mkGrepPattern1(s,key) + [first s,:[mkGrepPattern(x,key) for x in rest s]] + +mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) + $options : local := options + s := STRINGIMAGE x +--s := DOWNCASE STRINGIMAGE x + addOptions remUnderscores addWilds split(g s,char '_*) where + addWilds sl == --add wild cards (sl is list of parts between *'s) + IFCAR sl = '"" => h(IFCDR sl,[$wild1]) + h(sl,nil) + g s == --remove "*"s around pattern for text match + not MEMQ('w,$options) => s + if s.0 = char '_* then s := SUBSTRING(s,1,nil) + if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) + s + h(sl,res) == --helper for wild cards + sl is [s,:r] => h(r,[$wild1,s,:res]) + res := rest res + if not MEMQ('w,$options) then + if first res ^= '"" then res := ['"`",:res] + else if res is [.,p,:r] and p = $wild1 then res := r + "STRCONC"/NREVERSE res + remUnderscores s == + (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => + STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", + remUnderscores(SUBSTRING(s,k + 2,nil))) + s + split(s,char) == + max := MAXINDEX s + 1 + f := -1 + [SUBSTRING(s,i,f-i) + while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] + charPosition(c,t,startpos) == --honors underscores + n := SIZE t + if startpos < 0 or startpos > n then error "index out of range" + k:= startpos + for i in startpos .. n-1 while c ^= ELT(t,i) + or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) + k + addOptions s == --add front anchor + --options a o c d p x denote standard items + --options w means comments + --option t means text + --option s means signature + --option n means number of arguments + --option i means predicate + --option none means NO PREFIX + one := ($options is [x,:$options] and x => x; '"[^x]") + tick := '"[^`]*`" + one = 'w => s + one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) + prefix := + one = 't => STRCONC(tick,tick,tick,tick,tick,".*") + one = 'n => tick + one = 'i => STRCONC(tick,tick,tick,tick) + one = 's => STRCONC(tick,tick,tick) +-- true => '"" ----> never put on following prefixes + one = 'k => '"[cdp]" + one = 'y => '"[cdpx]" + STRINGIMAGE one + s = $wild1 => STRCONC('"^",prefix) + STRCONC('"^",prefix,s) + +conform2OutputForm(form) == + [op,:args] := form + null args => form + cosig := rest GETDATABASE(op,'COSIG) + atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == + pp [x,atype,pred] + pred => conform2OutputForm x + typ := sublisFormal(args,atype) + if x is ['QUOTE,a] then x := a + algCoerceInteractive(x,typ,'(OutputForm)) + [op,:sargl] + +oPage(a,:b) == --called by \spadfun{opname} + oSearch (IFCAR b or a) --always take slow path + +oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} + htPage := htInitPage(nil,nil) --create empty page and fill in needed properties + htpSetProperty(htPage,'conform,conform := getConstructorForm conname) + htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) + itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" + null itemlist => systemError [conform,'" has no operation named ",opname] + opAlist := [itemlist] + dbShowOperationsFromConform(htPage,'"operation",opAlist) + +aPage(a,:b) == --called by \spadatt{a} + $attributeArgs : local := nil + arg := IFCAR b or a + s := pmParseFromString STRINGIMAGE arg + searchOn := + ATOM s => s + IFCAR s + $attributeArgs : local := IFCAR IFCDR s + aSearch searchOn +--must recognize that not all attributes can be found in database +--e.g. constant(deriv) is not but appears in a conditional in LODO + +spadType(x) == --called by \spadtype{x} from HyperDoc + s := PNAME x + form := ncParseFromString s or + systemError ['"Argument: ",s,'" to spadType won't parse"] + if atom form then form := [form] + op := opOf form + looksLikeDomainForm form => APPLY(function conPage,form) + conPage(op) + +looksLikeDomainForm x == + entry := getCDTEntry(opOf x,true) or return false + coSig := LASSOC('coSig,CDDR entry) + k := #coSig + atom x => k = 1 + k ^= #x => false + and/[p for key in rest coSig for arg in rest x] where + p == + key => looksLikeDomainForm arg + not IDENTP arg + +spadSys(x) == --called by \spadsyscom{x} + s := PNAME x + if s.0 = char '_) then s := SUBSTRING(s,1,nil) + form := ncParseFromString s or + systemError ['"Argument: ",s,'" to spadType won't parse"] + htSystemCommands PNAME opOf form + +--======================================================================= +-- Name and General Search +--======================================================================= +aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) +--General search for constructs but NOT documentation + +genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch +--General + documentation search + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => htErrorStar() + includeDoc? := not IFCAR options +--give summaries for how many a o c d p x match filter + regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) + regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist + key := removeSurroundingStars filter + if includeDoc? then + docSearchAlist := grepConstruct(key,'w,true) + docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist + docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults + genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) + +genSearchTran alist == [[x,y,:y] for [x,:y] in alist] + + +genSearch1(filter,reg,doc) == + regSearchAlist := searchDropUnexposedLines reg + docSearchAlist := searchDropUnexposedLines doc + key := removeSurroundingStars filter + regCount := searchCount regSearchAlist + docCount := searchCount docSearchAlist + count := regCount + docCount + count = 0 => emptySearchPage('"entry",filter,true) + count = 1 => + alist := (regCount = 1 => regSearchAlist; docSearchAlist) + showNamedConstruct(or/[x for x in alist | CADR x]) + summarize? := + docSearchAlist => true + nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] + not(nonEmpties is [pair]) + not summarize? => showNamedConstruct pair + -----------generate a summary page--------------------------- + plural := + $exposedOnlyIfTrue => '"exposed entries match" + '"entries match" + prefix := pluralSay(count,'"", plural) + emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] + header := [:prefix,'" ",:emfilter] + page := htInitPage(header,nil) + htpSetProperty(page,'regSearchAlist,regSearchAlist) + htpSetProperty(page,'docSearchAlist,docSearchAlist) + htpSetProperty(page,'filter,filter) + if docSearchAlist then + dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") + for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt '"\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,summarize?,kind,i,'showConstruct) + if docSearchAlist then + htSaySaturn '"\bigskip{}" + dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") + for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt "\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,true,kind,i,'showDoc) + htShowPageStar() +searchDropUnexposedLines alist == + [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where + pred == + not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line + nil + +htShowPageStar() == +------------> OBSELETE + htSayStandard '"\endscroll " + if $exposedOnlyIfTrue then + htMakePage [['bcLinks,['"Exposed",'" {\em only}",'repeatSearch,NIL]]] + else + htSay('"*{\em =}") + htMakePage [['bcLinks,['"unexposed",'"",'repeatSearch,'T]]] + htShowPageNoScroll() + +repeatSearch(htPage,newValue) == + $exposedOnlyIfTrue := newValue + filter := htpProperty(htPage,'filter) + reg := htpProperty(htPage,'regSearchAlist) + doc := htpProperty(htPage,'docSearchAlist) + reg => genSearch1(filter,reg,doc) + docSearch1(filter,doc) + +searchCount u == +/[# y for [x,y,:.] in u] + +showDoc(htPage,count) == + showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) + +showConstruct(htPage,count) == + showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) + +showIt(htPage,index,searchAlist) == + filter := htpProperty(htPage,'filter) + [relativeIndex,n] := DIVIDE(index,8) + relativeIndex = 0 => showNamedConstruct(searchAlist.n) + [kind,items,:.] := searchAlist . n + for j in 1.. while j < relativeIndex repeat items := rest items + firstName := dbName first items --select name then gather all of same name + lines := [line for line in items while dbName line = firstName] + showNamedConstruct [kind,nil,:lines] + +showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") + +genSearchSay(pair,summarize,kind,who,fn) == + [u,:fullLineList] := pair + count := #u + uniqueCount := genSearchUniqueCount u + short := summarize and uniqueCount >= $browseCountThreshold + htMakePage + [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] + if count = 0 then htSay('"{\em No ",kind,'"} ") + else if count = 1 then + htSay('"{\em 1 ",kind,'"} ") + else + htSay('"{\em ",count,'" ",pluralize kind,'"} ") + short => 'done + if uniqueCount ^= 1 then + htSayStandard '"\indent{4}" + htSay '"\newline " + htBeginTable() + lastid := nil + groups := organizeByName u + i := 1 + for group in groups repeat + id := dbGetName first group + if $includeUnexposed? then + exposed? := or/[dbExposed?(item,dbKind item) for item in group] + bcHt '"{" + if $includeUnexposed? then + exposed? => htBlank() + htSayUnexposed() + htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] + i := i + #group + bcHt '"}" + if uniqueCount ^= 1 then + htEndTable() + htSayStandard '"\indent{0}" + +organizeByName u == + [[(u := rest u; x) while u and head = dbName (x := first u)] + while u and (head := dbName first u)] + +genSearchSayJump(htPage,[lines,kind]) == + filter := htpProperty(htPage,'filter) + dbSearch(lines,kind,filter) + +genSearchUniqueCount(u) == +--count the unique number of items (if less than $browseCountThreshold) + count := 0 + lastid := nil + for item in u while count < $browseCountThreshold repeat + id := dbGetName item + if id ^= lastid then + count := count + 1 + lastid := id + count + +dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) + +pluralSay(count,singular,plural,:options) == + item := (options is [x,:options] => x; '"") + colon := (IFCAR options => '":"; '"") + count = 0 => concat('"No ",singular,item) + count = 1 => concat('"1 ",singular,item,colon) + concat(count,'" ",plural,item,colon) + + +--======================================================================= +-- Documentation Search +--======================================================================= +docSearch filter == --"Documentation" from HD (see man0.ht) + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => htErrorStar() + key := removeSurroundingStars filter + docSearchAlist := grepConstruct(filter,'w,true) + docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist + docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults + docSearch1(filter,genSearchTran docSearchAlist) + +docSearch1(filter,doc) == + docSearchAlist := searchDropUnexposedLines doc + count := searchCount docSearchAlist + count = 0 => emptySearchPage('"entry",filter,true) + count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) + prefix := pluralSay(count,'"entry matches",'"entries match") + emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] + header := [:prefix,'" ",:emfilter] + page := htInitPage(header,nil) + htpSetProperty(page,'docSearchAlist,docSearchAlist) + htpSetProperty(page,'regSearchAlist,nil) + htpSetProperty(page,'filter,filter) + dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") + for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt '"\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,true,kind,i,'showDoc) + htShowPageStar() + +removeSurroundingStars filter == + key := STRINGIMAGE filter + if key.0 = char '_* then key := SUBSTRING(key,1,nil) + if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) + key + +showNamedDoc([kind,:lines],index) == + dbGather(kind,lines,index - 1,true) + +sayDocMessage message == + htSay('"{\em ") + if message is [leftEnd,left,middle,right,rightEnd] then + htSay(leftEnd,left,'"}") + if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() + htSay middle + if right ^= '"" and right.0 = $blank then htBlank() + htSay('"{\em ",right,rightEnd) + else + htSay message + htSay ('"}") + +stripOffSegments(s,n) == + progress := true + while n > 0 and progress = true repeat + n := n - 1 + k := charPosition(char '_`,s,0) + new := SUBSTRING(s,k + 1,nil) + #new < #s => s := new + progress := false + n = 0 => s + nil + +replaceTicksBySpaces s == + n := -1 + max := MAXINDEX s + while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) + s + +checkFilter filter == + filter := STRINGIMAGE filter + filter = '"" => '"*" + trimString filter + +aSearch filter == --called from HD (man0.ht): general attribute search + null (filter := checkFilter filter) => nil --in case of filter error + dbSearch(grepConstruct(filter,'a),'"attribute",filter) + +oSearch filter == -- called from HD (man0.ht): operation search + opAlist := opPageFastPath filter => opPageFast opAlist + key := 'o + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) + oSearchGrep(filter,key,'"operation") + +oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch + dbSearch(grepConstruct(filter,'o),kind,filter) + +grepSearchQuery(kind,items) == + page := htInitPage('"Query Page",nil) + htpSetProperty(page,'items,items) + htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) + htShowPage() + +cSearch filter == --called from HD (man0.ht): category search + constructorSearch(checkFilter filter,'c,'"category") + +dSearch filter == --called from HD (man0.ht): domain search + constructorSearch(checkFilter filter,'d,'"domain") + +pSearch filter == --called from HD (man0.ht): package search + constructorSearch(checkFilter filter,'p,'"package") + +xSearch filter == --called from HD (man0.ht): default package search + constructorSearch(checkFilter filter,'x,'"default package") + +kSearch filter == --called from HD (man0.ht): constructor search (no defaults) + constructorSearch(checkFilter filter,'k,'"constructor") + +ySearch filter == --called from conPage: like kSearch but defaults included + constructorSearch(checkFilter filter,'y,'"constructor") + +constructorSearch(filter,key,kind) == + null filter => nil --in case of filter error + (parse := conSpecialString? filter) => conPage parse + pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => + downlink pageName + name := (STRINGP filter => INTERN filter; filter) + if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u + line := conPageFastPath DOWNCASE filter => + code := dbKind line + newkind := + code = char 'p => '"package" + code = char 'd => '"domain" + code = char 'c => '"category" + nil + kind = '"constructor" or kind = newkind => kPage line + page := htInitPage('"Query Page",nil) + htpSetProperty(page,'line,line) + message := + ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", + newkind,'"}. Would you like to view it?\vspace{1}"] + htQuery(message, 'grepConstructorSearch,true) + htShowPage() + filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) + constructorSearchGrep(filter,key,kind) + +grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) + +conSpecialString?(filter,:options) == + secondTime := IFCAR options + parse := + words := string2Words filter is [s] => ncParseFromString s + and/[not member(x,'("and" "or" "not")) for x in words] => ncParseFromString filter + false + null parse => nil + form := conLowerCaseConTran parse + MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil + filter = '"Mapping" =>nil + u := kisValidType form => u + secondTime => false + u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] + conSpecialString?(u, true) + +dbString2Words l == + i := 0 + [w while dbWordFrom(l,i) is [w,i]] + +$dbDelimiters := [char " " , char "(", char ")"] + +dbWordFrom(l,i) == + maxIndex := MAXINDEX l + while maxIndex >= i and l.i = char " " repeat i := i + 1 + if maxIndex >= i and member(l.i, $dbDelimiters) then return [l.i, i + 1] + k := or/[j for j in i..maxIndex | not member(l.j, $dbDelimiters)] or return nil + buf := '"" + while k <= maxIndex and not member(c := l.k, $dbDelimiters) repeat + ch := + c = char '__ => l.(k := 1+k) --this may exceed bounds + c + buf := STRCONC(buf,ch) + k := k + 1 + [buf,k] + +conLowerCaseConTran x == + IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x + atom x => x + [conLowerCaseConTran y for y in x] + +string2Constructor x == + not STRINGP x => x + IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x + +conLowerCaseConTranTryHarder x == + IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x + atom x => x + [conLowerCaseConTranTryHarder y for y in x] + +constructorSearchGrep(filter,key,kind) == + dbSearch(grepConstruct(filter,key),kind,filter) + +grepSearchJump(htPage,yes) == + [filter,key,kind,fn] := htpProperty(htPage,'items) + FUNCALL(fn,filter,key,kind) + +--======================================================================= +-- Branch Functions After Database Search +--======================================================================= +dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search + lines is ['error,:.] => bcErrorPage lines + null filter => nil --means filter error + lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) + if member(kind,'("attribute" "operation")) then --should not be necessary!! + lines := dbScreenForDefaultFunctions lines + count := #lines + count = 0 => emptySearchPage(kind,filter) + member(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) + dbShowConstructorLines lines + +dbSearchAbbrev([.,:conlist],kind,filter) == + null conlist => emptySearchPage('"abbreviation",filter) + kind := intern kind + if kind ^= 'constructor then + conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] + conlist is [[nam,:.]] => conPage DOWNCASE nam + cAlist := [[con,:true] for con in conlist] + htPage := htInitPage('"",nil) + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,nil) + return dbShowCons(htPage,'names) + page := htInitPage([#conlist, + '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) + for [nam,abbr,:r] in conlist repeat + kind := LASSOC('kind,r) + htSay('"\newline{\em ",s := STRINGIMAGE abbr) + htSayStandard '"\tab{10}" + htSay '"}" + htSay kind + htSayStandard '"\tab{19}" + bcCon nam + htShowPage() + +--======================================================================= +-- Selectable Search +--======================================================================= +detailedSearch(filter) == + page := htInitPage('"Detailed Search with Options",nil) + filter := escapeSpecialChars PNAME filter + bcHt '"Select what you want to search for, then click on {\em Search} below" + bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." + htSayHrule() + htMakePage '( + (text . "\newline") + (bcRadioButtons which + ( "\tab{3}{\em Operations}" + ((text . "\newline\space{3}") + (text . "name") (bcStrings (14 "*" opname EM)) + (text . " \#args") (bcStrings (1 "*" opnargs EM)) + (text . " signature") (bcStrings (14 "*" opsig EM)) + (text . "\vspace{1}\newline ")) + ops) + ( "\tab{3}{\em Attributes}" + ((text . "\newline\space{3}") + (text . "name") (bcStrings (14 "*" attrname EM)) + (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) + (text . " arguments ")(bcStrings (14 "*" attrargs EM)) + (text . "\vspace{1}\newline ")) + attrs) + ( "\tab{3}{\em Constructors}" + ((text . "\tab{17}") + (bcButtons (1 cats)) (text . " {\em categories} ") + (bcButtons (1 doms)) (text . " {\em domains} ") + (bcButtons (1 paks)) (text . " {\em packages} ") + (bcButtons (1 defs)) (text . " {\em defaults} ") + (text . "\newline\tab{3}") + (text . "name") (bcStrings (14 "*" conname EM)) + (text . " \#args") (bcStrings (1 "*" connargs EM)) + (text . "signature") (bcStrings (14 "*" consig EM)) + (text . "\vspace{1}\newline ")) + cons) +-- ( "\tab{3}{\em Documentation}" +-- ((text . "\tab{26}key") +-- (bcStrings (28 "*" docfilter EM))) +-- doc) + ) + (text . "\vspace{1}\newline\center{ ") + (bcLinks ("\box{Search}" "" generalSearchDo NIL)) + (text . "}")) + htShowPage() + +generalSearchDo(htPage,flag) == +--$exposedOnlyIfTrue := (flag => 'T; nil) + $htPage := htPage + alist := htpInputAreaAlist htPage + which := htpButtonValue(htPage,'which) + selectors := + which = 'cons => '(conname connargs consig) + which = 'ops => '(opname opnargs opsig) + '(attrname attrnargs attrargs) + name := generalSearchString(htPage,selectors.0) + nargs:= generalSearchString(htPage,selectors.1) + npat := standardizeSignature generalSearchString(htPage,selectors.2) + kindCode := + which = 'ops => char 'o + which = 'attrs => char 'a + acc := '"" + if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) + if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) + if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) + if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) + n := #acc + n = 0 or n = 4 => '"[cdpx]" + n = 1 => acc + STRCONC(char '_[,acc,char '_]) + form := mkDetailedGrepPattern(kindCode,name,nargs,npat) + lines := applyGrep(form,'libdb) +--lines := dbReadLines resultFile + if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines + kind := + which = 'cons => + n = 1 => + htButtonOn?(htPage,'cats) => '"category" + htButtonOn?(htPage,'doms) => '"domain" + htButtonOn?(htPage,'paks) => '"package" + '"default package" + '"constructor" + which = 'ops => '"operation" + '"attribute" + null lines => emptySearchPage(kind,nil) + dbSearch(lines,kind,'"filter") + +generalSearchString(htPage,sel) == + string := htpLabelInputString(htPage,sel) + string = '"" => '"*" + string + +htButtonOn?(htPage,key) == + LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" + +mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where + main == + nottick := '"[^`]" + name := replaceGrepStar name + firstPart := + $saturn => STRCONC(char '_^,name) + STRCONC(char '_^,kind,name) + nargsPart := replaceGrepStar nargs + exposedPart := char '_. --always get exposed/unexposed + patPart := replaceGrepStar argOrSig + simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) + conc(a,b) == + b = '"[^`]*" or b = char '_. => a + STRCONC(a,$tick,b) + simp a == + m := MAXINDEX a + m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ + and a.(m-3) = $tick and a.(m-2) = char '_] + and a.(m-1) = char '_* and a.m = $tick + => simp SUBSTRING(a,0,m-5) + a + +replaceGrepStar s == + s = "" => s + final := MAXINDEX s + i := charPosition(char '_*,s,0) + i > final => s + STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) + +standardizeSignature(s) == underscoreDollars + s.0 = char '_( => s + k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants + s.(k - 1) = char '_) => STRCONC(char '_(,s) + STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) + +underscoreDollars(s) == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => '"" + (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) + STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) + +--======================================================================= +-- Code dependent on $saturn +--======================================================================= + +obey x == + $saturn and not $aixTestSaturn => nil + OBEY x + +--======================================================================= +-- I/O Code +--======================================================================= + +getTempPath kind == + pathname := mkGrepFile kind + obey STRCONC('"rm -f ", pathname) + pathname + +dbWriteLines(s, :options) == + pathname := IFCAR options or getTempPath 'source + $outStream: local := MAKE_-OUTSTREAM pathname + for x in s repeat writedb x + SHUT $outStream + pathname + +dbReadLines target == --AIX only--called by grepFile + instream := OPEN target + lines := [READLINE instream while not EOFP instream] + CLOSE instream + lines + +dbGetCommentOrigin line == +--Given a comment line in comdb, returns line in libdb pointing to it +--Comment lines have format [dcpxoa]xxxxxx`ccccc... where +--x's give pointer into libdb, c's are comments + firstPart := dbPart(line,1,-1) + key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away + address := SUBSTRING(firstPart, 1, nil) --address in libdb + instream := OPEN grepSource key --this always returns libdb now + FILE_-POSITION(instream,PARSE_-INTEGER address) + line := READLINE instream + CLOSE instream + line + +grepSource key == + key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") + key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") + key = $localLibdb => $localLibdb + mkGrepTextfile + MEMQ(key, '(_. a c d k o p x)) => 'libdb + 'comdb + +mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") + +mkGrepFile s == --called to generate a path name for a temporary grep file + prefix := + $standard or $aixTestSaturn => '"/tmp/" + STRCONC($SPADROOT,'"/algebra/") + suffix := getEnv '"SPADNUM" + STRCONC(prefix, PNAME s,'".txt.", suffix) + +--======================================================================= +-- Grepping Code +--======================================================================= + +grepFile(pattern,:options) == + key := (x := IFCAR options => (options := rest options; x); nil) + source := grepSource key + lines := + not PROBE_-FILE source => NIL + $standard or $aixTestSaturn => + -----AIX Version---------- + target := getTempPath 'target + casepart := + MEMQ('iv,options)=> '"-vi" + '"-i" + command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) + obey + member(key,'(a o c d p x)) => + STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) + STRCONC(command, '" > ",target) + dbReadLines target + ----Windows Version------ + invert? := MEMQ('iv, options) + GREP(source, pattern, false, not invert?) + dbUnpatchLines lines + +dbUnpatchLines lines == --concatenate long lines together, skip blank lines + dash := char '_- + acc := nil + while lines is [line, :lines] repeat + #line = 0 => 'skip --skip blank lines + acc := + line.0 = dash and line.1 = dash => + [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] + [line,:acc] + -- following call to NREVERSE needed to keep lines properly sorted + NREVERSE acc ------> added by BMT 12/95 + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot deleted file mode 100644 index f1f286b3..00000000 --- a/src/interp/br-util.boot +++ /dev/null @@ -1,712 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---====================> WAS b-util.boot <================================ - ---======================================================================= --- AXIOM Browser --- Initial entry is from man0.ht page to one of these functions: --- kSearch (cSearch, dSearch, or pSearch), for constructors --- oSearch, for operations --- aSearch, for attributes --- aokSearch, for general search --- docSearch, for documentation search --- genSearch, for complete search ---======================================================================= - -browserAutoloadOnceTrigger() == nil - -----------------------> Global Variables <----------------------- -$includeUnexposed? := true --default setting -$tick := char '_` --field separator for database files -$charUnderscore := ('__) --needed because of parser bug -$wild1 := '"[^`]*" --phrase used to convert keys to grep strings -$browseCountThreshold := 10 --the maximum number of names that will display - --on a general search -$opDescriptionThreshold := 4 --if <= 4 operations with unique name, give desc - --otherwise, give signatures -$browseMixedCase := true --distinquish case in the browser? -$docTable := nil --cache for documentation table -$conArgstrings := nil --bound by conPage so that kPage - --will display arguments if given -$conformsAreDomains := false --are all arguments of a constructor given? -$returnNowhereFromGoGet := false --special branch out for goget for browser -$dbDataFunctionAlist := nil --set by dbGatherData -$domain := nil --bound in koOps -$infovec := nil --bound in koOps -$predvec := nil --bound in koOps -$exposedOnlyIfTrue := nil --see repeatSearch, dbShowOps, dbShowCon -$bcMultipleNames := nil --see bcNameConTable -$bcConformBincount := nil --see bcConform1 -$docTableHash := MAKE_-HASHTABLE 'EQUAL --see dbExpandOpAlistIfNecessary -$groupChoice := nil --see dbShowOperationsFromConform - -------------------> Initial Settings <--------------------- -$pmFilterDelimiters := [char '_(,char '_),char '_ ] -$dbKindAlist := - [[char 'a,:'"attribute"],[char 'o,:'"operation"], - [char 'd,:'"domain"],[char 'p,:'"package"], - [char 'c,:'"category"],[char 'x,:'"default_ package"]] -$OpViewTable := '( - (names "Name" "Names" dbShowOpNames) - (documentation "Name" "Names" dbShowOpDocumentation) - (domains "Domain" "Domains" dbShowOpDomains) - (signatures "Signature" "Signatures" dbShowOpSignatures) - (parameters "Form" "Forms" dbShowOpParameters) - (origins "Origin" "Origins" dbShowOpOrigins) - (implementation nil "Implementation Domains" dbShowOpImplementations) - (conditions "Condition" "Conditions" dbShowOpConditions)) - -bcBlankLine() == bcHt '"\vspace{1}\newline " - -pluralize k == - k = '"child" => '"children" - k = '"category" => '"categories" - k = '"entry" => '"entries" - STRCONC(k,'"s") - -capitalize s == - LASSOC(s,'( - ("domain" . "Domain") - ("category" . "Category") - ("package" . "Package") - ("default package" . "Default Package"))) or - res := COPY_-SEQ s - SETELT(res,0,UPCASE res.0) - res - -escapeSpecialIds u == --very expensive function - x := LASSOC(u,$htCharAlist) => [x] - #u = 1 => - member(u, $htSpecialChars) => [CONCAT('"_\", u)] - [u] - c := char u.0 - or/[c = char y for y in $htSpecialChars] => - [CONCAT('"_\",u)] - [u] - -escapeString com == --this makes changes on single comment lines --- was htexCom - look := 0 - while look repeat - look >= SIZE com => look := [] - - - look := STRPOSL ('"${}#%", com, look, []) - if look then - com := RPLACSTR (com,look,0,'"\") --note RPLACSTR copies!!! - look := look + 2 - com - -htPred2English(x,:options) == - $emList :local := IFCAR options --list of identifiers to be emphasised - $precList: local := '((OR 10 . "or") (AND 9 . "and") - (_< 5) (_<_= 5) (_> 5) (_>_= 5) (_= 5) (_^_= 5) (or 10) (and 9)) - fn(x,100) where - fn(x,prec) == - x is [op,:l] => - LASSOC(op,$precList) is [iprec,:rename] => - if iprec > prec then htSay '"(" - fn(first l,iprec) - for y in rest l repeat - htSay('" ",rename or op,'" ") - fn(y,iprec) - if iprec > prec then htSay '")" - if prec < 5 then htSay '"(" - gn(x,op,l,prec) - if prec < 5 then htSay '")" - x = 'etc => htSay '"..." - IDENTP x and not MEMQ(x,$emList) => htSay escapeSpecialIds PNAME x - htSay form2HtString(x,$emList) - gn(x,op,l,prec) == - MEMQ(op,'(NOT not)) => - htSay('"not ") - fn(first l,0) - op = 'HasCategory => - bcConform(first l,$emList) - htSay('" has ") - bcConform(CADADR l,$emList) - op = 'HasAttribute => - bcConform(first l,$emList) - htSay('" has ") - fnAttr CADADR l - MEMQ(op,'(has ofCategory)) => - bcConform(first l,$emList) - htSay('" has ") - [a,b] := l - b is ['ATTRIBUTE,c] and not constructor? c => fnAttr c - bcConform(b, $emList) - bcConform(x,$emList) - fnAttr c == - s := form2HtString c - member(s,$emList) => htSay('"{\em ",s,'"}") - satDownLink(s, ['"(|aPage| '|",s,'"|)"]) - -unMkEvalable u == - u is ['QUOTE,a] => a - u is ['LIST,:r] => [unMkEvalable x for x in r] - u - -lisp2HT u == ['"_'",:fn u] where fn u == - IDENTP u => escapeSpecialIds PNAME u - STRINGP u => escapeString u - ATOM u => systemError() - ['"_(",:"append"/[fn x for x in u],'")"] - -args2HtString(x,:options) == - null x => '"" - emList := IFCAR options - SUBSTRING(form2HtString(['f,:x],emList),1,nil) - -quickForm2HtString(x) == - atom x => STRINGIMAGE x - form2HtString x - -form2HtString(x,:options) == - $emList:local := IFCAR options --list of atoms to be emphasized - $brief: local := IFCAR IFCDR options --see dbShowOperationsFromConform (lib11) - fn(x) where - fn x == - atom x => - MEMQ(x,$FormalMapVariableList) => STRCONC('"\",STRINGIMAGE x) - u := escapeSpecialChars STRINGIMAGE x - MEMQ(x,$emList) => STRCONC('"{\em ",u,'"}") - STRINGP x => STRCONC('"_"",u,'"_"") - u - first x = 'QUOTE => STRCONC('"'",sexpr2HtString first rest x) - first x = ":" => STRCONC(fn first rest x,'": ",fn first rest rest x) - first x = 'Mapping => - STRCONC(fnTail(rest rest x,'"()"),'"->",fn first rest x) - first x = 'construct => fnTail(rest x,'"[]") - tail := fnTail(rest x,'"()") - head := fn first x --- $brief and #head + #tail > 35 => STRCONC(head,'"(...)") - STRCONC(head,tail) - fnTail(x,str) == - null x => '"" - STRCONC(str . 0,fn first x,fnTailTail rest x,str . 1) - fnTailTail x == - null x => '"" - STRCONC('",",fn first x,fnTailTail rest x) - -sexpr2HtString x == - atom x => form2HtString x - STRCONC('"(",fn x,'")") where fn x == - r := rest x - suffix := - null r => '"" - atom r => STRCONC('" . ",form2HtString rest x) - STRCONC('" ",fn r) - STRCONC(sexpr2HtString first x,suffix) - -form2LispString(x) == - atom x => - x = '_$ => '"__$" - MEMQ(x,$FormalMapVariableList) => STRCONC(STRINGIMAGE '__, STRINGIMAGE x) - STRINGP x => STRCONC('"_"",STRINGIMAGE x,'"_"") - STRINGIMAGE x - x is ['QUOTE,a] => STRCONC('"'",sexpr2LispString a) - x is [":",a,b] => STRCONC(form2LispString a,'":",form2LispString b) - first x = 'Mapping => - null rest (r := rest x) => STRCONC('"()->",form2LispString first r) - STRCONC(args2LispString rest r,'"->",form2LispString first r) - STRCONC(form2LispString first x,args2LispString rest x) - -sexpr2LispString x == - atom x => form2LispString x - STRCONC('"(",fn x,'")") where fn x == - r := rest x - suffix := - null r => '"" - atom r => STRCONC('" . ",form2LispString rest x) - STRCONC('" ",fn r) - STRCONC(sexpr2HtString first x,suffix) - -args2LispString x == - null x => '"" - STRCONC('"(",form2LispString first x,fnTailTail rest x,'")") where - fnTailTail x == - null x => '"" - STRCONC('",",form2LispString first x,fnTailTail rest x) - -dbConstructorKind x == - target := CADAR GETDATABASE(x,'CONSTRUCTORMODEMAP) - target = '(Category) => 'category - target is ['CATEGORY,'package,:.] => 'package - HGET($defaultPackageNamesHT,x) => 'default_ package - 'domain - -getConstructorForm name == - name = 'Union => '(Union (_: a A) (_: b B)) - name = 'UntaggedUnion => '(Union A B) - name = 'Record => '(Record (_: a A) (_: b B)) - name = 'Mapping => '(Mapping T S) - name = 'Enumeration => '(Enumeration a b) - GETDATABASE(name,'CONSTRUCTORFORM) - -getConstructorArgs conname == CDR getConstructorForm conname - -htSay(x,:options) == ---if x = $charEscape then x := $charNewline else ---if x = $stringEscape then x := $stringNewline - bcHt x - for y in options repeat bcHt y - -bcComments(comments,:options) == - italics? := not IFCAR options - STRINGP comments => - comments = '"" => nil - htSay('"\newline ") - if italics? then htSay '"{\em " - htSay comments - if italics? then htSay '"}" - null comments => nil - htSay('"\newline ") - if italics? then htSay "{\em " - htSay first comments - for x in rest comments repeat htSay('" ",x) - if italics? then htSay '"}" - -bcConform(form,:options) == - $italics? : local := IFCAR options - $italicHead? : local := IFCAR IFCDR options - bcConform1 form - -bcConform1 form == main where ------------------> OBSELETE - main == - form is ['ifp,form1,:pred] => - hd form1 - bcPred pred - hd form - hd form == - atom form => - not MEMQ(form,'(Mapping Union Record)) and null constructor? form => - s := STRINGIMAGE form - (s.0 = char '_#) and (n := POSN1(form, $FormalFunctionParameterList)) => - htSay form2HtString ($FormalMapVariableList . n) - htSay form - s := STRINGIMAGE form - $italicHead? => htSayItalics s - $bcMultipleNames => - satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) - satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) - (head := QCAR form) = 'QUOTE => - htSay('"'") - hd CADR form - head = 'SIGNATURE => - htSay(CADR form,'": ") - mapping CADDR form - head = 'Mapping and rest form => rest form => mapping rest form - head = ":" => - hd CADR form - htSay '": " - hd CADDR form - QCDR form and dbEvalableConstructor? form - => bcConstructor(form,head) - hd head - null (r := QCDR form) => nil - tl QCDR form - mapping [target,:source] == - tuple source - bcHt - $saturn => '" {\ttrarrow} " - '" -> " - hd target - tuple u == - null u => bcHt '"()" - null rest u => hd u - bcHt '"(" - hd first u - for x in rest u repeat - bcHt '"," - hd x - bcHt '")" - tl u == - bcHt '"(" - firstTime := true - for x in u repeat - if not firstTime then bcHt '"," - firstTime := false - hd x - bcHt '")" - say x == - if $italics? then bcHt '"{\em " - if x = 'etc then x := '"..." - bcHt escapeSpecialIds STRINGIMAGE x - if $italics? then bcHt '"}" - -bcConstructor(form is [op,:arglist],cname) == --called only when $conformsAreDomains - htSayList dbConformGen form - -htSayList u == - for x in u repeat htSay x - -conform2HtString form == - for u in form2String form repeat - htSay u - -dbEvalableConstructor? form == ---form is constructor form; either ---(a) all arguments are specified or (b) none are specified - form is [op,:argl] => - null argl => true - op = 'QUOTE => 'T --is a domain valued object - and/[dbEvalableConstructor? x for x in argl] - INTEGERP form => true - false - -htSayItalics s == htSay('"{\em ",s,'"}") - -bcCon(name,:options) == - argString := IFCAR options or '"" - s := STRINGIMAGE name - bcStar name - htSayConstructorName(s,s) - htSay argString - -bcAbb(name,abb) == - s := STRINGIMAGE name - a := STRINGIMAGE abb - bcStar name - htSayConstructorName(a,s) - -bcStar name == - if $includeUnexposed? and not isExposedConstructor name then htSayUnexposed() - -bcStarSpace name == - null $includeUnexposed? => nil - not isExposedConstructor name => htSayUnexposed() - htBlank() - -bcStarSpaceOp(op,exposed?) == - null $includeUnexposed? => nil - not exposed? => - htSayUnexposed() - if op.0 = char '_* then htSay '" " - htBlank() - -bcStarConform form == - bcStar opOf form - bcConform form - -dbSourceFile name == - u:= GETDATABASE(name,'SOURCEFILE) - null u => '"" - n := PATHNAME_-NAME u - t := PATHNAME_-TYPE u - STRCONC(n,'".",t) - -asharpConstructorName? name == - u:= GETDATABASE(name,'SOURCEFILE) - u and PATHNAME_-TYPE u = '"as" - -asharpConstructors() == - [x for x in allConstructors() | not asharpConstructorName? x] - -extractFileNameFromPath s == fn(s,0,#s) where - fn(s,i,m) == - k := charPosition(char '_/,s,i) - k = m => SUBSTRING(s,i,nil) - fn(s,k + 1,m) - -bcOpTable(u,fn) == - htBeginTable() - firstTime := true - for op in u for i in 0.. repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - htMakePage [['bcLinks,[escapeSpecialChars STRINGIMAGE opOf op,'"",fn,i]]] - htSay '"}" - htEndTable() - -bcNameConTable u == - $bcMultipleNames: local := (#u ^= 1) - bcConTable REMDUP u - -- bcConTable u - -bcConTable u == - htBeginTable() - firstTime := true - for con in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - bcStarSpace opOf con - bcConform con - htSay '"}" - htEndTable() - -bcAbbTable u == - htBeginTable() - firstTime := true - for x in REMDUP u repeat --allow x to be NIL meaning "no abbreviation" - -- for x in u repeat --allow x to be NIL meaning "no abbreviation" - if firstTime then firstTime := false - else htSaySaturn '"&" - if x is [con,abb,:.] then - htSay '"{" - bcAbb(con,abb) - htSay '"}" - htEndTable() - -bcConPredTable(u,conname,:options) == - italicList := IFCAR options - htBeginTable() - firstTime := true - for [conform,:pred] in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - bcStarSpace opOf conform - form := - atom conform => getConstructorForm conform - conform - bcConform(form,italicList) - if extractHasArgs pred is [arglist,:pred] then - htSay('" {\em of} ") - bcConform([conname,:arglist],italicList,true) - if pred ^= 'etc then bcPred(pred,italicList) - htSay '"}" - htEndTable() - -bcPred(pred,:options) == - pred = '"" or pred = true or null pred => 'skip - italicList := IFCAR options - if not IFCAR IFCDR options then htSay '" {\em if} " - htPred2English(pred,italicList) - -extractHasArgs pred == - x := find pred or return nil where find x == - x is [op,:argl] => - op = 'hasArgs => x - MEMQ(op,'(AND OR NOT)) => or/[find y for y in argl] - nil - nil - [rest x,:simpBool SUBST('T,x,pred)] - -splitConTable cons == - uncond := cond := nil - for (pair := [con,:pred]) in cons repeat - null pred => 'skip - pred = 'T or pred is ['hasArgs,:.] => uncond := [pair,:uncond] - cond := [pair,:cond] - [NREVERSE uncond,:NREVERSE cond] - -bcNameTable(u,fn,:option) == --option if * prefix - htSay '"\newline" - htBeginTable() - firstTime := true - for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - if IFCAR option then bcStar x - htMakePage [['bcLinks,[s := escapeSpecialChars STRINGIMAGE x,'"",fn,s]]] - htSay '"}" - htEndTable() - -bcNameCountTable(u,fn,gn,:options) == - linkFunction := - IFCAR options => 'bcLispLinks - 'bcLinks - htSay '"\newline" - htBeginTable() - firstTime := true - for i in 0.. for x in u repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - htSay '"{" - htMakePage [[linkFunction,[FUNCALL(fn,x),'"",gn,i]]] - htSay '"}" - htEndTable() - -dbSayItemsItalics(:u) == - htSay '"{\em " - APPLY(function dbSayItems,u) - htSay '"}" - -dbSayItems(countOrPrefix,singular,plural,:options) == - bcHt '"\newline " - count := - countOrPrefix is [:prefix,c] => - htSay prefix - c - countOrPrefix - if count = 0 then htSay('"No ",singular) - else if count = 1 then htSay('"1 ",singular) - else htSay(count,'" ",plural) - for x in options repeat bcHt x - if count ^= 0 then bcHt '":" - -dbBasicConstructor? conname == member(dbSourceFile conname,'("catdef" "coerce")) - -nothingFoundPage(:options) == - htInitPage('"Sorry, no match found",nil) - htShowPage() - -htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] - -dbInfovec name == - 'category = GETDATABASE(name,'CONSTRUCTORKIND) => nil - GETDATABASE(name, 'ASHARP?) => nil - loadLibIfNotLoaded(name) - u := GETL(name,'infovec) => u - -emptySearchPage(kind,filter,:options) == - skipNamePart := IFCAR options - heading := ['"No ",capitalize kind,'" Found"] - htInitPage(heading,nil) - exposePart := - null $includeUnexposed? => '"{\em exposed} " - '"" - htSay('"\vspace{1}\newline\centerline{There is no ",exposePart,kind,'" matching pattern}\newline\centerline{{\em ") - if filter then htPred2English filter - htSay '"}}" - htShowPage() - -isLoaded? conform == GETL(constructor? opOf conform,'LOADED) - -string2Integer s == - and/[DIGIT_-CHAR_-P (s.i) for i in 0..MAXINDEX s] => PARSE_-INTEGER s - nil - -dbGetInputString htPage == - s := htpLabelInputString(htPage,'filter) - null s or s = '"" => '"*" - s - - - ---======================================================================= --- Error Pages ---======================================================================= -bcErrorPage u == - u is ['error,:r] => - htInitPage(first r,nil) - bcBlankLine() - for x in rest r repeat htSay x - htShowPage() - systemError '"Unexpected error message" - -errorPage(htPage,[heading,kind,:info]) == - kind = 'invalidType => kInvalidTypePage first info - if heading = 'error then htInitPage('"Error",nil) else - htInitPage(heading,nil) - bcBlankLine() - for x in info repeat htSay x - htShowPage() - -htErrorStar() == - errorPage(nil,['"{\em *} not a valid search string",nil,'"\vspace{3}\centerline{{\em *} is not a valid search string for a general search}\centerline{\em {it would match everything!}}"]) - -htQueryPage(htPage,heading,message,query,fn) == - htInitPage(heading,nil) - htSay message - htQuery(query,fn) - htShowPage() - -htQuery(question,fn,:options) == - upLink? := IFCAR options - if question then - htSay('"\vspace{1}\centerline{") - htSay question - htSay('"}") - htSay('"\centerline{") - htMakePage [['bcLispLinks,['"\fbox{Yes}",'"",fn,'yes]]] - htBlank 4 - if upLink? - then htSay('"\downlink{\fbox{No}}{UpPage}") - else htMakePage [['bcLispLinks,['"\fbox{No}",'"",fn,'no]]] - htSay('"}") - -kInvalidTypePage form == - htInitPage('"Error",nil) - bcBlankLine() - htSay('"\centerline{You gave an invalid type:}\newline\centerline{{\sf ") - htSay(form2HtString form,'"}}") - htShowPage() - -dbNotAvailablePage(:options) == - htInitPage('"Missing Page",nil) - bcBlankLine() - htSay(IFCAR options or '"\centerline{This page is not available yet}") - htShowPage() - ---======================================================================= --- Utility Functions for Manipulating Browse Datalines ---======================================================================= -dbpHasDefaultCategory? s == #s > 1 and s.1 = char 'x --s is part 3 of line - -dbKind line == line.0 - -dbKindString kind == LASSOC(kind,$dbKindAlist) - -dbName line == escapeString SUBSTRING(line,1,charPosition($tick,line,1) - 1) - -dbAttr line == STRCONC(dbName line,escapeString dbPart(line,4,0)) - -dbPart(line,n,k) == --returns part n of line (n=1,..) beginning in column k - n = 1 => SUBSTRING(line,k + 1,charPosition($tick,line,k + 1) - k - 1) - dbPart(line,n - 1,charPosition($tick,line,k + 1)) - -dbXParts(line,n,m) == - [.,nargs,:r] := dbParts(line,n,m) - [dbKindString line.0,dbName line,PARSE_-INTEGER nargs,:r] - -dbParts(line,n,m) == --split line into n parts beginning in column m - n = 0 => nil - [SUBSTRING(line,m,-m + (k := charPosition($tick,line,m))), - :dbParts(line,n - 1,k + 1)] - -dbConname(line) == dbPart(line,5,1) - -dbComments line == dbReadComments(string2Integer dbPart(line,7,1)) - -dbNewConname(line) == --dbName line unless kind is 'a or 'o => name in 5th pos. - (kind := line.0) = char 'a or kind = char 'o => - conform := dbPart(line,5,1) - k := charPosition(char '_(,conform,1) - SUBSTRING(conform,1,k - 1) - dbName line - -dbTickIndex(line,n,k) == --returns index of nth tick in line starting at k - n = 1 => charPosition($tick,line,k) - dbTickIndex(line,n - 1,1 + charPosition($tick,line,k)) - -mySort u == listSort(function GLESSEQP,u) - - - - - diff --git a/src/interp/br-util.boot.pamphlet b/src/interp/br-util.boot.pamphlet new file mode 100644 index 00000000..d157054d --- /dev/null +++ b/src/interp/br-util.boot.pamphlet @@ -0,0 +1,738 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/br-util.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--====================> WAS b-util.boot <================================ + +--======================================================================= +-- AXIOM Browser +-- Initial entry is from man0.ht page to one of these functions: +-- kSearch (cSearch, dSearch, or pSearch), for constructors +-- oSearch, for operations +-- aSearch, for attributes +-- aokSearch, for general search +-- docSearch, for documentation search +-- genSearch, for complete search +--======================================================================= + +browserAutoloadOnceTrigger() == nil + +----------------------> Global Variables <----------------------- +$includeUnexposed? := true --default setting +$tick := char '_` --field separator for database files +$charUnderscore := ('__) --needed because of parser bug +$wild1 := '"[^`]*" --phrase used to convert keys to grep strings +$browseCountThreshold := 10 --the maximum number of names that will display + --on a general search +$opDescriptionThreshold := 4 --if <= 4 operations with unique name, give desc + --otherwise, give signatures +$browseMixedCase := true --distinquish case in the browser? +$docTable := nil --cache for documentation table +$conArgstrings := nil --bound by conPage so that kPage + --will display arguments if given +$conformsAreDomains := false --are all arguments of a constructor given? +$returnNowhereFromGoGet := false --special branch out for goget for browser +$dbDataFunctionAlist := nil --set by dbGatherData +$domain := nil --bound in koOps +$infovec := nil --bound in koOps +$predvec := nil --bound in koOps +$exposedOnlyIfTrue := nil --see repeatSearch, dbShowOps, dbShowCon +$bcMultipleNames := nil --see bcNameConTable +$bcConformBincount := nil --see bcConform1 +$docTableHash := MAKE_-HASHTABLE 'EQUAL --see dbExpandOpAlistIfNecessary +$groupChoice := nil --see dbShowOperationsFromConform + +------------------> Initial Settings <--------------------- +$pmFilterDelimiters := [char '_(,char '_),char '_ ] +$dbKindAlist := + [[char 'a,:'"attribute"],[char 'o,:'"operation"], + [char 'd,:'"domain"],[char 'p,:'"package"], + [char 'c,:'"category"],[char 'x,:'"default_ package"]] +$OpViewTable := '( + (names "Name" "Names" dbShowOpNames) + (documentation "Name" "Names" dbShowOpDocumentation) + (domains "Domain" "Domains" dbShowOpDomains) + (signatures "Signature" "Signatures" dbShowOpSignatures) + (parameters "Form" "Forms" dbShowOpParameters) + (origins "Origin" "Origins" dbShowOpOrigins) + (implementation nil "Implementation Domains" dbShowOpImplementations) + (conditions "Condition" "Conditions" dbShowOpConditions)) + +bcBlankLine() == bcHt '"\vspace{1}\newline " + +pluralize k == + k = '"child" => '"children" + k = '"category" => '"categories" + k = '"entry" => '"entries" + STRCONC(k,'"s") + +capitalize s == + LASSOC(s,'( + ("domain" . "Domain") + ("category" . "Category") + ("package" . "Package") + ("default package" . "Default Package"))) or + res := COPY_-SEQ s + SETELT(res,0,UPCASE res.0) + res + +escapeSpecialIds u == --very expensive function + x := LASSOC(u,$htCharAlist) => [x] + #u = 1 => + member(u, $htSpecialChars) => [CONCAT('"_\", u)] + [u] + c := char u.0 + or/[c = char y for y in $htSpecialChars] => + [CONCAT('"_\",u)] + [u] + +escapeString com == --this makes changes on single comment lines +-- was htexCom + look := 0 + while look repeat + look >= SIZE com => look := [] + + + look := STRPOSL ('"${}#%", com, look, []) + if look then + com := RPLACSTR (com,look,0,'"\") --note RPLACSTR copies!!! + look := look + 2 + com + +htPred2English(x,:options) == + $emList :local := IFCAR options --list of identifiers to be emphasised + $precList: local := '((OR 10 . "or") (AND 9 . "and") + (_< 5) (_<_= 5) (_> 5) (_>_= 5) (_= 5) (_^_= 5) (or 10) (and 9)) + fn(x,100) where + fn(x,prec) == + x is [op,:l] => + LASSOC(op,$precList) is [iprec,:rename] => + if iprec > prec then htSay '"(" + fn(first l,iprec) + for y in rest l repeat + htSay('" ",rename or op,'" ") + fn(y,iprec) + if iprec > prec then htSay '")" + if prec < 5 then htSay '"(" + gn(x,op,l,prec) + if prec < 5 then htSay '")" + x = 'etc => htSay '"..." + IDENTP x and not MEMQ(x,$emList) => htSay escapeSpecialIds PNAME x + htSay form2HtString(x,$emList) + gn(x,op,l,prec) == + MEMQ(op,'(NOT not)) => + htSay('"not ") + fn(first l,0) + op = 'HasCategory => + bcConform(first l,$emList) + htSay('" has ") + bcConform(CADADR l,$emList) + op = 'HasAttribute => + bcConform(first l,$emList) + htSay('" has ") + fnAttr CADADR l + MEMQ(op,'(has ofCategory)) => + bcConform(first l,$emList) + htSay('" has ") + [a,b] := l + b is ['ATTRIBUTE,c] and not constructor? c => fnAttr c + bcConform(b, $emList) + bcConform(x,$emList) + fnAttr c == + s := form2HtString c + member(s,$emList) => htSay('"{\em ",s,'"}") + satDownLink(s, ['"(|aPage| '|",s,'"|)"]) + +unMkEvalable u == + u is ['QUOTE,a] => a + u is ['LIST,:r] => [unMkEvalable x for x in r] + u + +lisp2HT u == ['"_'",:fn u] where fn u == + IDENTP u => escapeSpecialIds PNAME u + STRINGP u => escapeString u + ATOM u => systemError() + ['"_(",:"append"/[fn x for x in u],'")"] + +args2HtString(x,:options) == + null x => '"" + emList := IFCAR options + SUBSTRING(form2HtString(['f,:x],emList),1,nil) + +quickForm2HtString(x) == + atom x => STRINGIMAGE x + form2HtString x + +form2HtString(x,:options) == + $emList:local := IFCAR options --list of atoms to be emphasized + $brief: local := IFCAR IFCDR options --see dbShowOperationsFromConform (lib11) + fn(x) where + fn x == + atom x => + MEMQ(x,$FormalMapVariableList) => STRCONC('"\",STRINGIMAGE x) + u := escapeSpecialChars STRINGIMAGE x + MEMQ(x,$emList) => STRCONC('"{\em ",u,'"}") + STRINGP x => STRCONC('"_"",u,'"_"") + u + first x = 'QUOTE => STRCONC('"'",sexpr2HtString first rest x) + first x = ":" => STRCONC(fn first rest x,'": ",fn first rest rest x) + first x = 'Mapping => + STRCONC(fnTail(rest rest x,'"()"),'"->",fn first rest x) + first x = 'construct => fnTail(rest x,'"[]") + tail := fnTail(rest x,'"()") + head := fn first x +-- $brief and #head + #tail > 35 => STRCONC(head,'"(...)") + STRCONC(head,tail) + fnTail(x,str) == + null x => '"" + STRCONC(str . 0,fn first x,fnTailTail rest x,str . 1) + fnTailTail x == + null x => '"" + STRCONC('",",fn first x,fnTailTail rest x) + +sexpr2HtString x == + atom x => form2HtString x + STRCONC('"(",fn x,'")") where fn x == + r := rest x + suffix := + null r => '"" + atom r => STRCONC('" . ",form2HtString rest x) + STRCONC('" ",fn r) + STRCONC(sexpr2HtString first x,suffix) + +form2LispString(x) == + atom x => + x = '_$ => '"__$" + MEMQ(x,$FormalMapVariableList) => STRCONC(STRINGIMAGE '__, STRINGIMAGE x) + STRINGP x => STRCONC('"_"",STRINGIMAGE x,'"_"") + STRINGIMAGE x + x is ['QUOTE,a] => STRCONC('"'",sexpr2LispString a) + x is [":",a,b] => STRCONC(form2LispString a,'":",form2LispString b) + first x = 'Mapping => + null rest (r := rest x) => STRCONC('"()->",form2LispString first r) + STRCONC(args2LispString rest r,'"->",form2LispString first r) + STRCONC(form2LispString first x,args2LispString rest x) + +sexpr2LispString x == + atom x => form2LispString x + STRCONC('"(",fn x,'")") where fn x == + r := rest x + suffix := + null r => '"" + atom r => STRCONC('" . ",form2LispString rest x) + STRCONC('" ",fn r) + STRCONC(sexpr2HtString first x,suffix) + +args2LispString x == + null x => '"" + STRCONC('"(",form2LispString first x,fnTailTail rest x,'")") where + fnTailTail x == + null x => '"" + STRCONC('",",form2LispString first x,fnTailTail rest x) + +dbConstructorKind x == + target := CADAR GETDATABASE(x,'CONSTRUCTORMODEMAP) + target = '(Category) => 'category + target is ['CATEGORY,'package,:.] => 'package + HGET($defaultPackageNamesHT,x) => 'default_ package + 'domain + +getConstructorForm name == + name = 'Union => '(Union (_: a A) (_: b B)) + name = 'UntaggedUnion => '(Union A B) + name = 'Record => '(Record (_: a A) (_: b B)) + name = 'Mapping => '(Mapping T S) + name = 'Enumeration => '(Enumeration a b) + GETDATABASE(name,'CONSTRUCTORFORM) + +getConstructorArgs conname == CDR getConstructorForm conname + +htSay(x,:options) == +--if x = $charEscape then x := $charNewline else +--if x = $stringEscape then x := $stringNewline + bcHt x + for y in options repeat bcHt y + +bcComments(comments,:options) == + italics? := not IFCAR options + STRINGP comments => + comments = '"" => nil + htSay('"\newline ") + if italics? then htSay '"{\em " + htSay comments + if italics? then htSay '"}" + null comments => nil + htSay('"\newline ") + if italics? then htSay "{\em " + htSay first comments + for x in rest comments repeat htSay('" ",x) + if italics? then htSay '"}" + +bcConform(form,:options) == + $italics? : local := IFCAR options + $italicHead? : local := IFCAR IFCDR options + bcConform1 form + +bcConform1 form == main where +-----------------> OBSELETE + main == + form is ['ifp,form1,:pred] => + hd form1 + bcPred pred + hd form + hd form == + atom form => + not MEMQ(form,'(Mapping Union Record)) and null constructor? form => + s := STRINGIMAGE form + (s.0 = char '_#) and (n := POSN1(form, $FormalFunctionParameterList)) => + htSay form2HtString ($FormalMapVariableList . n) + htSay form + s := STRINGIMAGE form + $italicHead? => htSayItalics s + $bcMultipleNames => + satTypeDownLink(s, ['"(|conPageChoose| '|",s,'"|)"]) + satTypeDownLink(s, ["(|conPage| '|",s,'"|)"]) + (head := QCAR form) = 'QUOTE => + htSay('"'") + hd CADR form + head = 'SIGNATURE => + htSay(CADR form,'": ") + mapping CADDR form + head = 'Mapping and rest form => rest form => mapping rest form + head = ":" => + hd CADR form + htSay '": " + hd CADDR form + QCDR form and dbEvalableConstructor? form + => bcConstructor(form,head) + hd head + null (r := QCDR form) => nil + tl QCDR form + mapping [target,:source] == + tuple source + bcHt + $saturn => '" {\ttrarrow} " + '" -> " + hd target + tuple u == + null u => bcHt '"()" + null rest u => hd u + bcHt '"(" + hd first u + for x in rest u repeat + bcHt '"," + hd x + bcHt '")" + tl u == + bcHt '"(" + firstTime := true + for x in u repeat + if not firstTime then bcHt '"," + firstTime := false + hd x + bcHt '")" + say x == + if $italics? then bcHt '"{\em " + if x = 'etc then x := '"..." + bcHt escapeSpecialIds STRINGIMAGE x + if $italics? then bcHt '"}" + +bcConstructor(form is [op,:arglist],cname) == --called only when $conformsAreDomains + htSayList dbConformGen form + +htSayList u == + for x in u repeat htSay x + +conform2HtString form == + for u in form2String form repeat + htSay u + +dbEvalableConstructor? form == +--form is constructor form; either +--(a) all arguments are specified or (b) none are specified + form is [op,:argl] => + null argl => true + op = 'QUOTE => 'T --is a domain valued object + and/[dbEvalableConstructor? x for x in argl] + INTEGERP form => true + false + +htSayItalics s == htSay('"{\em ",s,'"}") + +bcCon(name,:options) == + argString := IFCAR options or '"" + s := STRINGIMAGE name + bcStar name + htSayConstructorName(s,s) + htSay argString + +bcAbb(name,abb) == + s := STRINGIMAGE name + a := STRINGIMAGE abb + bcStar name + htSayConstructorName(a,s) + +bcStar name == + if $includeUnexposed? and not isExposedConstructor name then htSayUnexposed() + +bcStarSpace name == + null $includeUnexposed? => nil + not isExposedConstructor name => htSayUnexposed() + htBlank() + +bcStarSpaceOp(op,exposed?) == + null $includeUnexposed? => nil + not exposed? => + htSayUnexposed() + if op.0 = char '_* then htSay '" " + htBlank() + +bcStarConform form == + bcStar opOf form + bcConform form + +dbSourceFile name == + u:= GETDATABASE(name,'SOURCEFILE) + null u => '"" + n := PATHNAME_-NAME u + t := PATHNAME_-TYPE u + STRCONC(n,'".",t) + +asharpConstructorName? name == + u:= GETDATABASE(name,'SOURCEFILE) + u and PATHNAME_-TYPE u = '"as" + +asharpConstructors() == + [x for x in allConstructors() | not asharpConstructorName? x] + +extractFileNameFromPath s == fn(s,0,#s) where + fn(s,i,m) == + k := charPosition(char '_/,s,i) + k = m => SUBSTRING(s,i,nil) + fn(s,k + 1,m) + +bcOpTable(u,fn) == + htBeginTable() + firstTime := true + for op in u for i in 0.. repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + htMakePage [['bcLinks,[escapeSpecialChars STRINGIMAGE opOf op,'"",fn,i]]] + htSay '"}" + htEndTable() + +bcNameConTable u == + $bcMultipleNames: local := (#u ^= 1) + bcConTable REMDUP u + -- bcConTable u + +bcConTable u == + htBeginTable() + firstTime := true + for con in u repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + bcStarSpace opOf con + bcConform con + htSay '"}" + htEndTable() + +bcAbbTable u == + htBeginTable() + firstTime := true + for x in REMDUP u repeat --allow x to be NIL meaning "no abbreviation" + -- for x in u repeat --allow x to be NIL meaning "no abbreviation" + if firstTime then firstTime := false + else htSaySaturn '"&" + if x is [con,abb,:.] then + htSay '"{" + bcAbb(con,abb) + htSay '"}" + htEndTable() + +bcConPredTable(u,conname,:options) == + italicList := IFCAR options + htBeginTable() + firstTime := true + for [conform,:pred] in u repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + bcStarSpace opOf conform + form := + atom conform => getConstructorForm conform + conform + bcConform(form,italicList) + if extractHasArgs pred is [arglist,:pred] then + htSay('" {\em of} ") + bcConform([conname,:arglist],italicList,true) + if pred ^= 'etc then bcPred(pred,italicList) + htSay '"}" + htEndTable() + +bcPred(pred,:options) == + pred = '"" or pred = true or null pred => 'skip + italicList := IFCAR options + if not IFCAR IFCDR options then htSay '" {\em if} " + htPred2English(pred,italicList) + +extractHasArgs pred == + x := find pred or return nil where find x == + x is [op,:argl] => + op = 'hasArgs => x + MEMQ(op,'(AND OR NOT)) => or/[find y for y in argl] + nil + nil + [rest x,:simpBool SUBST('T,x,pred)] + +splitConTable cons == + uncond := cond := nil + for (pair := [con,:pred]) in cons repeat + null pred => 'skip + pred = 'T or pred is ['hasArgs,:.] => uncond := [pair,:uncond] + cond := [pair,:cond] + [NREVERSE uncond,:NREVERSE cond] + +bcNameTable(u,fn,:option) == --option if * prefix + htSay '"\newline" + htBeginTable() + firstTime := true + for x in u repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + if IFCAR option then bcStar x + htMakePage [['bcLinks,[s := escapeSpecialChars STRINGIMAGE x,'"",fn,s]]] + htSay '"}" + htEndTable() + +bcNameCountTable(u,fn,gn,:options) == + linkFunction := + IFCAR options => 'bcLispLinks + 'bcLinks + htSay '"\newline" + htBeginTable() + firstTime := true + for i in 0.. for x in u repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + htSay '"{" + htMakePage [[linkFunction,[FUNCALL(fn,x),'"",gn,i]]] + htSay '"}" + htEndTable() + +dbSayItemsItalics(:u) == + htSay '"{\em " + APPLY(function dbSayItems,u) + htSay '"}" + +dbSayItems(countOrPrefix,singular,plural,:options) == + bcHt '"\newline " + count := + countOrPrefix is [:prefix,c] => + htSay prefix + c + countOrPrefix + if count = 0 then htSay('"No ",singular) + else if count = 1 then htSay('"1 ",singular) + else htSay(count,'" ",plural) + for x in options repeat bcHt x + if count ^= 0 then bcHt '":" + +dbBasicConstructor? conname == member(dbSourceFile conname,'("catdef" "coerce")) + +nothingFoundPage(:options) == + htInitPage('"Sorry, no match found",nil) + htShowPage() + +htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] + +dbInfovec name == + 'category = GETDATABASE(name,'CONSTRUCTORKIND) => nil + GETDATABASE(name, 'ASHARP?) => nil + loadLibIfNotLoaded(name) + u := GETL(name,'infovec) => u + +emptySearchPage(kind,filter,:options) == + skipNamePart := IFCAR options + heading := ['"No ",capitalize kind,'" Found"] + htInitPage(heading,nil) + exposePart := + null $includeUnexposed? => '"{\em exposed} " + '"" + htSay('"\vspace{1}\newline\centerline{There is no ",exposePart,kind,'" matching pattern}\newline\centerline{{\em ") + if filter then htPred2English filter + htSay '"}}" + htShowPage() + +isLoaded? conform == GETL(constructor? opOf conform,'LOADED) + +string2Integer s == + and/[DIGIT_-CHAR_-P (s.i) for i in 0..MAXINDEX s] => PARSE_-INTEGER s + nil + +dbGetInputString htPage == + s := htpLabelInputString(htPage,'filter) + null s or s = '"" => '"*" + s + + + +--======================================================================= +-- Error Pages +--======================================================================= +bcErrorPage u == + u is ['error,:r] => + htInitPage(first r,nil) + bcBlankLine() + for x in rest r repeat htSay x + htShowPage() + systemError '"Unexpected error message" + +errorPage(htPage,[heading,kind,:info]) == + kind = 'invalidType => kInvalidTypePage first info + if heading = 'error then htInitPage('"Error",nil) else + htInitPage(heading,nil) + bcBlankLine() + for x in info repeat htSay x + htShowPage() + +htErrorStar() == + errorPage(nil,['"{\em *} not a valid search string",nil,'"\vspace{3}\centerline{{\em *} is not a valid search string for a general search}\centerline{\em {it would match everything!}}"]) + +htQueryPage(htPage,heading,message,query,fn) == + htInitPage(heading,nil) + htSay message + htQuery(query,fn) + htShowPage() + +htQuery(question,fn,:options) == + upLink? := IFCAR options + if question then + htSay('"\vspace{1}\centerline{") + htSay question + htSay('"}") + htSay('"\centerline{") + htMakePage [['bcLispLinks,['"\fbox{Yes}",'"",fn,'yes]]] + htBlank 4 + if upLink? + then htSay('"\downlink{\fbox{No}}{UpPage}") + else htMakePage [['bcLispLinks,['"\fbox{No}",'"",fn,'no]]] + htSay('"}") + +kInvalidTypePage form == + htInitPage('"Error",nil) + bcBlankLine() + htSay('"\centerline{You gave an invalid type:}\newline\centerline{{\sf ") + htSay(form2HtString form,'"}}") + htShowPage() + +dbNotAvailablePage(:options) == + htInitPage('"Missing Page",nil) + bcBlankLine() + htSay(IFCAR options or '"\centerline{This page is not available yet}") + htShowPage() + +--======================================================================= +-- Utility Functions for Manipulating Browse Datalines +--======================================================================= +dbpHasDefaultCategory? s == #s > 1 and s.1 = char 'x --s is part 3 of line + +dbKind line == line.0 + +dbKindString kind == LASSOC(kind,$dbKindAlist) + +dbName line == escapeString SUBSTRING(line,1,charPosition($tick,line,1) - 1) + +dbAttr line == STRCONC(dbName line,escapeString dbPart(line,4,0)) + +dbPart(line,n,k) == --returns part n of line (n=1,..) beginning in column k + n = 1 => SUBSTRING(line,k + 1,charPosition($tick,line,k + 1) - k - 1) + dbPart(line,n - 1,charPosition($tick,line,k + 1)) + +dbXParts(line,n,m) == + [.,nargs,:r] := dbParts(line,n,m) + [dbKindString line.0,dbName line,PARSE_-INTEGER nargs,:r] + +dbParts(line,n,m) == --split line into n parts beginning in column m + n = 0 => nil + [SUBSTRING(line,m,-m + (k := charPosition($tick,line,m))), + :dbParts(line,n - 1,k + 1)] + +dbConname(line) == dbPart(line,5,1) + +dbComments line == dbReadComments(string2Integer dbPart(line,7,1)) + +dbNewConname(line) == --dbName line unless kind is 'a or 'o => name in 5th pos. + (kind := line.0) = char 'a or kind = char 'o => + conform := dbPart(line,5,1) + k := charPosition(char '_(,conform,1) + SUBSTRING(conform,1,k - 1) + dbName line + +dbTickIndex(line,n,k) == --returns index of nth tick in line starting at k + n = 1 => charPosition($tick,line,k) + dbTickIndex(line,n - 1,1 + charPosition($tick,line,k)) + +mySort u == listSort(function GLESSEQP,u) + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot deleted file mode 100644 index 31fd1336..00000000 --- a/src/interp/buildom.boot +++ /dev/null @@ -1,364 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- This file contains the constructors for the domains that cannot --- be written in ScratchpadII yet. They are not cached because they --- are very cheap to instantiate. --- SMW and SCM July 86 - -import '"sys-macros" -)package "BOOT" - -$noCategoryDomains == '(Domain Mode SubDomain) -$nonLisplibDomains == APPEND($Primitives,$noCategoryDomains) - ---% Record --- Want to eventually have the elts and setelts. --- Record is a macro in BUILDOM LISP. It takes out the colons. - -isRecord type == type is ["Record",:.] - -RecordInner args == - -- this is old and should be removed wherever it occurs - if $evalDomain then - sayBrightly '"-->> Whoops! RecordInner called from this code." - Record0 VEC2LIST args - -Record0 args == - dom := GETREFV 10 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := ["RecordCategory",:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := [CDR a for a in args] - dom.6 := [function RecordEqual, :dom] - dom.7 := [function RecordPrint, :dom] - dom.8 := [function Undef, :dom] - -- following is cache for equality functions - dom.9 := if (n:= LENGTH args) <= 2 - then [NIL,:NIL] - else GETREFV n - dom - -RecordEqual(x,y,dom) == - PAIRP x => - b:= - SPADCALL(CAR x, CAR y, CAR(dom.9) or - CAR RPLACA(dom.9,findEqualFun(dom.5.0))) - NULL rest(dom.5) => b - b and - SPADCALL(CDR x, CDR y, CDR (dom.9) or - CDR RPLACD(dom.9,findEqualFun(dom.5.1))) - VECP x => - equalfuns := dom.9 - and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) - for i in 0.. for fdom in dom.5] - error '"Bug: Silly record representation" - -RecordPrint(x,dom) == coerceRe2E(x,dom.3) - -coerceVal2E(x,m) == - objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) - -findEqualFun(dom) == - compiledLookup("_=",[$Boolean,"$","$"],dom) - -coerceRe2E(x,source) == - n := # CDR source - n = 1 => - ["construct", - ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)] ] - n = 2 => - ["construct", - ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)], _ - ["_=", source.2.1, coerceVal2E(CDR x,source.2.2)] ] - VECP x => - ['construct, - :[["_=",tag,coerceVal2E(x.i, fdom)] - for i in 0.. for [.,tag,fdom] in rest source]] - error '"Bug: ridiculous record representation" - - ---% Union --- Want to eventually have the coerce to and from branch types. - -Union(:args) == - dom := GETREFV 9 - dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval] - else devaluate a) for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function UnionEqual, :dom] - dom.7 := [function UnionPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -UnionEqual(x, y, dom) == - ["Union",:branches] := dom.0 - branches := orderUnionEntries branches - predlist := mkPredList branches - same := false - for b in stripUnionTags branches for p in predlist while not same repeat - typeFun := ["LAMBDA", '(_#1), p] - FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => - STRINGP b => same := (x = y) - if p is ["EQCAR", :.] then (x := rest x; y := rest y) - same := SPADCALL(x, y, findEqualFun(evalDomain b)) - same - -UnionPrint(x, dom) == coerceUn2E(x, dom.0) - -coerceUn2E(x,source) == - ["Union",:branches] := source - branches := orderUnionEntries branches - predlist := mkPredList branches - byGeorge := byJane := GENSYM() - for b in stripUnionTags branches for p in predlist repeat - typeFun := ["LAMBDA", '(_#1), p] - if FUNCALL(typeFun,x) then return - if p is ["EQCAR", :.] then x := rest x --- STRINGP b => return x -- to catch "failed" etc. - STRINGP b => byGeorge := x -- to catch "failed" etc. - byGeorge := coerceVal2E(x,b) - byGeorge = byJane => - error '"Union bug: Cannot find appropriate branch for coerce to E" - byGeorge - ---% Mapping --- Want to eventually have elt: ($, args) -> target - -Mapping(:args) == - dom := GETREFV 9 - dom.0 := ["Mapping", :[devaluate a for a in args]] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14]]]] - dom.2 := NIL - dom.3 := - '(SetCategory) - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function MappingEqual, :dom] - dom.7 := [function MappingPrint, :dom] - dom.8 := [function Undef, :dom] - dom - -MappingEqual(x, y, dom) == EQ(x,y) -MappingPrint(x, dom) == coerceMap2E(x) - -coerceMap2E(x) == - -- nrlib domain - ARRAYP CDR x => ["theMap", BPINAME CAR x, - if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] - -- aldor - ["theMap", BPINAME CAR x ] - ---% Enumeration - -Enumeration(:"args") == - dom := GETREFV 9 - -- JHD added an extra slot to cache EQUAL methods - dom.0 := ["Enumeration", :args] - dom.1 := - [function lookupInTable,dom, - [["_=",[[["Boolean"],"_$","_$"],:12]], - ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] - ]] - dom.2 := NIL - dom.3 := ["EnumerationCategory",:QCDR dom.0] - dom.4 := - [[ '(SetCategory) ],[ '(SetCategory) ]] - dom.5 := args - dom.6 := [function EnumEqual, :dom] - dom.7 := [function EnumPrint, :dom] - dom.8 := [function createEnum, :dom] - dom - -EnumEqual(e1,e2,dom) == e1=e2 -EnumPrint(enum, dom) == dom.5.enum -createEnum(sym, dom) == - args := dom.5 - val := -1 - for v in args for i in 0.. repeat - sym=v => return(val:=i) - val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] - val - ---% INSTANTIATORS - -RecordCategory(:"x") == constructorCategory ["Record",:x] - -EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] - -UnionCategory(:"x") == constructorCategory ["Union",:x] - ---ListCategory(:"x") == constructorCategory ("List",:x) - ---VectorCategory(:"x") == constructorCategory ("Vector",:x) - --above two now defined in SPAD code. - -constructorCategory (title is [op,:.]) == - constructorFunction:= GETL(op,"makeFunctionList") or - systemErrorHere '"constructorCategory" - [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) - oplist:= [[[a,b],true,c] for [a,b,c] in funlist] - cat:= - JoinInner([SetCategory(),mkCategory("domain",oplist,nil,nil,nil)], - $EmptyEnvironment) - cat.(0):= title - cat - ---mkMappingFunList(nam,mapForm,e) == [[],e] -mkMappingFunList(nam,mapForm,e) == - dc := GENSYM() - sigFunAlist:= - [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["coerce",[$Expression,nam],["ELT",dc,7]]] - [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] - -mkRecordFunList(nam,["Record",:Alist],e) == - len:= #Alist - --- for (.,a,.) in Alist do --- if getmode(a,e) then MOAN("Symbol: ",a, --- " must not be both a variable and literal") --- e:= put(a,"isLiteral","true",e) - dc := GENSYM() - sigFunAlist:= - --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len))) - -- for i in 0..,(.,a,A) in Alist), - - [["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"], - ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["coerce",[$Expression,nam],["ELT",dc,7]],: - [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] - for i in 0.. for [.,a,A] in Alist],: - [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], - ["SETRECORDELT","$1",i, len,"$3"]]] - for i in 0.. for [.,a,A] in Alist],: - [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", - "$1",len]]]]] - [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] - -mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == - dc := name - if name = "Rep" then name := "$" - --2. create coercions from subtypes to subUnion - cList:= - [["_=",[["Boolean"],name ,name],["ELT",dc,6]], - ["coerce",[$Expression,name],["ELT",dc,7]],: - ("append"/ - [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], - ["elt",[type,name,tag],cdownFun], - ["case",['(Boolean),name,tag], - ["XLAM",["#1"],["QEQCAR","#1",i]]]] - for [.,tag,type] in listOfEntries for i in 0..])] where - cdownFun() == - gg:=GENSYM() - $InteractiveMode => - ["XLAM",["#1"],["PROG1",["QCDR","#1"], - ["check_-union",["QEQCAR","#1",i],type,"#1"]]] - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], - ["check_-union",["QEQCAR",gg,i],type,gg]]] - [cList,e] - -mkEnumerationFunList(nam,["Enumeration",:SL],e) == - len:= #SL - dc := nam - cList := - [nil, - ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], - ["_^_=",[["Boolean"],nam ,nam],["ELT",dc,7]], - ["coerce",[nam, ["Symbol"]], ["ELT", dc, 8]], - ["coerce",[["OutputForm"],nam],["ELT",dc, 9]]] - [substitute(nam, dc, cList),e] - -mkUnionFunList(op,form is ["Union",:listOfEntries],e) == - first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) - -- following call to order is a bug, but needs massive recomp to fix - listOfEntries:= orderUnionEntries listOfEntries - --1. create representations of subtypes - predList:= mkPredList listOfEntries - g:=GENSYM() - --2. create coercions from subtypes to subUnion - cList:= - [["_=",[["Boolean"],g ,g],["ELT",op,6]], - ["coerce",[$Expression,g],["ELT",op,7]],: - ("append"/ - [[["autoCoerce",[g,t],upFun], - ["coerce",[t,g],cdownFun], - ["autoCoerce",[t,g],downFun], --this should be removed eventually - ["case",['(Boolean),g,t],typeFun]] - for p in predList for t in listOfEntries])] where - upFun() == - p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] - ["XLAM",["#1"],"#1"] - cdownFun() == - gg:=GENSYM() - if p is ["EQCAR",x,n] then - ref:=["QCDR",gg] - q:= ["QEQCAR", gg, n] - else - ref:=gg - q:= substitute(gg,"#1",p) - ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, - ["check_-union",q,t,gg]]] - downFun() == - p is ["EQCAR",x,.] => - ["XLAM",["#1"],["QCDR","#1"]] - ["XLAM",["#1"],"#1"] - typeFun() == - p is ["EQCAR",x,n] => - ["XLAM",["#1"],["QEQCAR",x,n]] - ["XLAM",["#1"],p] - op:= - op="Rep" => "$" - op - cList:= substitute(op,g,cList) - [cList,e] - diff --git a/src/interp/buildom.boot.pamphlet b/src/interp/buildom.boot.pamphlet new file mode 100644 index 00000000..cbbc7a43 --- /dev/null +++ b/src/interp/buildom.boot.pamphlet @@ -0,0 +1,386 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp buildom.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- This file contains the constructors for the domains that cannot +-- be written in ScratchpadII yet. They are not cached because they +-- are very cheap to instantiate. +-- SMW and SCM July 86 + +import '"sys-macros" +)package "BOOT" + +$noCategoryDomains == '(Domain Mode SubDomain) +$nonLisplibDomains == APPEND($Primitives,$noCategoryDomains) + +--% Record +-- Want to eventually have the elts and setelts. +-- Record is a macro in BUILDOM LISP. It takes out the colons. + +isRecord type == type is ["Record",:.] + +RecordInner args == + -- this is old and should be removed wherever it occurs + if $evalDomain then + sayBrightly '"-->> Whoops! RecordInner called from this code." + Record0 VEC2LIST args + +Record0 args == + dom := GETREFV 10 + -- JHD added an extra slot to cache EQUAL methods + dom.0 := ["Record", :[["_:", CAR a, devaluate CDR a] for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := ["RecordCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := [CDR a for a in args] + dom.6 := [function RecordEqual, :dom] + dom.7 := [function RecordPrint, :dom] + dom.8 := [function Undef, :dom] + -- following is cache for equality functions + dom.9 := if (n:= LENGTH args) <= 2 + then [NIL,:NIL] + else GETREFV n + dom + +RecordEqual(x,y,dom) == + PAIRP x => + b:= + SPADCALL(CAR x, CAR y, CAR(dom.9) or + CAR RPLACA(dom.9,findEqualFun(dom.5.0))) + NULL rest(dom.5) => b + b and + SPADCALL(CDR x, CDR y, CDR (dom.9) or + CDR RPLACD(dom.9,findEqualFun(dom.5.1))) + VECP x => + equalfuns := dom.9 + and/[SPADCALL(x.i,y.i,equalfuns.i or (equalfuns.i:=findEqualFun(fdom))) + for i in 0.. for fdom in dom.5] + error '"Bug: Silly record representation" + +RecordPrint(x,dom) == coerceRe2E(x,dom.3) + +coerceVal2E(x,m) == + objValUnwrap coerceByFunction(objNewWrap(x,m),$Expression) + +findEqualFun(dom) == + compiledLookup("_=",[$Boolean,"$","$"],dom) + +coerceRe2E(x,source) == + n := # CDR source + n = 1 => + ["construct", + ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)] ] + n = 2 => + ["construct", + ["_=", source.1.1, coerceVal2E(CAR x,source.1.2)], _ + ["_=", source.2.1, coerceVal2E(CDR x,source.2.2)] ] + VECP x => + ['construct, + :[["_=",tag,coerceVal2E(x.i, fdom)] + for i in 0.. for [.,tag,fdom] in rest source]] + error '"Bug: ridiculous record representation" + + +--% Union +-- Want to eventually have the coerce to and from branch types. + +Union(:args) == + dom := GETREFV 9 + dom.0 := ["Union", :[(if a is ["_:",tag,domval] then ["_:",tag,devaluate domval] + else devaluate a) for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function UnionEqual, :dom] + dom.7 := [function UnionPrint, :dom] + dom.8 := [function Undef, :dom] + dom + +UnionEqual(x, y, dom) == + ["Union",:branches] := dom.0 + branches := orderUnionEntries branches + predlist := mkPredList branches + same := false + for b in stripUnionTags branches for p in predlist while not same repeat + typeFun := ["LAMBDA", '(_#1), p] + FUNCALL(typeFun,x) and FUNCALL(typeFun,y) => + STRINGP b => same := (x = y) + if p is ["EQCAR", :.] then (x := rest x; y := rest y) + same := SPADCALL(x, y, findEqualFun(evalDomain b)) + same + +UnionPrint(x, dom) == coerceUn2E(x, dom.0) + +coerceUn2E(x,source) == + ["Union",:branches] := source + branches := orderUnionEntries branches + predlist := mkPredList branches + byGeorge := byJane := GENSYM() + for b in stripUnionTags branches for p in predlist repeat + typeFun := ["LAMBDA", '(_#1), p] + if FUNCALL(typeFun,x) then return + if p is ["EQCAR", :.] then x := rest x +-- STRINGP b => return x -- to catch "failed" etc. + STRINGP b => byGeorge := x -- to catch "failed" etc. + byGeorge := coerceVal2E(x,b) + byGeorge = byJane => + error '"Union bug: Cannot find appropriate branch for coerce to E" + byGeorge + +--% Mapping +-- Want to eventually have elt: ($, args) -> target + +Mapping(:args) == + dom := GETREFV 9 + dom.0 := ["Mapping", :[devaluate a for a in args]] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14]]]] + dom.2 := NIL + dom.3 := + '(SetCategory) + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function MappingEqual, :dom] + dom.7 := [function MappingPrint, :dom] + dom.8 := [function Undef, :dom] + dom + +MappingEqual(x, y, dom) == EQ(x,y) +MappingPrint(x, dom) == coerceMap2E(x) + +coerceMap2E(x) == + -- nrlib domain + ARRAYP CDR x => ["theMap", BPINAME CAR x, + if $testingSystem then 0 else REMAINDER(HASHEQ CDR x, 1000)] + -- aldor + ["theMap", BPINAME CAR x ] + +--% Enumeration + +Enumeration(:"args") == + dom := GETREFV 9 + -- JHD added an extra slot to cache EQUAL methods + dom.0 := ["Enumeration", :args] + dom.1 := + [function lookupInTable,dom, + [["_=",[[["Boolean"],"_$","_$"],:12]], + ["coerce",[[$Expression,"_$"],:14], [["_$", $Symbol], :16]] + ]] + dom.2 := NIL + dom.3 := ["EnumerationCategory",:QCDR dom.0] + dom.4 := + [[ '(SetCategory) ],[ '(SetCategory) ]] + dom.5 := args + dom.6 := [function EnumEqual, :dom] + dom.7 := [function EnumPrint, :dom] + dom.8 := [function createEnum, :dom] + dom + +EnumEqual(e1,e2,dom) == e1=e2 +EnumPrint(enum, dom) == dom.5.enum +createEnum(sym, dom) == + args := dom.5 + val := -1 + for v in args for i in 0.. repeat + sym=v => return(val:=i) + val<0 => error ["Cannot coerce",sym,"to",["Enumeration",:args]] + val + +--% INSTANTIATORS + +RecordCategory(:"x") == constructorCategory ["Record",:x] + +EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] + +UnionCategory(:"x") == constructorCategory ["Union",:x] + +--ListCategory(:"x") == constructorCategory ("List",:x) + +--VectorCategory(:"x") == constructorCategory ("Vector",:x) + --above two now defined in SPAD code. + +constructorCategory (title is [op,:.]) == + constructorFunction:= GETL(op,"makeFunctionList") or + systemErrorHere '"constructorCategory" + [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) + oplist:= [[[a,b],true,c] for [a,b,c] in funlist] + cat:= + JoinInner([SetCategory(),mkCategory("domain",oplist,nil,nil,nil)], + $EmptyEnvironment) + cat.(0):= title + cat + +--mkMappingFunList(nam,mapForm,e) == [[],e] +mkMappingFunList(nam,mapForm,e) == + dc := GENSYM() + sigFunAlist:= + [["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["coerce",[$Expression,nam],["ELT",dc,7]]] + [substitute(nam,dc,substitute("$",'Rep,sigFunAlist)),e] + +mkRecordFunList(nam,["Record",:Alist],e) == + len:= #Alist + +-- for (.,a,.) in Alist do +-- if getmode(a,e) then MOAN("Symbol: ",a, +-- " must not be both a variable and literal") +-- e:= put(a,"isLiteral","true",e) + dc := GENSYM() + sigFunAlist:= + --:((a,(A,nam),("XLAM",("$1","$2"),("RECORDELT","$1",i,len))) + -- for i in 0..,(.,a,A) in Alist), + + [["construct",[nam,:[A for [.,a,A] in Alist]],"mkRecord"], + ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["coerce",[$Expression,nam],["ELT",dc,7]],: + [["elt",[A,nam,PNAME a],["XLAM",["$1","$2"],["RECORDELT","$1",i,len]]] + for i in 0.. for [.,a,A] in Alist],: + [["setelt",[A,nam,PNAME a,A],["XLAM",["$1","$2","$3"], + ["SETRECORDELT","$1",i, len,"$3"]]] + for i in 0.. for [.,a,A] in Alist],: + [["copy",[nam,nam],["XLAM",["$1"],["RECORDCOPY", + "$1",len]]]]] + [substitute(nam,dc,substitute("$","Rep",sigFunAlist)),e] + +mkNewUnionFunList(name,form is ["Union",:listOfEntries],e) == + dc := name + if name = "Rep" then name := "$" + --2. create coercions from subtypes to subUnion + cList:= + [["_=",[["Boolean"],name ,name],["ELT",dc,6]], + ["coerce",[$Expression,name],["ELT",dc,7]],: + ("append"/ + [[["construct",[name,type],["XLAM",["#1"],["CONS",i,"#1"]]], + ["elt",[type,name,tag],cdownFun], + ["case",['(Boolean),name,tag], + ["XLAM",["#1"],["QEQCAR","#1",i]]]] + for [.,tag,type] in listOfEntries for i in 0..])] where + cdownFun() == + gg:=GENSYM() + $InteractiveMode => + ["XLAM",["#1"],["PROG1",["QCDR","#1"], + ["check_-union",["QEQCAR","#1",i],type,"#1"]]] + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],["QCDR",gg], + ["check_-union",["QEQCAR",gg,i],type,gg]]] + [cList,e] + +mkEnumerationFunList(nam,["Enumeration",:SL],e) == + len:= #SL + dc := nam + cList := + [nil, + ["_=",[["Boolean"],nam ,nam],["ELT",dc,6]], + ["_^_=",[["Boolean"],nam ,nam],["ELT",dc,7]], + ["coerce",[nam, ["Symbol"]], ["ELT", dc, 8]], + ["coerce",[["OutputForm"],nam],["ELT",dc, 9]]] + [substitute(nam, dc, cList),e] + +mkUnionFunList(op,form is ["Union",:listOfEntries],e) == + first listOfEntries is [":",.,.] => mkNewUnionFunList(op,form,e) + -- following call to order is a bug, but needs massive recomp to fix + listOfEntries:= orderUnionEntries listOfEntries + --1. create representations of subtypes + predList:= mkPredList listOfEntries + g:=GENSYM() + --2. create coercions from subtypes to subUnion + cList:= + [["_=",[["Boolean"],g ,g],["ELT",op,6]], + ["coerce",[$Expression,g],["ELT",op,7]],: + ("append"/ + [[["autoCoerce",[g,t],upFun], + ["coerce",[t,g],cdownFun], + ["autoCoerce",[t,g],downFun], --this should be removed eventually + ["case",['(Boolean),g,t],typeFun]] + for p in predList for t in listOfEntries])] where + upFun() == + p is ["EQCAR",x,n] => ["XLAM",["#1"],["CONS",n,"#1"]] + ["XLAM",["#1"],"#1"] + cdownFun() == + gg:=GENSYM() + if p is ["EQCAR",x,n] then + ref:=["QCDR",gg] + q:= ["QEQCAR", gg, n] + else + ref:=gg + q:= substitute(gg,"#1",p) + ["XLAM",["#1"],["PROG2",["LET",gg,"#1"],ref, + ["check_-union",q,t,gg]]] + downFun() == + p is ["EQCAR",x,.] => + ["XLAM",["#1"],["QCDR","#1"]] + ["XLAM",["#1"],"#1"] + typeFun() == + p is ["EQCAR",x,n] => + ["XLAM",["#1"],["QEQCAR",x,n]] + ["XLAM",["#1"],p] + op:= + op="Rep" => "$" + op + cList:= substitute(op,g,cList) + [cList,e] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot deleted file mode 100644 index ffbb4617..00000000 --- a/src/interp/c-doc.boot +++ /dev/null @@ -1,1272 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -batchExecute() == - _/RF_-1 '(GENCON INPUT) - -getDoc(conName,op,modemap) == - [dc,target,sl,pred,D] := simplifyModemap modemap - sig := [target,:sl] - null atom dc => - sig := SUBST('$,dc,sig) - sig := SUBLISLIS($FormalMapVariableList,rest dc,sig) - getDocForDomain(conName,op,sig) - if argList := IFCDR getOfCategoryArgument pred then - SUBLISLIS($FormalMapArgumentList,argList,sig) - sig := SUBST('$,dc,sig) - getDocForCategory(conName,op,sig) - -getOfCategoryArgument pred == - pred is [fn,:.] and MEMQ(fn,'(AND OR NOT)) => - or/[getOfCategoryArgument x for x in rest pred] - pred is ['ofCategory,'_*1,form] => form - nil - -getDocForCategory(name,op,sig) == - getOpDoc(constructor? name,op,sig) or - or/[getOpDoc(constructor? x,op,sig) for x in whatCatCategories name] - -getDocForDomain(name,op,sig) == - getOpDoc(constructor? name,op,sig) or - or/[getOpDoc(constructor? x,op,sig) for x in whatCatExtDom name] - -getOpDoc(abb,op,:sigPart) == - u := LASSOC(op,GETDATABASE(abb,'DOCUMENTATION)) - $argList : local := $FormalMapVariableList - _$: local := '_$ - sigPart is [sig] => or/[d for [s,:d] in u | sig = s] - u - -readForDoc fn == - $bootStrapMode: local:= true - _/RQ_-LIB_-1 [fn,'SPAD] - -recordSignatureDocumentation(opSig,lineno) == - recordDocumentation(rest postTransform opSig,lineno) - -recordAttributeDocumentation(['Attribute,att],lineno) == - name := opOf att - UPPER_-CASE_-P (PNAME name).0 => nil - recordDocumentation([name,['attribute,:IFCDR postTransform att]],lineno) - -recordDocumentation(key,lineno) == - recordHeaderDocumentation lineno - u:= collectComBlock lineno - --record NIL to mean "there was no documentation" - $maxSignatureLineNumber := lineno - $docList := [[key,:u],:$docList] - -- leave CAR of $docList alone as required by collectAndDeleteAssoc - -recordHeaderDocumentation lineno == - if $maxSignatureLineNumber = 0 then - al := [p for (p := [n,:u]) in $COMBLOCKLIST - | NULL n or NULL lineno or n < lineno] - $COMBLOCKLIST := SETDIFFERENCE($COMBLOCKLIST,al) - $headerDocumentation := ASSOCRIGHT al - if $headerDocumentation then $maxSignatureLineNumber := 1 --see postDef - $headerDocumentation - -collectComBlock x == - $COMBLOCKLIST is [[=x,:val],:.] => - u := [:val,:collectAndDeleteAssoc x] - $COMBLOCKLIST := rest $COMBLOCKLIST - u - collectAndDeleteAssoc x - -collectAndDeleteAssoc x == ---u is (.. (x . a) .. (x . b) .. ) ==> (a b ..) deleting entries from u ---assumes that the first element is useless - for y in tails $COMBLOCKLIST | (s := rest y) repeat - while s and first s is [=x,:r] repeat - res := [:res,:r] - s := rest s - RPLACD(y,s) - res - -finalizeDocumentation() == - unusedCommentLineNumbers := [x for (x := [n,:r]) in $COMBLOCKLIST | r] - docList := SUBST("$","%",transDocList($op,$docList)) - if u := [sig for [sig,:doc] in docList | null doc] then - for y in u repeat - y = 'constructor => noHeading := true - y is [x,b] and b is [='attribute,:r] => - attributes := [[x,:r],:attributes] - signatures := [y,:signatures] - name := CAR $lisplibForm - if noHeading or signatures or attributes or unusedCommentLineNumbers then - sayKeyedMsg("S2CD0001",NIL) - bigcnt := 1 - if noHeading or signatures or attributes then - sayKeyedMsg("S2CD0002",[STRCONC(STRINGIMAGE bigcnt,'"."),name]) - bigcnt := bigcnt + 1 - litcnt := 1 - if noHeading then - sayKeyedMsg("S2CD0003", - [STRCONC('"(",STRINGIMAGE litcnt,'")"),name]) - litcnt := litcnt + 1 - if signatures then - sayKeyedMsg("S2CD0004", - [STRCONC('"(",STRINGIMAGE litcnt,'")")]) - litcnt := litcnt + 1 - for [op,sig] in signatures repeat - s := formatOpSignature(op,sig) - sayMSG - atom s => ['%x9,s] - ['%x9,:s] - if attributes then - sayKeyedMsg("S2CD0005", - [STRCONC('"(",STRINGIMAGE litcnt,'")")]) - litcnt := litcnt + 1 - for x in attributes repeat - a := form2String x - sayMSG - atom a => ['%x9,a] - ['%x9,:a] - if unusedCommentLineNumbers then - sayKeyedMsg("S2CD0006",[STRCONC(STRINGIMAGE bigcnt,'"."),name]) - for [n,r] in unusedCommentLineNumbers repeat - sayMSG ['" ",:bright n,'" ",r] - hn [[:fn(sig,$e),:doc] for [sig,:doc] in docList] where - fn(x,e) == - atom x => [x,nil] - if #x > 2 then x := TAKE(2,x) - SUBLISLIS($FormalMapVariableList,rest $lisplibForm, - macroExpand(x,e)) - hn u == - -- ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...) - opList := REMDUP ASSOCLEFT u - [[op,:[[sig,doc] for [op1,sig,doc] in u | op = op1]] for op in opList] - ---======================================================================= --- Transformation of ++ comments ---======================================================================= -transDocList($constructorName,doclist) == --returns ((key line)...) ---called ONLY by finalizeDocumentation ---if $exposeFlag then messages go to file $outStream; flag=nil by default - sayBrightly ['" Processing ",$constructorName,'" for Browser database:"] - commentList := transDoc($constructorName,doclist) - acc := nil - for entry in commentList repeat - entry is ['constructor,x] => - conEntry => checkDocError ['"Spurious comments: ",x] - conEntry := entry - acc := [entry,:acc] - conEntry => [conEntry,:acc] - checkDocError1 ['"Missing Description"] - acc - -transDoc(conname,doclist) == ---$exposeFlag and not isExposedConstructor conname => nil ---skip over unexposed constructors when checking system files - $x: local - rlist := REVERSE doclist - for [$x,:lines] in rlist repeat - $attribute? : local := $x is [.,[key]] and key = 'attribute - null lines => - $attribute? => nil - checkDocError1 ['"Not documented!!!!"] - u := checkTrim($x,(STRINGP lines => [lines]; $x = 'constructor => first lines; lines)) - $argl : local := nil --set by checkGetArgs --- tpd: related domain information doesn't exist --- if v := checkExtract('"Related Domains:",u) then --- $lisplibRelatedDomains:=[w for x in gn(v) | w := fn(x)] where --- gn(v) == --note: unabbrev checks for correct number of arguments --- s := checkExtractItemList v --- parse := ncParseFromString s --is a single conform or a tuple --- null parse => nil --- parse is ['Tuple,:r] => r --- [parse] --- fn(x) == --- expectedNumOfArgs := checkNumOfArgs x --- null expectedNumOfArgs => --- checkDocError ['"Unknown constructor name?: ",opOf x] --- x --- expectedNumOfArgs ^= (n := #(IFCDR x)) => --- n = 0 => checkDocError1 --- ['"You must give arguments to the _"Related Domain_": ",x] --- checkDocError --- ['"_"Related Domain_" has wrong number of arguments: ",x] --- nil --- n=0 and atom x => [x] --- x - longline := - $x = 'constructor => - v :=checkExtract('"Description:",u) or u and - checkExtract('"Description:", - [STRCONC('"Description: ",first u),:rest u]) - transformAndRecheckComments('constructor,v or u) - transformAndRecheckComments($x,u) - acc := [[$x,longline],:acc] --processor assumes a list of lines - NREVERSE acc - -checkExtractItemList l == --items are separated by commas or end of line - acc := nil --l is list of remaining lines - while l repeat --stop when you get to a line with a colon - m := MAXINDEX first l - k := charPosition(char '_:,first l,0) - k <= m => return nil - acc := [first l,:acc] - l := rest l - "STRCONC"/[x for x in NREVERSE acc] - ---NREVERSE("append"/[fn string for string in acc]) where --- fn(string) == --- m := MAXINDEX string --- acc := nil --- i := 0 --- while i < m and (k := charPosition(char '_,,string,i)) < m repeat --- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc] --- i := k + 1 --- if i < m then --- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc] --- acc - -transformAndRecheckComments(name,lines) == - $checkingXmptex? := false - $x : local := name - $name : local := 'GlossaryPage - $origin : local := 'gloss - $recheckingFlag : local := false - $exposeFlagHeading : local := ['"--------",name,'"---------"] - if null $exposeFlag then sayBrightly $exposeFlagHeading - u := checkComments(name,lines) - $recheckingFlag := true - checkRewrite(name,[u]) - $recheckingFlag := false - u - -checkRewrite(name,lines) == main where --similar to checkComments from c-doc - main == - $checkErrorFlag: local := true - margin := 0 - lines := checkRemoveComments lines - u := lines - if $checkingXmptex? then - u := [checkAddIndented(x,margin) for x in u] - $argl := checkGetArgs first u --set $argl - u2 := nil - verbatim := nil - for x in u repeat - w := newString2Words x - verbatim => - w and first w = '"\end{verbatim}" => - verbatim := false - u2 := append(u2, w) - u2 := append(u2, [x]) - w and first w = '"\begin{verbatim}" => - verbatim := true - u2 := append(u2, w) - u2 := append(u2, w) - u := u2 - u := checkAddSpaces u - u := checkSplit2Words u - u := checkAddMacros u - u := checkTexht u --- checkBalance u - okBefore := null $checkErrorFlag - checkArguments u - if $checkErrorFlag then u := checkFixCommonProblem u - checkRecordHash u --- u := checkTranVerbatim u - checkDecorateForHt u - -checkTexht u == - count := 0 - acc := nil - while u repeat - x := first u - if x = '"\texht" and (u := IFCDR u) then - if not (IFCAR u = $charLbrace) then - checkDocError '"First left brace after \texht missing" - count := 1 -- drop first argument including braces of \texht - while ((y := IFCAR (u := rest u))^= $charRbrace or count > 1) repeat - if y = $charLbrace then count := count + 1 - if y = $charRbrace then count := count - 1 - x := IFCAR (u := rest u) -- drop first right brace of 1st arg - if x = '"\httex" and (u := IFCDR u) and (IFCAR u = $charLbrace) then - acc := [IFCAR u,:acc] --left brace: add it - while (y := IFCAR (u := rest u)) ^= $charRbrace repeat (acc := [y,:acc]) - acc := [IFCAR u,:acc] --right brace: add it - x := IFCAR (u := rest u) --left brace: forget it - while IFCAR (u := rest u) ^= $charRbrace repeat 'skip - x := IFCAR (u := rest u) --forget right brace: move to next char - acc := [x,:acc] - u := rest u - NREVERSE acc - -checkRecordHash u == - while u repeat - x := first u - if STRINGP x and x.0 = $charBack then - if member(x,$HTlinks) and (u := checkLookForLeftBrace IFCDR u) - and (u := checkLookForRightBrace IFCDR u) - and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then - htname := intern IFCAR u - entry := HGET($htHash,htname) or [nil] - HPUT($htHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) - else if member(x,$HTlisplinks) and (u := checkLookForLeftBrace IFCDR u) - and (u := checkLookForRightBrace IFCDR u) - and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then - htname := intern checkGetLispFunctionName checkGetStringBeforeRightBrace u - entry := HGET($lispHash,htname) or [nil] - HPUT($lispHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) - else if ((p := member(x,'("\gloss" "\spadglos"))) - or (q := member(x,'("\glossSee" "\spadglosSee")))) - and (u := checkLookForLeftBrace IFCDR u) - and (u := IFCDR u) then - if q then - u := checkLookForRightBrace u - u := checkLookForLeftBrace IFCDR u - u := IFCDR u - htname := intern checkGetStringBeforeRightBrace u - entry := HGET($glossHash,htname) or [nil] - HPUT($glossHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) - else if x = '"\spadsys" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then - s := checkGetStringBeforeRightBrace u - if s.0 = char '_) then s := SUBSTRING(s,1,nil) - parse := checkGetParse s - null parse => checkDocError ['"Unparseable \spadtype: ",s] - not member(opOf parse,$currentSysList) => - checkDocError ['"Bad system command: ",s] - atom parse or not (parse is ['set,arg]) => 'ok ---assume ok - not spadSysChoose($setOptions,arg) => - checkDocError ['"Incorrect \spadsys: ",s] - entry := HGET($sysHash,htname) or [nil] - HPUT($sysHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) - else if x = '"\spadtype" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then - s := checkGetStringBeforeRightBrace u - parse := checkGetParse s - null parse => checkDocError ['"Unparseable \spadtype: ",s] - n := checkNumOfArgs parse - null n => checkDocError ['"Unknown \spadtype: ", s] - atom parse and n > 0 => 'skip - null (key := checkIsValidType parse) => - checkDocError ['"Unknown \spadtype: ", s] - atom key => 'ok - checkDocError ['"Wrong number of arguments: ",form2HtString key] - else if member(x,'("\spadop" "\keyword")) and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then - x := intern checkGetStringBeforeRightBrace u - not (GET(x,'Led) or GET(x,'Nud)) => - checkDocError ['"Unknown \spadop: ",x] - u := rest u - 'done - -checkGetParse s == ncParseFromString removeBackslashes s - -removeBackslashes s == - s = '"" => '"" - (k := charPosition($charBack,s,0)) < #s => - k = 0 => removeBackslashes SUBSTRING(s,1,nil) - STRCONC(SUBSTRING(s,0,k),removeBackslashes SUBSTRING(s,k + 1,nil)) - s - -checkNumOfArgs conform == - conname := opOf conform - constructor? conname or (conname := abbreviation? conname) => - #GETDATABASE(conname,'CONSTRUCTORARGS) - nil --signals error - -checkIsValidType form == main where ---returns ok if correct, form is wrong number of arguments, nil if unknown - main == - atom form => 'ok - [op,:args] := form - conname := (constructor? op => op; abbreviation? op) - null conname => nil - fn(form,GETDATABASE(conname,'COSIG)) - fn(form,coSig) == - #form ^= #coSig => form - or/[null checkIsValidType x for x in rest form for flag in rest coSig | flag] - => nil - 'ok - -checkGetLispFunctionName s == - n := #s - (k := charPosition(char '_|,s,1)) and k < n and - (j := charPosition(char '_|,s,k + 1)) and j < n => SUBSTRING(s,k + 1,j-k-1) - checkDocError ['"Ill-formed lisp expression : ",s] - 'illformed - -checkGetStringBeforeRightBrace u == - acc := nil - while u repeat - x := first u - x = $charRbrace => return "STRCONC"/(NREVERSE acc) - acc := [x,:acc] - u := rest u - --- checkTranVerbatim u == --- acc := nil --- while u repeat --- x := first u --- x = '"\begin" and checkTranVerbatimMiddle u is [middle,:r] => --- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc] --- u := r --- if x = '"\spadcommand" then x := '"\spadpaste" --- acc := [x,:acc] --- u := rest u --- NREVERSE acc --- --- checkTranVerbatimMiddle u == --- (y := IFCAR (v := IFCDR u)) = $charLbrace and --- (y := IFCAR (v := IFCDR v)) = '"verbatim" and --- (y := IFCAR (v := IFCDR v)) = $charRbrace => --- w := IFCDR v --- middle := nil --- while w and (z := first w) ^= '"\end" repeat --- middle := [z,:middle] --- w := rest w --- if (y := IFCAR (w := IFCDR w)) = $charLbrace and --- (y := IFCAR (w := IFCDR w)) = '"verbatim" and --- (y := IFCAR (w := IFCDR w)) = $charRbrace then --- u := IFCDR w --- else --- checkDocError '"Missing \end{verbatim}" --- u := w --- [middle,:u] --- --- checkTranVerbatim1 u == --- acc := nil --- while u repeat --- x := first u --- x = '"\begin" and (y := IFCAR (v := IFCDR u)) = $charLbrace and --- (y := IFCAR (v := IFCDR v)) = '"verbatim" and --- (y := IFCAR (v := IFCDR v)) = $charRbrace => --- w := IFCDR v --- middle := nil --- while w and (z := first w) ^= '"\end" repeat --- middle := [z,:middle] --- w := rest w --- if (y := IFCAR (w := IFCDR w)) = $charLbrace and --- (y := IFCAR (w := IFCDR w)) = '"verbatim" and --- (y := IFCAR (w := IFCDR w)) = $charRbrace then --- u := IFCDR w --- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc] --- if x = '"\spadcommand" then x := '"\spadpaste" --- acc := [x,:acc] --- u := rest u --- NREVERSE acc - -appendOver [head,:tail] == - acc := LASTNODE head - for x in tail repeat - end := LASTNODE x - RPLACD(acc,x) - acc := end - head - -checkRemoveComments lines == - while lines repeat - do - line := checkTrimCommented first lines - if firstNonBlankPosition line >= 0 then acc := [line,:acc] - lines := rest lines - NREVERSE acc - -checkTrimCommented line == - n := #line - k := htcharPosition(char '_%,line,0) - --line beginning with % is a comment - k = 0 => '"" - --remarks beginning with %% are comments - k >= n - 1 or line.(k + 1) ^= char '_% => line - k < #line => SUBSTRING(line,0,k) - line - -htcharPosition(char,line,i) == - m := #line - k := charPosition(char,line,i) - k = m => k - k > 0 => - line.(k - 1) ^= $charBack => k - htcharPosition(char,line,k + 1) - 0 - -checkAddMacros u == - acc := nil - verbatim := false - while u repeat - x := first u - acc := - x = '"\end{verbatim}" => - verbatim := false - [x, :acc] - verbatim => [x, :acc] - x = '"\begin{verbatim}" => - verbatim := true - [x, :acc] - y := LASSOC(x,$HTmacs) => [:y,:acc] - [x,:acc] - u := rest u - NREVERSE acc - -checkComments(nameSig,lines) == main where - main == - $checkErrorFlag: local := false - margin := checkGetMargin lines - if (null BOUNDP '$attribute? or null $attribute?) - and nameSig ^= 'constructor then lines := - [checkTransformFirsts(first nameSig,first lines,margin),:rest lines] - u := checkIndentedLines(lines, margin) - $argl := checkGetArgs first u --set $argl - u2 := nil - verbatim := nil - for x in u repeat - w := newString2Words x - verbatim => - w and first w = '"\end{verbatim}" => - verbatim := false - u2 := append(u2, w) - u2 := append(u2, [x]) - w and first w = '"\begin{verbatim}" => - verbatim := true - u2 := append(u2, w) - u2 := append(u2, w) - u := u2 - u := checkAddSpaces u - u := checkIeEg u - u := checkSplit2Words u - checkBalance u - okBefore := null $checkErrorFlag - checkArguments u - if $checkErrorFlag then u := checkFixCommonProblem u - v := checkDecorate u - res := "STRCONC"/[y for y in v] - res := checkAddPeriod res - if $checkErrorFlag then pp res - res - -checkIndentedLines(u, margin) == - verbatim := false - u2 := nil - for x in u repeat - k := firstNonBlankPosition x - k = -1 => - verbatim => u2 := [:u2, $charFauxNewline] - u2 := [:u2, '"\blankline "] - s := SUBSTRING(x, k, nil) - s = '"\begin{verbatim}" => - verbatim := true - u2 := [:u2, s] - s = '"\end{verbatim}" => - verbatim := false - u2 := [:u2, s] - verbatim => u2 := [:u2, SUBSTRING(x, margin, nil)] - margin = k => u2 := [:u2, s] - u2 := [:u2, STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(s,0),'"}")] - u2 - -newString2Words l == - not STRINGP l => [l] - m := MAXINDEX l - m = -1 => NIL - i := 0 - [w while newWordFrom(l,i,m) is [w,i]] - -newWordFrom(l,i,m) == - while i <= m and l.i = " " repeat i := i + 1 - i > m => NIL - buf := '"" - ch := l.i - ch = $charFauxNewline => [$stringFauxNewline, i+ 1] - done := false - while i <= m and not done repeat - ch := l.i - ch = $charBlank or ch = $charFauxNewline => done := true - buf := STRCONC(buf,ch) - i := i + 1 - [buf,i] - -checkAddPeriod s == --No, just leave blank at the end (rdj: 10/18/91) - m := MAXINDEX s - lastChar := s . m - lastChar = char '_! or lastChar = char '_? or lastChar = char '_. => s - lastChar = char '_, or lastChar = char '_; => - s . m := (char '_.) - s - s - -checkGetArgs u == - NOT STRINGP u => nil - m := MAXINDEX u - k := firstNonBlankPosition(u) - k > 0 => checkGetArgs SUBSTRING(u,k,nil) - stringPrefix?('"\spad{",u) => - k := getMatchingRightPren(u,6,char '_{,char '_}) or m - checkGetArgs SUBSTRING(u,6,k-6) - (i := charPosition(char '_(,u,0)) > m => nil - (u . m) ^= char '_) => nil - while (k := charPosition($charComma,u,i + 1)) < m repeat - acc := [trimString SUBSTRING(u,i + 1,k - i - 1),:acc] - i := k - NREVERSE [SUBSTRING(u,i + 1,m - i - 1),:acc] - -checkGetMargin lines == - while lines repeat - do - x := first lines - k := firstNonBlankPosition x - k = -1 => nil - margin := (margin => MIN(margin,k); k) - lines := rest lines - margin or 0 - -firstNonBlankPosition(x,:options) == - start := IFCAR options or 0 - k := -1 - for i in start..MAXINDEX x repeat - if x.i ^= $charBlank then return (k := i) - k - -checkAddIndented(x,margin) == - k := firstNonBlankPosition x - k = -1 => '"\blankline " - margin = k => x - STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(SUBSTRING(x,k,nil),0),'"}") - -checkAddSpaceSegments(u,k) == - m := MAXINDEX u - i := charPosition($charBlank,u,k) - m < i => u - j := i - while (j := j + 1) < m and u.j = (char '_ ) repeat 'continue - n := j - i --number of blanks - n > 1 => STRCONC(SUBSTRING(u,0,i),'"\space{", - STRINGIMAGE n,'"}",checkAddSpaceSegments(SUBSTRING(u,i + n,nil),0)) - checkAddSpaceSegments(u,j) - -checkTrim($x,lines) == main where - main == - s := [wherePP first lines] - for x in rest lines repeat - j := wherePP x - if not MEMQ(j,s) then - checkDocError [$x,'" has varying indentation levels"] - s := [j,:s] - [trim y for y in lines] - wherePP(u) == - k := charPosition($charPlus,u,0) - k = #u or charPosition($charPlus,u,k + 1) ^= k + 1 => - systemError '" Improper comment found" - k - trim(s) == - k := wherePP(s) - return SUBSTRING(s,k + 2,nil) - m := MAXINDEX s - n := k + 2 - for j in (k + 2)..m while s.j = $charBlank repeat (n := n + 1) - SUBSTRING(s,n,nil) - -checkExtract(header,lines) == - while lines repeat - line := first lines - k := firstNonBlankPosition line --k gives margin of Description: - substring?(header,line,k) => return nil - lines := rest lines - null lines => nil - u := first lines - j := charPosition(char '_:,u,k) - margin := k - firstLines := - (k := firstNonBlankPosition(u,j + 1)) ^= -1 => - [SUBSTRING(u,j + 1,nil),:rest lines] - rest lines - --now look for another header; if found skip all rest of these lines - acc := nil - for line in firstLines repeat - do - m := #line - (k := firstNonBlankPosition line) = -1 => 'skip --include if blank - k > margin => 'skip --include if idented - not UPPER_-CASE_-P line.k => 'skip --also if not upcased - (j := charPosition(char '_:,line,k)) = m => 'skip --or if not colon, or - (i := charPosition(char '_ ,line,k+1)) < j => 'skip --blank before colon - return nil - acc := [line,:acc] - NREVERSE acc - -checkFixCommonProblem u == - acc := nil - while u repeat - x := first u - x = $charLbrace and member(next := IFCAR rest u,$HTspadmacros) and - (IFCAR IFCDR rest u ^= $charLbrace) => - checkDocError ['"Reversing ",next,'" and left brace"] - acc := [$charLbrace,next,:acc] --reverse order of brace and command - u := rest rest u - acc := [x,:acc] - u := rest u - NREVERSE acc - -checkDecorate u == - count := 0 - spadflag := false --means OK to wrap single letter words with \s{} - mathSymbolsOk := false - acc := nil - verbatim := false - while u repeat - x := first u - - if not verbatim then - if x = '"\em" then - if count > 0 then - mathSymbolsOk := count - 1 - spadflag := count - 1 - else checkDocError ['"\em must be enclosed in braces"] - if member(x,'("\spadpaste" "\spad" "\spadop")) then mathSymbolsOk := count - if member(x,'("\s" "\spadtype" "\spadsys" "\example" "\andexample" "\spadop" "\spad" "\spadignore" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count - else if x = $charLbrace then - count := count + 1 - else if x = $charRbrace then - count := count - 1 - if mathSymbolsOk = count then mathSymbolsOk := false - if spadflag = count then spadflag := false - else if not mathSymbolsOk and member(x,'("+" "*" "=" "==" "->")) then - if $checkingXmptex? then - checkDocError ["Symbol ",x,'" appearing outside \spad{}"] - - acc := - x = '"\end{verbatim}" => - verbatim := false - [x, :acc] - verbatim => [x, :acc] - x = '"\begin{verbatim}" => - verbatim := true - [x, :acc] - - x = '"\begin" and first (v := IFCDR u) = $charLbrace and - first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace - => - u := v - ['"\blankline ",:acc] - x = '"\end" and first (v := IFCDR u) = $charLbrace and - first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace - => - u := v - acc - x = char '_$ or x = '"$" => ['"\$",:acc] - x = char '_% or x = '"%" => ['"\%",:acc] - x = char '_, or x = '"," => ['",{}",:acc] - x = '"\spad" => ['"\spad",:acc] - STRINGP x and DIGITP x.0 => [x,:acc] - null spadflag and - (CHARP x and ALPHA_-CHAR_-P x and not MEMQ(x,$charExclusions) or - member(x,$argl)) => [$charRbrace,x,$charLbrace,'"\spad",:acc] - null spadflag and ((STRINGP x and not x.0 = $charBack and DIGITP(x.(MAXINDEX x))) or member(x,'("true" "false"))) => - [$charRbrace,x,$charLbrace,'"\spad",:acc] --wrap x1, alpha3, etc - xcount := #x - xcount = 3 and x.1 = char 't and x.2 = char 'h => - ['"th",$charRbrace,x.0,$charLbrace,'"\spad",:acc] - xcount = 4 and x.1 = char '_- and x.2 = char 't and x.3 = char 'h => - ['"-th",$charRbrace,x.0,$charLbrace,'"\spad",:acc] - xcount = 2 and x.1 = char 'i or --wrap ei, xi, hi - null spadflag and xcount > 0 and xcount < 4 and not member(x,'("th" "rd" "st")) and - hasNoVowels x => --wrap words with no vowels - [$charRbrace,x,$charLbrace,'"\spad",:acc] - [checkAddBackSlashes x,:acc] - u := rest u - NREVERSE acc - -hasNoVowels x == - max := MAXINDEX x - x.max = char 'y => false - and/[not isVowel(x.i) for i in 0..max] - -isVowel c == - EQ(c,char 'a) or EQ(c,char 'e) or EQ(c,char 'i) or EQ(c,char 'o) or EQ(c,char 'u) or - EQ(c,char 'A) or EQ(c,char 'E) or EQ(c,char 'I) or EQ(c,char 'O) or EQ(c,char 'U) - - -checkAddBackSlashes s == - (CHARP s and (c := s)) or (#s = 1 and (c := s.0)) => - MEMQ(s,$charEscapeList) => STRCONC($charBack,c) - s - k := 0 - m := MAXINDEX s - insertIndex := nil - while k <= m repeat - do - char := s.k - char = $charBack => k := k + 2 - MEMQ(char,$charEscapeList) => return (insertIndex := k) - k := k + 1 - insertIndex => checkAddBackSlashes STRCONC(SUBSTRING(s,0,insertIndex),$charBack,s.k,SUBSTRING(s,insertIndex + 1,nil)) - s - -checkAddSpaces u == - null u => nil - null rest u => u - space := $charBlank - u2 := nil - for i in 1.. for f in u repeat - -- want newlines before and after begin/end verbatim and between lines - -- since this might be written to a file, we can't really use - -- newline characters. The Browser and HD will do the translation - -- later. - if f = '"\begin{verbatim}" then - space := $charFauxNewline - if null u2 then u2 := [space] - - if i > 1 then u2 := [:u2, space, f] - else u2 := [:u2, f] - - if f = '"\end{verbatim}" then - u2 := [:u2, space] - space := $charBlank - u2 - -checkIeEg u == - acc := nil - verbatim := false - while u repeat - x := first u - acc := - x = '"\end{verbatim}" => - verbatim := false - [x, :acc] - verbatim => [x, :acc] - x = '"\begin{verbatim}" => - verbatim := true - [x, :acc] - z := checkIeEgfun x => [:NREVERSE z,:acc] - [x,:acc] - u := rest u - NREVERSE acc - -checkIeEgfun x == - CHARP x => nil - x = '"" => nil - m := MAXINDEX x - for k in 0..(m - 3) repeat - x.(k + 1) = $charPeriod and x.(k + 3) = $charPeriod and - (x.k = char 'i and x.(k + 2) = char 'e and (key := '"that is") - or x.k = char 'e and x.(k + 2) = char 'g and (key := '"for example")) => - firstPart := (k > 0 => [SUBSTRING(x,0,k)]; nil) - result := [:firstPart,'"\spadignore{",SUBSTRING(x,k,4),'"}", - :checkIeEgfun SUBSTRING(x,k+4,nil)] - result - -checkSplit2Words u == - acc := nil - while u repeat - x := first u - acc := - x = '"\end{verbatim}" => - verbatim := false - [x, :acc] - verbatim => [x, :acc] - x = '"\begin{verbatim}" => - verbatim := true - [x, :acc] - z := checkSplitBrace x => [:NREVERSE z,:acc] - [x,:acc] - u := rest u - NREVERSE acc - -checkSplitBrace x == - CHARP x => [x] - #x = 1 => [x.0] - (u := checkSplitBackslash x) - and rest u => "append"/[checkSplitBrace y for y in u] - m := MAXINDEX x - (u := checkSplitOn x) - and rest u => "append"/[checkSplitBrace y for y in u] - (u := checkSplitPunctuation x) - and rest u => "append"/[checkSplitBrace y for y in u] - [x] - -checkSplitBackslash x == - not STRINGP x => [x] - m := MAXINDEX x - (k := charPosition($charBack,x,0)) < m => - m = 1 or ALPHA_-CHAR_-P(x . (k + 1)) => --starts with a backslash so.. - (k := charPosition($charBack,x,1)) < m => --..see if there is another - [SUBSTRING(x,0,k),:checkSplitBackslash SUBSTRING(x,k,nil)] -- yup - [x] --no, just return line - k = 0 => --starts with backspace but x.1 is not a letter; break it up - [SUBSTRING(x,0,2),:checkSplitBackslash SUBSTRING(x,2,nil)] - u := SUBSTRING(x,0,k) - v := SUBSTRING(x,k,2) - k + 1 = m => [u,v] - [u,v,:checkSplitBackslash SUBSTRING(x,k + 2,nil)] - [x] - -checkSplitPunctuation x == - CHARP x => [x] - m := MAXINDEX x - m < 1 => [x] - lastchar := x.m - lastchar = $charPeriod and x.(m - 1) = $charPeriod => - m = 1 => [x] - m > 3 and x.(m-2) = $charPeriod => - [:checkSplitPunctuation SUBSTRING(x,0,m-2),'"..."] - [:checkSplitPunctuation SUBSTRING(x,0,m-1),'".."] - lastchar = $charPeriod or lastchar = $charSemiColon or lastchar = $charComma - => [SUBSTRING(x,0,m),lastchar] - m > 1 and x.(m - 1) = $charQuote => [SUBSTRING(x,0,m - 1),SUBSTRING(x,m-1,nil)] - (k := charPosition($charBack,x,0)) < m => - k = 0 => - m = 1 or HGET($htMacroTable,x) or ALPHA_-CHAR_-P x.1 => [x] - v := SUBSTRING(x,2,nil) - [SUBSTRING(x,0,2),:checkSplitPunctuation v] - u := SUBSTRING(x,0,k) - v := SUBSTRING(x,k,nil) - [:checkSplitPunctuation u,:checkSplitPunctuation v] - (k := charPosition($charDash,x,1)) < m => - u := SUBSTRING(x,k + 1,nil) - [SUBSTRING(x,0,k),$charDash,:checkSplitPunctuation u] - [x] - -checkSplitOn(x) == - CHARP x => [x] - l := $charSplitList - m := MAXINDEX x - while l repeat - char := first l - do - m = 0 and x.0 = char => return (k := -1) --special exit - k := charPosition(char,x,0) - k > 0 and x.(k - 1) = $charBack => [x] - k <= m => return k - l := rest l - null l => [x] - k = -1 => [char] - k = 0 => [char,SUBSTRING(x,1,nil)] - k = MAXINDEX x => [SUBSTRING(x,0,k),char] - [SUBSTRING(x,0,k),char,:checkSplitOn SUBSTRING(x,k + 1,nil)] - - -checkBalance u == - checkBeginEnd u - stack := nil - while u repeat - do - x := first u - openClose := ASSOC(x,$checkPrenAlist) --is it an open bracket? - => stack := [CAR openClose,:stack] --yes, push the open bracket - open := rassoc(x,$checkPrenAlist) => --it is a close bracket! - stack is [top,:restStack] => --does corresponding open bracket match? - if open ^= top then --yes: just pop the stack - checkDocError - ['"Mismatch: left ",checkSayBracket top,'" matches right ",checkSayBracket open] - stack := restStack - checkDocError ['"Missing left ",checkSayBracket open] - u := rest u - if stack then - for x in NREVERSE stack repeat - checkDocError ['"Missing right ",checkSayBracket x] - u - -checkSayBracket x == - x = char '_( or x = char '_) => '"pren" - x = char '_{ or x = char '_} => '"brace" - '"bracket" - -checkBeginEnd u == - beginEndStack := nil - while u repeat - IDENTITY - x := first u - STRINGP x and x.0 = $charBack and #x > 2 and not HGET($htMacroTable,x) - and not (x = '"\spadignore") and IFCAR IFCDR u = $charLbrace - and not - (substring?('"\radiobox",x,0) or substring?('"\inputbox",x,0))=> - --allow 0 argument guys to pass through - checkDocError ["Unexpected HT command: ",x] - x = '"\beginitems" => - beginEndStack := ["items",:beginEndStack] - x = '"\begin" => - u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace => - if not member(y,$beginEndList) then - checkDocError ['"Unknown begin type: \begin{",y,'"}"] - beginEndStack := [y,:beginEndStack] - u := r - checkDocError ['"Improper \begin command"] - x = '"\item" => - member(IFCAR beginEndStack,'("items" "menu")) => nil - null beginEndStack => - checkDocError ['"\item appears outside a \begin-\end"] - checkDocError ['"\item appears within a \begin{",IFCAR beginEndStack,'"}.."] - x = '"\end" => - u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace => - y = IFCAR beginEndStack => - beginEndStack := rest beginEndStack - u := r - checkDocError ['"Trying to match \begin{",IFCAR beginEndStack,'"} with \end{",y,"}"] - checkDocError ['"Improper \end command"] - u := rest u - beginEndStack => checkDocError ['"Missing \end{",first beginEndStack,'"}"] - 'ok - -checkArguments u == - while u repeat - do - x := first u - null (k := HGET($htMacroTable,x)) => 'skip - k = 0 => 'skip - k > 0 => checkHTargs(x,rest u,k,nil) - checkHTargs(x,rest u,-k,true) - u := rest u - u - -checkHTargs(keyword,u,nargs,integerValue?) == ---u should start with an open brace ... - nargs = 0 => 'ok - if not (u := checkLookForLeftBrace u) then - return checkDocError ['"Missing argument for ",keyword] - if not (u := checkLookForRightBrace IFCDR u) then - return checkDocError ['"Missing right brace for ",keyword] - checkHTargs(keyword,rest u,nargs - 1,integerValue?) - -checkLookForLeftBrace(u) == --return line beginning with left brace - while u repeat - x := first u - if x = $charLbrace then return u - x ^= $charBlank => return nil - u := rest u - u - -checkLookForRightBrace(u) == --return line beginning with right brace - count := 0 - while u repeat - x := first u - do - x = $charRbrace => - count = 0 => return (found := u) - count := count - 1 - x = $charLbrace => count := count + 1 - u := rest u - found - -checkInteger s == - CHARP s => false - s = '"" => false - and/[DIGIT_-CHAR_-P s.i for i in 0..MAXINDEX s] - -checkTransformFirsts(opname,u,margin) == ---case 1: \spad{... ---case 2: form(args) ---case 3: form arg ---case 4: op arg ---case 5: arg op arg - namestring := PNAME opname - if namestring = '"Zero" then namestring := '"0" - else if namestring = '"One" then namestring := '"1" - margin > 0 => - s := leftTrim u - STRCONC(fillerSpaces margin,checkTransformFirsts(opname,s,0)) - m := MAXINDEX u - m < 2 => u - u.0 = $charBack => u - ALPHA_-CHAR_-P u.0 => - i := checkSkipToken(u,0,m) or return u - j := checkSkipBlanks(u,i,m) or return u - open := u.j - open = char '_[ and (close := char '_]) or - open = char '_( and (close := char '_)) => - k := getMatchingRightPren(u,j + 1,open,close) - namestring ^= (firstWord := SUBSTRING(u,0,i)) => - checkDocError ['"Improper first word in comments: ",firstWord] - u - null k => - if open = char '_[ - then checkDocError ['"Missing close bracket on first line: ", u] - else checkDocError ['"Missing close parenthesis on first line: ", u] - u - STRCONC('"\spad{",SUBSTRING(u,0,k + 1),'"}",SUBSTRING(u,k + 1,nil)) - k := checkSkipToken(u,j,m) or return u - infixOp := INTERN SUBSTRING(u,j,k - j) - not GET(infixOp,'Led) => --case 3 - namestring ^= (firstWord := SUBSTRING(u,0,i)) => - checkDocError ['"Improper first word in comments: ",firstWord] - u - #(p := PNAME infixOp) = 1 and (open := p.0) and - (close := LASSOC(open,$checkPrenAlist)) => --have an open bracket - l := getMatchingRightPren(u,k + 1,open,close) - if l > MAXINDEX u then l := k - 1 - STRCONC('"\spad{",SUBSTRING(u,0,l + 1),'"}",SUBSTRING(u,l + 1,nil)) - STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil)) - l := checkSkipBlanks(u,k,m) or return u - n := checkSkipToken(u,l,m) or return u - namestring ^= PNAME infixOp => - checkDocError ['"Improper initial operator in comments: ",infixOp] - u - STRCONC('"\spad{",SUBSTRING(u,0,n),'"}",SUBSTRING(u,n,nil)) --case 5 - true => -- not ALPHA_-CHAR_-P u.0 => - i := checkSkipToken(u,0,m) or return u - namestring ^= (firstWord := SUBSTRING(u,0,i)) => - checkDocError ['"Improper first word in comments: ",firstWord] - u - prefixOp := INTERN SUBSTRING(u,0,i) - not GET(prefixOp,'Nud) => - u ---what could this be? - j := checkSkipBlanks(u,i,m) or return u - u.j = char '_( => --case 4 - j := getMatchingRightPren(u,j + 1,char '_(,char '_)) - j > m => u - STRCONC('"\spad{",SUBSTRING(u,0,j + 1),'"}",SUBSTRING(u,j + 1,nil)) - k := checkSkipToken(u,j,m) or return u - namestring ^= (firstWord := SUBSTRING(u,0,i)) => - checkDocError ['"Improper first word in comments: ",firstWord] - u - STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil)) - -getMatchingRightPren(u,j,open,close) == - count := 0 - m := MAXINDEX u - for i in j..m repeat - c := u . i - do - c = close => - count = 0 => return (found := i) - count := count - 1 - c = open => count := count + 1 - found - -checkSkipBlanks(u,i,m) == - while i < m and u.i = $charBlank repeat i := i + 1 - i = m => nil - i - -checkSkipToken(u,i,m) == - ALPHA_-CHAR_-P(u.i) => checkSkipIdentifierToken(u,i,m) - checkSkipOpToken(u,i,m) - -checkSkipOpToken(u,i,m) == - while i < m and - (not(checkAlphabetic(u.i)) and not(member(u.i,$charDelimiters))) repeat - i := i + 1 - i = m => nil - i - -checkSkipIdentifierToken(u,i,m) == - while i < m and checkAlphabetic u.i repeat i := i + 1 - i = m => nil - i - -checkAlphabetic c == - ALPHA_-CHAR_-P c or DIGITP c or MEMQ(c,$charIdentifierEndings) - ---======================================================================= --- Code for creating a personalized report for ++ comments ---======================================================================= -docreport(nam) == ---creates a report for person "nam" using file "whofiles" - OBEY '"rm docreport.input" - OBEY STRCONC('"echo _")bo setOutStream('",STRINGIMAGE nam,'")_" > temp.input") - OBEY '"cat docreport.header temp.input > docreport.input" - OBEY STRCONC('"awk '/",STRINGIMAGE nam,'"/ {printf(_")co %s.spad\n_",$2)}' whofiles > temp.input") - OBEY '"cat docreport.input temp.input > temp1.input" - OBEY '"cat temp1.input docreport.trailer > docreport.input" - OBEY '"rm temp.input" - OBEY '"rm temp1.input" - SETQ(_/EDITFILE,'"docreport.input") - _/RQ() - -setOutStream nam == - filename := STRCONC('"/tmp/",STRINGIMAGE nam,".docreport") - $outStream := MAKE_-OUTSTREAM filename - -whoOwns(con) == - null $exposeFlag => nil ---con=constructor name (id beginning with a capital), returns owner as a string - filename := GETDATABASE(con,'SOURCEFILE) - quoteChar := char '_" - OBEY STRCONC('"awk '$2 == ",quoteChar,filename,quoteChar,'" {print $1}' whofiles > /tmp/temp") - instream := MAKE_-INSTREAM '"/tmp/temp" - value := - EOFP instream => nil - READLINE instream - SHUT instream - value - ---======================================================================= --- Report Documentation Error ---======================================================================= -checkDocError1 u == ---when compiling for documentation, ignore certain errors - BOUNDP '$compileDocumentation and $compileDocumentation => nil - checkDocError u - -checkDocError u == - $checkErrorFlag := true - msg := - $recheckingFlag => - $constructorName => checkDocMessage u - concat('"> ",u) - $constructorName => checkDocMessage u - u - if $exposeFlag and $exposeFlagHeading then - SAYBRIGHTLY1($exposeFlagHeading,$outStream) - sayBrightly $exposeFlagHeading - $exposeFlagHeading := nil - sayBrightly msg - if $exposeFlag then SAYBRIGHTLY1(msg,$outStream) - --if called by checkDocFile (see file checkdoc.boot) - -checkDocMessage u == - sourcefile := GETDATABASE($constructorName,'SOURCEFILE) - person := whoOwns $constructorName or '"---" - middle := - BOUNDP '$x => ['"(",$x,'"): "] - ['": "] - concat(person,'">",sourcefile,'"-->",$constructorName,middle,u) - -checkDecorateForHt u == - count := 0 - spadflag := false --means OK to wrap single letter words with \s{} - while u repeat - x := first u - do - if x = '"\em" then - if count > 0 then spadflag := count - 1 - else checkDocError ['"\em must be enclosed in braces"] - if member(x,'("\s" "\spadop" "\spadtype" "\spad" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count - else if x = $charLbrace then count := count + 1 - else if x = $charRbrace then - count := count - 1 - if spadflag = count then spadflag := false - else if not spadflag and member(x,'("+" "*" "=" "==" "->")) then - if $checkingXmptex? then - checkDocError ["Symbol ",x,'" appearing outside \spad{}"] - x = '"$" or x = '"%" => checkDocError ['"Unescaped ",x] --- null spadflag and STRINGP x and (member(x,$argl) or #x = 1 --- and ALPHA_-CHAR_-P x.0) and not member(x,'("a" "A")) => --- checkDocError1 ['"Naked ",x] --- null spadflag and STRINGP x and (not x.0 = $charBack and not DIGITP(x.0) and DIGITP(x.(MAXINDEX x))or member(x,'("true" "false"))) --- => checkDocError1 ["Naked ",x] - u := rest u - u - - - - diff --git a/src/interp/c-doc.boot.pamphlet b/src/interp/c-doc.boot.pamphlet new file mode 100644 index 00000000..d1d0949c --- /dev/null +++ b/src/interp/c-doc.boot.pamphlet @@ -0,0 +1,1298 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/c-doc.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +batchExecute() == + _/RF_-1 '(GENCON INPUT) + +getDoc(conName,op,modemap) == + [dc,target,sl,pred,D] := simplifyModemap modemap + sig := [target,:sl] + null atom dc => + sig := SUBST('$,dc,sig) + sig := SUBLISLIS($FormalMapVariableList,rest dc,sig) + getDocForDomain(conName,op,sig) + if argList := IFCDR getOfCategoryArgument pred then + SUBLISLIS($FormalMapArgumentList,argList,sig) + sig := SUBST('$,dc,sig) + getDocForCategory(conName,op,sig) + +getOfCategoryArgument pred == + pred is [fn,:.] and MEMQ(fn,'(AND OR NOT)) => + or/[getOfCategoryArgument x for x in rest pred] + pred is ['ofCategory,'_*1,form] => form + nil + +getDocForCategory(name,op,sig) == + getOpDoc(constructor? name,op,sig) or + or/[getOpDoc(constructor? x,op,sig) for x in whatCatCategories name] + +getDocForDomain(name,op,sig) == + getOpDoc(constructor? name,op,sig) or + or/[getOpDoc(constructor? x,op,sig) for x in whatCatExtDom name] + +getOpDoc(abb,op,:sigPart) == + u := LASSOC(op,GETDATABASE(abb,'DOCUMENTATION)) + $argList : local := $FormalMapVariableList + _$: local := '_$ + sigPart is [sig] => or/[d for [s,:d] in u | sig = s] + u + +readForDoc fn == + $bootStrapMode: local:= true + _/RQ_-LIB_-1 [fn,'SPAD] + +recordSignatureDocumentation(opSig,lineno) == + recordDocumentation(rest postTransform opSig,lineno) + +recordAttributeDocumentation(['Attribute,att],lineno) == + name := opOf att + UPPER_-CASE_-P (PNAME name).0 => nil + recordDocumentation([name,['attribute,:IFCDR postTransform att]],lineno) + +recordDocumentation(key,lineno) == + recordHeaderDocumentation lineno + u:= collectComBlock lineno + --record NIL to mean "there was no documentation" + $maxSignatureLineNumber := lineno + $docList := [[key,:u],:$docList] + -- leave CAR of $docList alone as required by collectAndDeleteAssoc + +recordHeaderDocumentation lineno == + if $maxSignatureLineNumber = 0 then + al := [p for (p := [n,:u]) in $COMBLOCKLIST + | NULL n or NULL lineno or n < lineno] + $COMBLOCKLIST := SETDIFFERENCE($COMBLOCKLIST,al) + $headerDocumentation := ASSOCRIGHT al + if $headerDocumentation then $maxSignatureLineNumber := 1 --see postDef + $headerDocumentation + +collectComBlock x == + $COMBLOCKLIST is [[=x,:val],:.] => + u := [:val,:collectAndDeleteAssoc x] + $COMBLOCKLIST := rest $COMBLOCKLIST + u + collectAndDeleteAssoc x + +collectAndDeleteAssoc x == +--u is (.. (x . a) .. (x . b) .. ) ==> (a b ..) deleting entries from u +--assumes that the first element is useless + for y in tails $COMBLOCKLIST | (s := rest y) repeat + while s and first s is [=x,:r] repeat + res := [:res,:r] + s := rest s + RPLACD(y,s) + res + +finalizeDocumentation() == + unusedCommentLineNumbers := [x for (x := [n,:r]) in $COMBLOCKLIST | r] + docList := SUBST("$","%",transDocList($op,$docList)) + if u := [sig for [sig,:doc] in docList | null doc] then + for y in u repeat + y = 'constructor => noHeading := true + y is [x,b] and b is [='attribute,:r] => + attributes := [[x,:r],:attributes] + signatures := [y,:signatures] + name := CAR $lisplibForm + if noHeading or signatures or attributes or unusedCommentLineNumbers then + sayKeyedMsg("S2CD0001",NIL) + bigcnt := 1 + if noHeading or signatures or attributes then + sayKeyedMsg("S2CD0002",[STRCONC(STRINGIMAGE bigcnt,'"."),name]) + bigcnt := bigcnt + 1 + litcnt := 1 + if noHeading then + sayKeyedMsg("S2CD0003", + [STRCONC('"(",STRINGIMAGE litcnt,'")"),name]) + litcnt := litcnt + 1 + if signatures then + sayKeyedMsg("S2CD0004", + [STRCONC('"(",STRINGIMAGE litcnt,'")")]) + litcnt := litcnt + 1 + for [op,sig] in signatures repeat + s := formatOpSignature(op,sig) + sayMSG + atom s => ['%x9,s] + ['%x9,:s] + if attributes then + sayKeyedMsg("S2CD0005", + [STRCONC('"(",STRINGIMAGE litcnt,'")")]) + litcnt := litcnt + 1 + for x in attributes repeat + a := form2String x + sayMSG + atom a => ['%x9,a] + ['%x9,:a] + if unusedCommentLineNumbers then + sayKeyedMsg("S2CD0006",[STRCONC(STRINGIMAGE bigcnt,'"."),name]) + for [n,r] in unusedCommentLineNumbers repeat + sayMSG ['" ",:bright n,'" ",r] + hn [[:fn(sig,$e),:doc] for [sig,:doc] in docList] where + fn(x,e) == + atom x => [x,nil] + if #x > 2 then x := TAKE(2,x) + SUBLISLIS($FormalMapVariableList,rest $lisplibForm, + macroExpand(x,e)) + hn u == + -- ((op,sig,doc), ...) --> ((op ((sig doc) ...)) ...) + opList := REMDUP ASSOCLEFT u + [[op,:[[sig,doc] for [op1,sig,doc] in u | op = op1]] for op in opList] + +--======================================================================= +-- Transformation of ++ comments +--======================================================================= +transDocList($constructorName,doclist) == --returns ((key line)...) +--called ONLY by finalizeDocumentation +--if $exposeFlag then messages go to file $outStream; flag=nil by default + sayBrightly ['" Processing ",$constructorName,'" for Browser database:"] + commentList := transDoc($constructorName,doclist) + acc := nil + for entry in commentList repeat + entry is ['constructor,x] => + conEntry => checkDocError ['"Spurious comments: ",x] + conEntry := entry + acc := [entry,:acc] + conEntry => [conEntry,:acc] + checkDocError1 ['"Missing Description"] + acc + +transDoc(conname,doclist) == +--$exposeFlag and not isExposedConstructor conname => nil +--skip over unexposed constructors when checking system files + $x: local + rlist := REVERSE doclist + for [$x,:lines] in rlist repeat + $attribute? : local := $x is [.,[key]] and key = 'attribute + null lines => + $attribute? => nil + checkDocError1 ['"Not documented!!!!"] + u := checkTrim($x,(STRINGP lines => [lines]; $x = 'constructor => first lines; lines)) + $argl : local := nil --set by checkGetArgs +-- tpd: related domain information doesn't exist +-- if v := checkExtract('"Related Domains:",u) then +-- $lisplibRelatedDomains:=[w for x in gn(v) | w := fn(x)] where +-- gn(v) == --note: unabbrev checks for correct number of arguments +-- s := checkExtractItemList v +-- parse := ncParseFromString s --is a single conform or a tuple +-- null parse => nil +-- parse is ['Tuple,:r] => r +-- [parse] +-- fn(x) == +-- expectedNumOfArgs := checkNumOfArgs x +-- null expectedNumOfArgs => +-- checkDocError ['"Unknown constructor name?: ",opOf x] +-- x +-- expectedNumOfArgs ^= (n := #(IFCDR x)) => +-- n = 0 => checkDocError1 +-- ['"You must give arguments to the _"Related Domain_": ",x] +-- checkDocError +-- ['"_"Related Domain_" has wrong number of arguments: ",x] +-- nil +-- n=0 and atom x => [x] +-- x + longline := + $x = 'constructor => + v :=checkExtract('"Description:",u) or u and + checkExtract('"Description:", + [STRCONC('"Description: ",first u),:rest u]) + transformAndRecheckComments('constructor,v or u) + transformAndRecheckComments($x,u) + acc := [[$x,longline],:acc] --processor assumes a list of lines + NREVERSE acc + +checkExtractItemList l == --items are separated by commas or end of line + acc := nil --l is list of remaining lines + while l repeat --stop when you get to a line with a colon + m := MAXINDEX first l + k := charPosition(char '_:,first l,0) + k <= m => return nil + acc := [first l,:acc] + l := rest l + "STRCONC"/[x for x in NREVERSE acc] + +--NREVERSE("append"/[fn string for string in acc]) where +-- fn(string) == +-- m := MAXINDEX string +-- acc := nil +-- i := 0 +-- while i < m and (k := charPosition(char '_,,string,i)) < m repeat +-- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc] +-- i := k + 1 +-- if i < m then +-- if (t := trimString SUBSTRING(string,i,k-i)) ^= '"" then acc := [t,:acc] +-- acc + +transformAndRecheckComments(name,lines) == + $checkingXmptex? := false + $x : local := name + $name : local := 'GlossaryPage + $origin : local := 'gloss + $recheckingFlag : local := false + $exposeFlagHeading : local := ['"--------",name,'"---------"] + if null $exposeFlag then sayBrightly $exposeFlagHeading + u := checkComments(name,lines) + $recheckingFlag := true + checkRewrite(name,[u]) + $recheckingFlag := false + u + +checkRewrite(name,lines) == main where --similar to checkComments from c-doc + main == + $checkErrorFlag: local := true + margin := 0 + lines := checkRemoveComments lines + u := lines + if $checkingXmptex? then + u := [checkAddIndented(x,margin) for x in u] + $argl := checkGetArgs first u --set $argl + u2 := nil + verbatim := nil + for x in u repeat + w := newString2Words x + verbatim => + w and first w = '"\end{verbatim}" => + verbatim := false + u2 := append(u2, w) + u2 := append(u2, [x]) + w and first w = '"\begin{verbatim}" => + verbatim := true + u2 := append(u2, w) + u2 := append(u2, w) + u := u2 + u := checkAddSpaces u + u := checkSplit2Words u + u := checkAddMacros u + u := checkTexht u +-- checkBalance u + okBefore := null $checkErrorFlag + checkArguments u + if $checkErrorFlag then u := checkFixCommonProblem u + checkRecordHash u +-- u := checkTranVerbatim u + checkDecorateForHt u + +checkTexht u == + count := 0 + acc := nil + while u repeat + x := first u + if x = '"\texht" and (u := IFCDR u) then + if not (IFCAR u = $charLbrace) then + checkDocError '"First left brace after \texht missing" + count := 1 -- drop first argument including braces of \texht + while ((y := IFCAR (u := rest u))^= $charRbrace or count > 1) repeat + if y = $charLbrace then count := count + 1 + if y = $charRbrace then count := count - 1 + x := IFCAR (u := rest u) -- drop first right brace of 1st arg + if x = '"\httex" and (u := IFCDR u) and (IFCAR u = $charLbrace) then + acc := [IFCAR u,:acc] --left brace: add it + while (y := IFCAR (u := rest u)) ^= $charRbrace repeat (acc := [y,:acc]) + acc := [IFCAR u,:acc] --right brace: add it + x := IFCAR (u := rest u) --left brace: forget it + while IFCAR (u := rest u) ^= $charRbrace repeat 'skip + x := IFCAR (u := rest u) --forget right brace: move to next char + acc := [x,:acc] + u := rest u + NREVERSE acc + +checkRecordHash u == + while u repeat + x := first u + if STRINGP x and x.0 = $charBack then + if member(x,$HTlinks) and (u := checkLookForLeftBrace IFCDR u) + and (u := checkLookForRightBrace IFCDR u) + and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then + htname := intern IFCAR u + entry := HGET($htHash,htname) or [nil] + HPUT($htHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) + else if member(x,$HTlisplinks) and (u := checkLookForLeftBrace IFCDR u) + and (u := checkLookForRightBrace IFCDR u) + and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then + htname := intern checkGetLispFunctionName checkGetStringBeforeRightBrace u + entry := HGET($lispHash,htname) or [nil] + HPUT($lispHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) + else if ((p := member(x,'("\gloss" "\spadglos"))) + or (q := member(x,'("\glossSee" "\spadglosSee")))) + and (u := checkLookForLeftBrace IFCDR u) + and (u := IFCDR u) then + if q then + u := checkLookForRightBrace u + u := checkLookForLeftBrace IFCDR u + u := IFCDR u + htname := intern checkGetStringBeforeRightBrace u + entry := HGET($glossHash,htname) or [nil] + HPUT($glossHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) + else if x = '"\spadsys" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then + s := checkGetStringBeforeRightBrace u + if s.0 = char '_) then s := SUBSTRING(s,1,nil) + parse := checkGetParse s + null parse => checkDocError ['"Unparseable \spadtype: ",s] + not member(opOf parse,$currentSysList) => + checkDocError ['"Bad system command: ",s] + atom parse or not (parse is ['set,arg]) => 'ok ---assume ok + not spadSysChoose($setOptions,arg) => + checkDocError ['"Incorrect \spadsys: ",s] + entry := HGET($sysHash,htname) or [nil] + HPUT($sysHash,htname,[first entry,:[[$name,:$origin],:rest entry]]) + else if x = '"\spadtype" and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then + s := checkGetStringBeforeRightBrace u + parse := checkGetParse s + null parse => checkDocError ['"Unparseable \spadtype: ",s] + n := checkNumOfArgs parse + null n => checkDocError ['"Unknown \spadtype: ", s] + atom parse and n > 0 => 'skip + null (key := checkIsValidType parse) => + checkDocError ['"Unknown \spadtype: ", s] + atom key => 'ok + checkDocError ['"Wrong number of arguments: ",form2HtString key] + else if member(x,'("\spadop" "\keyword")) and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then + x := intern checkGetStringBeforeRightBrace u + not (GET(x,'Led) or GET(x,'Nud)) => + checkDocError ['"Unknown \spadop: ",x] + u := rest u + 'done + +checkGetParse s == ncParseFromString removeBackslashes s + +removeBackslashes s == + s = '"" => '"" + (k := charPosition($charBack,s,0)) < #s => + k = 0 => removeBackslashes SUBSTRING(s,1,nil) + STRCONC(SUBSTRING(s,0,k),removeBackslashes SUBSTRING(s,k + 1,nil)) + s + +checkNumOfArgs conform == + conname := opOf conform + constructor? conname or (conname := abbreviation? conname) => + #GETDATABASE(conname,'CONSTRUCTORARGS) + nil --signals error + +checkIsValidType form == main where +--returns ok if correct, form is wrong number of arguments, nil if unknown + main == + atom form => 'ok + [op,:args] := form + conname := (constructor? op => op; abbreviation? op) + null conname => nil + fn(form,GETDATABASE(conname,'COSIG)) + fn(form,coSig) == + #form ^= #coSig => form + or/[null checkIsValidType x for x in rest form for flag in rest coSig | flag] + => nil + 'ok + +checkGetLispFunctionName s == + n := #s + (k := charPosition(char '_|,s,1)) and k < n and + (j := charPosition(char '_|,s,k + 1)) and j < n => SUBSTRING(s,k + 1,j-k-1) + checkDocError ['"Ill-formed lisp expression : ",s] + 'illformed + +checkGetStringBeforeRightBrace u == + acc := nil + while u repeat + x := first u + x = $charRbrace => return "STRCONC"/(NREVERSE acc) + acc := [x,:acc] + u := rest u + +-- checkTranVerbatim u == +-- acc := nil +-- while u repeat +-- x := first u +-- x = '"\begin" and checkTranVerbatimMiddle u is [middle,:r] => +-- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc] +-- u := r +-- if x = '"\spadcommand" then x := '"\spadpaste" +-- acc := [x,:acc] +-- u := rest u +-- NREVERSE acc +-- +-- checkTranVerbatimMiddle u == +-- (y := IFCAR (v := IFCDR u)) = $charLbrace and +-- (y := IFCAR (v := IFCDR v)) = '"verbatim" and +-- (y := IFCAR (v := IFCDR v)) = $charRbrace => +-- w := IFCDR v +-- middle := nil +-- while w and (z := first w) ^= '"\end" repeat +-- middle := [z,:middle] +-- w := rest w +-- if (y := IFCAR (w := IFCDR w)) = $charLbrace and +-- (y := IFCAR (w := IFCDR w)) = '"verbatim" and +-- (y := IFCAR (w := IFCDR w)) = $charRbrace then +-- u := IFCDR w +-- else +-- checkDocError '"Missing \end{verbatim}" +-- u := w +-- [middle,:u] +-- +-- checkTranVerbatim1 u == +-- acc := nil +-- while u repeat +-- x := first u +-- x = '"\begin" and (y := IFCAR (v := IFCDR u)) = $charLbrace and +-- (y := IFCAR (v := IFCDR v)) = '"verbatim" and +-- (y := IFCAR (v := IFCDR v)) = $charRbrace => +-- w := IFCDR v +-- middle := nil +-- while w and (z := first w) ^= '"\end" repeat +-- middle := [z,:middle] +-- w := rest w +-- if (y := IFCAR (w := IFCDR w)) = $charLbrace and +-- (y := IFCAR (w := IFCDR w)) = '"verbatim" and +-- (y := IFCAR (w := IFCDR w)) = $charRbrace then +-- u := IFCDR w +-- acc := [$charRbrace,:middle,$charLbrace,'"\spadpaste",:acc] +-- if x = '"\spadcommand" then x := '"\spadpaste" +-- acc := [x,:acc] +-- u := rest u +-- NREVERSE acc + +appendOver [head,:tail] == + acc := LASTNODE head + for x in tail repeat + end := LASTNODE x + RPLACD(acc,x) + acc := end + head + +checkRemoveComments lines == + while lines repeat + do + line := checkTrimCommented first lines + if firstNonBlankPosition line >= 0 then acc := [line,:acc] + lines := rest lines + NREVERSE acc + +checkTrimCommented line == + n := #line + k := htcharPosition(char '_%,line,0) + --line beginning with % is a comment + k = 0 => '"" + --remarks beginning with %% are comments + k >= n - 1 or line.(k + 1) ^= char '_% => line + k < #line => SUBSTRING(line,0,k) + line + +htcharPosition(char,line,i) == + m := #line + k := charPosition(char,line,i) + k = m => k + k > 0 => + line.(k - 1) ^= $charBack => k + htcharPosition(char,line,k + 1) + 0 + +checkAddMacros u == + acc := nil + verbatim := false + while u repeat + x := first u + acc := + x = '"\end{verbatim}" => + verbatim := false + [x, :acc] + verbatim => [x, :acc] + x = '"\begin{verbatim}" => + verbatim := true + [x, :acc] + y := LASSOC(x,$HTmacs) => [:y,:acc] + [x,:acc] + u := rest u + NREVERSE acc + +checkComments(nameSig,lines) == main where + main == + $checkErrorFlag: local := false + margin := checkGetMargin lines + if (null BOUNDP '$attribute? or null $attribute?) + and nameSig ^= 'constructor then lines := + [checkTransformFirsts(first nameSig,first lines,margin),:rest lines] + u := checkIndentedLines(lines, margin) + $argl := checkGetArgs first u --set $argl + u2 := nil + verbatim := nil + for x in u repeat + w := newString2Words x + verbatim => + w and first w = '"\end{verbatim}" => + verbatim := false + u2 := append(u2, w) + u2 := append(u2, [x]) + w and first w = '"\begin{verbatim}" => + verbatim := true + u2 := append(u2, w) + u2 := append(u2, w) + u := u2 + u := checkAddSpaces u + u := checkIeEg u + u := checkSplit2Words u + checkBalance u + okBefore := null $checkErrorFlag + checkArguments u + if $checkErrorFlag then u := checkFixCommonProblem u + v := checkDecorate u + res := "STRCONC"/[y for y in v] + res := checkAddPeriod res + if $checkErrorFlag then pp res + res + +checkIndentedLines(u, margin) == + verbatim := false + u2 := nil + for x in u repeat + k := firstNonBlankPosition x + k = -1 => + verbatim => u2 := [:u2, $charFauxNewline] + u2 := [:u2, '"\blankline "] + s := SUBSTRING(x, k, nil) + s = '"\begin{verbatim}" => + verbatim := true + u2 := [:u2, s] + s = '"\end{verbatim}" => + verbatim := false + u2 := [:u2, s] + verbatim => u2 := [:u2, SUBSTRING(x, margin, nil)] + margin = k => u2 := [:u2, s] + u2 := [:u2, STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(s,0),'"}")] + u2 + +newString2Words l == + not STRINGP l => [l] + m := MAXINDEX l + m = -1 => NIL + i := 0 + [w while newWordFrom(l,i,m) is [w,i]] + +newWordFrom(l,i,m) == + while i <= m and l.i = " " repeat i := i + 1 + i > m => NIL + buf := '"" + ch := l.i + ch = $charFauxNewline => [$stringFauxNewline, i+ 1] + done := false + while i <= m and not done repeat + ch := l.i + ch = $charBlank or ch = $charFauxNewline => done := true + buf := STRCONC(buf,ch) + i := i + 1 + [buf,i] + +checkAddPeriod s == --No, just leave blank at the end (rdj: 10/18/91) + m := MAXINDEX s + lastChar := s . m + lastChar = char '_! or lastChar = char '_? or lastChar = char '_. => s + lastChar = char '_, or lastChar = char '_; => + s . m := (char '_.) + s + s + +checkGetArgs u == + NOT STRINGP u => nil + m := MAXINDEX u + k := firstNonBlankPosition(u) + k > 0 => checkGetArgs SUBSTRING(u,k,nil) + stringPrefix?('"\spad{",u) => + k := getMatchingRightPren(u,6,char '_{,char '_}) or m + checkGetArgs SUBSTRING(u,6,k-6) + (i := charPosition(char '_(,u,0)) > m => nil + (u . m) ^= char '_) => nil + while (k := charPosition($charComma,u,i + 1)) < m repeat + acc := [trimString SUBSTRING(u,i + 1,k - i - 1),:acc] + i := k + NREVERSE [SUBSTRING(u,i + 1,m - i - 1),:acc] + +checkGetMargin lines == + while lines repeat + do + x := first lines + k := firstNonBlankPosition x + k = -1 => nil + margin := (margin => MIN(margin,k); k) + lines := rest lines + margin or 0 + +firstNonBlankPosition(x,:options) == + start := IFCAR options or 0 + k := -1 + for i in start..MAXINDEX x repeat + if x.i ^= $charBlank then return (k := i) + k + +checkAddIndented(x,margin) == + k := firstNonBlankPosition x + k = -1 => '"\blankline " + margin = k => x + STRCONC('"\indented{",STRINGIMAGE(k-margin),'"}{",checkAddSpaceSegments(SUBSTRING(x,k,nil),0),'"}") + +checkAddSpaceSegments(u,k) == + m := MAXINDEX u + i := charPosition($charBlank,u,k) + m < i => u + j := i + while (j := j + 1) < m and u.j = (char '_ ) repeat 'continue + n := j - i --number of blanks + n > 1 => STRCONC(SUBSTRING(u,0,i),'"\space{", + STRINGIMAGE n,'"}",checkAddSpaceSegments(SUBSTRING(u,i + n,nil),0)) + checkAddSpaceSegments(u,j) + +checkTrim($x,lines) == main where + main == + s := [wherePP first lines] + for x in rest lines repeat + j := wherePP x + if not MEMQ(j,s) then + checkDocError [$x,'" has varying indentation levels"] + s := [j,:s] + [trim y for y in lines] + wherePP(u) == + k := charPosition($charPlus,u,0) + k = #u or charPosition($charPlus,u,k + 1) ^= k + 1 => + systemError '" Improper comment found" + k + trim(s) == + k := wherePP(s) + return SUBSTRING(s,k + 2,nil) + m := MAXINDEX s + n := k + 2 + for j in (k + 2)..m while s.j = $charBlank repeat (n := n + 1) + SUBSTRING(s,n,nil) + +checkExtract(header,lines) == + while lines repeat + line := first lines + k := firstNonBlankPosition line --k gives margin of Description: + substring?(header,line,k) => return nil + lines := rest lines + null lines => nil + u := first lines + j := charPosition(char '_:,u,k) + margin := k + firstLines := + (k := firstNonBlankPosition(u,j + 1)) ^= -1 => + [SUBSTRING(u,j + 1,nil),:rest lines] + rest lines + --now look for another header; if found skip all rest of these lines + acc := nil + for line in firstLines repeat + do + m := #line + (k := firstNonBlankPosition line) = -1 => 'skip --include if blank + k > margin => 'skip --include if idented + not UPPER_-CASE_-P line.k => 'skip --also if not upcased + (j := charPosition(char '_:,line,k)) = m => 'skip --or if not colon, or + (i := charPosition(char '_ ,line,k+1)) < j => 'skip --blank before colon + return nil + acc := [line,:acc] + NREVERSE acc + +checkFixCommonProblem u == + acc := nil + while u repeat + x := first u + x = $charLbrace and member(next := IFCAR rest u,$HTspadmacros) and + (IFCAR IFCDR rest u ^= $charLbrace) => + checkDocError ['"Reversing ",next,'" and left brace"] + acc := [$charLbrace,next,:acc] --reverse order of brace and command + u := rest rest u + acc := [x,:acc] + u := rest u + NREVERSE acc + +checkDecorate u == + count := 0 + spadflag := false --means OK to wrap single letter words with \s{} + mathSymbolsOk := false + acc := nil + verbatim := false + while u repeat + x := first u + + if not verbatim then + if x = '"\em" then + if count > 0 then + mathSymbolsOk := count - 1 + spadflag := count - 1 + else checkDocError ['"\em must be enclosed in braces"] + if member(x,'("\spadpaste" "\spad" "\spadop")) then mathSymbolsOk := count + if member(x,'("\s" "\spadtype" "\spadsys" "\example" "\andexample" "\spadop" "\spad" "\spadignore" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count + else if x = $charLbrace then + count := count + 1 + else if x = $charRbrace then + count := count - 1 + if mathSymbolsOk = count then mathSymbolsOk := false + if spadflag = count then spadflag := false + else if not mathSymbolsOk and member(x,'("+" "*" "=" "==" "->")) then + if $checkingXmptex? then + checkDocError ["Symbol ",x,'" appearing outside \spad{}"] + + acc := + x = '"\end{verbatim}" => + verbatim := false + [x, :acc] + verbatim => [x, :acc] + x = '"\begin{verbatim}" => + verbatim := true + [x, :acc] + + x = '"\begin" and first (v := IFCDR u) = $charLbrace and + first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace + => + u := v + ['"\blankline ",:acc] + x = '"\end" and first (v := IFCDR u) = $charLbrace and + first (v := IFCDR v) = '"detail" and first (v := IFCDR v) = $charRbrace + => + u := v + acc + x = char '_$ or x = '"$" => ['"\$",:acc] + x = char '_% or x = '"%" => ['"\%",:acc] + x = char '_, or x = '"," => ['",{}",:acc] + x = '"\spad" => ['"\spad",:acc] + STRINGP x and DIGITP x.0 => [x,:acc] + null spadflag and + (CHARP x and ALPHA_-CHAR_-P x and not MEMQ(x,$charExclusions) or + member(x,$argl)) => [$charRbrace,x,$charLbrace,'"\spad",:acc] + null spadflag and ((STRINGP x and not x.0 = $charBack and DIGITP(x.(MAXINDEX x))) or member(x,'("true" "false"))) => + [$charRbrace,x,$charLbrace,'"\spad",:acc] --wrap x1, alpha3, etc + xcount := #x + xcount = 3 and x.1 = char 't and x.2 = char 'h => + ['"th",$charRbrace,x.0,$charLbrace,'"\spad",:acc] + xcount = 4 and x.1 = char '_- and x.2 = char 't and x.3 = char 'h => + ['"-th",$charRbrace,x.0,$charLbrace,'"\spad",:acc] + xcount = 2 and x.1 = char 'i or --wrap ei, xi, hi + null spadflag and xcount > 0 and xcount < 4 and not member(x,'("th" "rd" "st")) and + hasNoVowels x => --wrap words with no vowels + [$charRbrace,x,$charLbrace,'"\spad",:acc] + [checkAddBackSlashes x,:acc] + u := rest u + NREVERSE acc + +hasNoVowels x == + max := MAXINDEX x + x.max = char 'y => false + and/[not isVowel(x.i) for i in 0..max] + +isVowel c == + EQ(c,char 'a) or EQ(c,char 'e) or EQ(c,char 'i) or EQ(c,char 'o) or EQ(c,char 'u) or + EQ(c,char 'A) or EQ(c,char 'E) or EQ(c,char 'I) or EQ(c,char 'O) or EQ(c,char 'U) + + +checkAddBackSlashes s == + (CHARP s and (c := s)) or (#s = 1 and (c := s.0)) => + MEMQ(s,$charEscapeList) => STRCONC($charBack,c) + s + k := 0 + m := MAXINDEX s + insertIndex := nil + while k <= m repeat + do + char := s.k + char = $charBack => k := k + 2 + MEMQ(char,$charEscapeList) => return (insertIndex := k) + k := k + 1 + insertIndex => checkAddBackSlashes STRCONC(SUBSTRING(s,0,insertIndex),$charBack,s.k,SUBSTRING(s,insertIndex + 1,nil)) + s + +checkAddSpaces u == + null u => nil + null rest u => u + space := $charBlank + u2 := nil + for i in 1.. for f in u repeat + -- want newlines before and after begin/end verbatim and between lines + -- since this might be written to a file, we can't really use + -- newline characters. The Browser and HD will do the translation + -- later. + if f = '"\begin{verbatim}" then + space := $charFauxNewline + if null u2 then u2 := [space] + + if i > 1 then u2 := [:u2, space, f] + else u2 := [:u2, f] + + if f = '"\end{verbatim}" then + u2 := [:u2, space] + space := $charBlank + u2 + +checkIeEg u == + acc := nil + verbatim := false + while u repeat + x := first u + acc := + x = '"\end{verbatim}" => + verbatim := false + [x, :acc] + verbatim => [x, :acc] + x = '"\begin{verbatim}" => + verbatim := true + [x, :acc] + z := checkIeEgfun x => [:NREVERSE z,:acc] + [x,:acc] + u := rest u + NREVERSE acc + +checkIeEgfun x == + CHARP x => nil + x = '"" => nil + m := MAXINDEX x + for k in 0..(m - 3) repeat + x.(k + 1) = $charPeriod and x.(k + 3) = $charPeriod and + (x.k = char 'i and x.(k + 2) = char 'e and (key := '"that is") + or x.k = char 'e and x.(k + 2) = char 'g and (key := '"for example")) => + firstPart := (k > 0 => [SUBSTRING(x,0,k)]; nil) + result := [:firstPart,'"\spadignore{",SUBSTRING(x,k,4),'"}", + :checkIeEgfun SUBSTRING(x,k+4,nil)] + result + +checkSplit2Words u == + acc := nil + while u repeat + x := first u + acc := + x = '"\end{verbatim}" => + verbatim := false + [x, :acc] + verbatim => [x, :acc] + x = '"\begin{verbatim}" => + verbatim := true + [x, :acc] + z := checkSplitBrace x => [:NREVERSE z,:acc] + [x,:acc] + u := rest u + NREVERSE acc + +checkSplitBrace x == + CHARP x => [x] + #x = 1 => [x.0] + (u := checkSplitBackslash x) + and rest u => "append"/[checkSplitBrace y for y in u] + m := MAXINDEX x + (u := checkSplitOn x) + and rest u => "append"/[checkSplitBrace y for y in u] + (u := checkSplitPunctuation x) + and rest u => "append"/[checkSplitBrace y for y in u] + [x] + +checkSplitBackslash x == + not STRINGP x => [x] + m := MAXINDEX x + (k := charPosition($charBack,x,0)) < m => + m = 1 or ALPHA_-CHAR_-P(x . (k + 1)) => --starts with a backslash so.. + (k := charPosition($charBack,x,1)) < m => --..see if there is another + [SUBSTRING(x,0,k),:checkSplitBackslash SUBSTRING(x,k,nil)] -- yup + [x] --no, just return line + k = 0 => --starts with backspace but x.1 is not a letter; break it up + [SUBSTRING(x,0,2),:checkSplitBackslash SUBSTRING(x,2,nil)] + u := SUBSTRING(x,0,k) + v := SUBSTRING(x,k,2) + k + 1 = m => [u,v] + [u,v,:checkSplitBackslash SUBSTRING(x,k + 2,nil)] + [x] + +checkSplitPunctuation x == + CHARP x => [x] + m := MAXINDEX x + m < 1 => [x] + lastchar := x.m + lastchar = $charPeriod and x.(m - 1) = $charPeriod => + m = 1 => [x] + m > 3 and x.(m-2) = $charPeriod => + [:checkSplitPunctuation SUBSTRING(x,0,m-2),'"..."] + [:checkSplitPunctuation SUBSTRING(x,0,m-1),'".."] + lastchar = $charPeriod or lastchar = $charSemiColon or lastchar = $charComma + => [SUBSTRING(x,0,m),lastchar] + m > 1 and x.(m - 1) = $charQuote => [SUBSTRING(x,0,m - 1),SUBSTRING(x,m-1,nil)] + (k := charPosition($charBack,x,0)) < m => + k = 0 => + m = 1 or HGET($htMacroTable,x) or ALPHA_-CHAR_-P x.1 => [x] + v := SUBSTRING(x,2,nil) + [SUBSTRING(x,0,2),:checkSplitPunctuation v] + u := SUBSTRING(x,0,k) + v := SUBSTRING(x,k,nil) + [:checkSplitPunctuation u,:checkSplitPunctuation v] + (k := charPosition($charDash,x,1)) < m => + u := SUBSTRING(x,k + 1,nil) + [SUBSTRING(x,0,k),$charDash,:checkSplitPunctuation u] + [x] + +checkSplitOn(x) == + CHARP x => [x] + l := $charSplitList + m := MAXINDEX x + while l repeat + char := first l + do + m = 0 and x.0 = char => return (k := -1) --special exit + k := charPosition(char,x,0) + k > 0 and x.(k - 1) = $charBack => [x] + k <= m => return k + l := rest l + null l => [x] + k = -1 => [char] + k = 0 => [char,SUBSTRING(x,1,nil)] + k = MAXINDEX x => [SUBSTRING(x,0,k),char] + [SUBSTRING(x,0,k),char,:checkSplitOn SUBSTRING(x,k + 1,nil)] + + +checkBalance u == + checkBeginEnd u + stack := nil + while u repeat + do + x := first u + openClose := ASSOC(x,$checkPrenAlist) --is it an open bracket? + => stack := [CAR openClose,:stack] --yes, push the open bracket + open := rassoc(x,$checkPrenAlist) => --it is a close bracket! + stack is [top,:restStack] => --does corresponding open bracket match? + if open ^= top then --yes: just pop the stack + checkDocError + ['"Mismatch: left ",checkSayBracket top,'" matches right ",checkSayBracket open] + stack := restStack + checkDocError ['"Missing left ",checkSayBracket open] + u := rest u + if stack then + for x in NREVERSE stack repeat + checkDocError ['"Missing right ",checkSayBracket x] + u + +checkSayBracket x == + x = char '_( or x = char '_) => '"pren" + x = char '_{ or x = char '_} => '"brace" + '"bracket" + +checkBeginEnd u == + beginEndStack := nil + while u repeat + IDENTITY + x := first u + STRINGP x and x.0 = $charBack and #x > 2 and not HGET($htMacroTable,x) + and not (x = '"\spadignore") and IFCAR IFCDR u = $charLbrace + and not + (substring?('"\radiobox",x,0) or substring?('"\inputbox",x,0))=> + --allow 0 argument guys to pass through + checkDocError ["Unexpected HT command: ",x] + x = '"\beginitems" => + beginEndStack := ["items",:beginEndStack] + x = '"\begin" => + u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace => + if not member(y,$beginEndList) then + checkDocError ['"Unknown begin type: \begin{",y,'"}"] + beginEndStack := [y,:beginEndStack] + u := r + checkDocError ['"Improper \begin command"] + x = '"\item" => + member(IFCAR beginEndStack,'("items" "menu")) => nil + null beginEndStack => + checkDocError ['"\item appears outside a \begin-\end"] + checkDocError ['"\item appears within a \begin{",IFCAR beginEndStack,'"}.."] + x = '"\end" => + u is [.,=$charLbrace,y,:r] and CAR r = $charRbrace => + y = IFCAR beginEndStack => + beginEndStack := rest beginEndStack + u := r + checkDocError ['"Trying to match \begin{",IFCAR beginEndStack,'"} with \end{",y,"}"] + checkDocError ['"Improper \end command"] + u := rest u + beginEndStack => checkDocError ['"Missing \end{",first beginEndStack,'"}"] + 'ok + +checkArguments u == + while u repeat + do + x := first u + null (k := HGET($htMacroTable,x)) => 'skip + k = 0 => 'skip + k > 0 => checkHTargs(x,rest u,k,nil) + checkHTargs(x,rest u,-k,true) + u := rest u + u + +checkHTargs(keyword,u,nargs,integerValue?) == +--u should start with an open brace ... + nargs = 0 => 'ok + if not (u := checkLookForLeftBrace u) then + return checkDocError ['"Missing argument for ",keyword] + if not (u := checkLookForRightBrace IFCDR u) then + return checkDocError ['"Missing right brace for ",keyword] + checkHTargs(keyword,rest u,nargs - 1,integerValue?) + +checkLookForLeftBrace(u) == --return line beginning with left brace + while u repeat + x := first u + if x = $charLbrace then return u + x ^= $charBlank => return nil + u := rest u + u + +checkLookForRightBrace(u) == --return line beginning with right brace + count := 0 + while u repeat + x := first u + do + x = $charRbrace => + count = 0 => return (found := u) + count := count - 1 + x = $charLbrace => count := count + 1 + u := rest u + found + +checkInteger s == + CHARP s => false + s = '"" => false + and/[DIGIT_-CHAR_-P s.i for i in 0..MAXINDEX s] + +checkTransformFirsts(opname,u,margin) == +--case 1: \spad{... +--case 2: form(args) +--case 3: form arg +--case 4: op arg +--case 5: arg op arg + namestring := PNAME opname + if namestring = '"Zero" then namestring := '"0" + else if namestring = '"One" then namestring := '"1" + margin > 0 => + s := leftTrim u + STRCONC(fillerSpaces margin,checkTransformFirsts(opname,s,0)) + m := MAXINDEX u + m < 2 => u + u.0 = $charBack => u + ALPHA_-CHAR_-P u.0 => + i := checkSkipToken(u,0,m) or return u + j := checkSkipBlanks(u,i,m) or return u + open := u.j + open = char '_[ and (close := char '_]) or + open = char '_( and (close := char '_)) => + k := getMatchingRightPren(u,j + 1,open,close) + namestring ^= (firstWord := SUBSTRING(u,0,i)) => + checkDocError ['"Improper first word in comments: ",firstWord] + u + null k => + if open = char '_[ + then checkDocError ['"Missing close bracket on first line: ", u] + else checkDocError ['"Missing close parenthesis on first line: ", u] + u + STRCONC('"\spad{",SUBSTRING(u,0,k + 1),'"}",SUBSTRING(u,k + 1,nil)) + k := checkSkipToken(u,j,m) or return u + infixOp := INTERN SUBSTRING(u,j,k - j) + not GET(infixOp,'Led) => --case 3 + namestring ^= (firstWord := SUBSTRING(u,0,i)) => + checkDocError ['"Improper first word in comments: ",firstWord] + u + #(p := PNAME infixOp) = 1 and (open := p.0) and + (close := LASSOC(open,$checkPrenAlist)) => --have an open bracket + l := getMatchingRightPren(u,k + 1,open,close) + if l > MAXINDEX u then l := k - 1 + STRCONC('"\spad{",SUBSTRING(u,0,l + 1),'"}",SUBSTRING(u,l + 1,nil)) + STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil)) + l := checkSkipBlanks(u,k,m) or return u + n := checkSkipToken(u,l,m) or return u + namestring ^= PNAME infixOp => + checkDocError ['"Improper initial operator in comments: ",infixOp] + u + STRCONC('"\spad{",SUBSTRING(u,0,n),'"}",SUBSTRING(u,n,nil)) --case 5 + true => -- not ALPHA_-CHAR_-P u.0 => + i := checkSkipToken(u,0,m) or return u + namestring ^= (firstWord := SUBSTRING(u,0,i)) => + checkDocError ['"Improper first word in comments: ",firstWord] + u + prefixOp := INTERN SUBSTRING(u,0,i) + not GET(prefixOp,'Nud) => + u ---what could this be? + j := checkSkipBlanks(u,i,m) or return u + u.j = char '_( => --case 4 + j := getMatchingRightPren(u,j + 1,char '_(,char '_)) + j > m => u + STRCONC('"\spad{",SUBSTRING(u,0,j + 1),'"}",SUBSTRING(u,j + 1,nil)) + k := checkSkipToken(u,j,m) or return u + namestring ^= (firstWord := SUBSTRING(u,0,i)) => + checkDocError ['"Improper first word in comments: ",firstWord] + u + STRCONC('"\spad{",SUBSTRING(u,0,k),'"}",SUBSTRING(u,k,nil)) + +getMatchingRightPren(u,j,open,close) == + count := 0 + m := MAXINDEX u + for i in j..m repeat + c := u . i + do + c = close => + count = 0 => return (found := i) + count := count - 1 + c = open => count := count + 1 + found + +checkSkipBlanks(u,i,m) == + while i < m and u.i = $charBlank repeat i := i + 1 + i = m => nil + i + +checkSkipToken(u,i,m) == + ALPHA_-CHAR_-P(u.i) => checkSkipIdentifierToken(u,i,m) + checkSkipOpToken(u,i,m) + +checkSkipOpToken(u,i,m) == + while i < m and + (not(checkAlphabetic(u.i)) and not(member(u.i,$charDelimiters))) repeat + i := i + 1 + i = m => nil + i + +checkSkipIdentifierToken(u,i,m) == + while i < m and checkAlphabetic u.i repeat i := i + 1 + i = m => nil + i + +checkAlphabetic c == + ALPHA_-CHAR_-P c or DIGITP c or MEMQ(c,$charIdentifierEndings) + +--======================================================================= +-- Code for creating a personalized report for ++ comments +--======================================================================= +docreport(nam) == +--creates a report for person "nam" using file "whofiles" + OBEY '"rm docreport.input" + OBEY STRCONC('"echo _")bo setOutStream('",STRINGIMAGE nam,'")_" > temp.input") + OBEY '"cat docreport.header temp.input > docreport.input" + OBEY STRCONC('"awk '/",STRINGIMAGE nam,'"/ {printf(_")co %s.spad\n_",$2)}' whofiles > temp.input") + OBEY '"cat docreport.input temp.input > temp1.input" + OBEY '"cat temp1.input docreport.trailer > docreport.input" + OBEY '"rm temp.input" + OBEY '"rm temp1.input" + SETQ(_/EDITFILE,'"docreport.input") + _/RQ() + +setOutStream nam == + filename := STRCONC('"/tmp/",STRINGIMAGE nam,".docreport") + $outStream := MAKE_-OUTSTREAM filename + +whoOwns(con) == + null $exposeFlag => nil +--con=constructor name (id beginning with a capital), returns owner as a string + filename := GETDATABASE(con,'SOURCEFILE) + quoteChar := char '_" + OBEY STRCONC('"awk '$2 == ",quoteChar,filename,quoteChar,'" {print $1}' whofiles > /tmp/temp") + instream := MAKE_-INSTREAM '"/tmp/temp" + value := + EOFP instream => nil + READLINE instream + SHUT instream + value + +--======================================================================= +-- Report Documentation Error +--======================================================================= +checkDocError1 u == +--when compiling for documentation, ignore certain errors + BOUNDP '$compileDocumentation and $compileDocumentation => nil + checkDocError u + +checkDocError u == + $checkErrorFlag := true + msg := + $recheckingFlag => + $constructorName => checkDocMessage u + concat('"> ",u) + $constructorName => checkDocMessage u + u + if $exposeFlag and $exposeFlagHeading then + SAYBRIGHTLY1($exposeFlagHeading,$outStream) + sayBrightly $exposeFlagHeading + $exposeFlagHeading := nil + sayBrightly msg + if $exposeFlag then SAYBRIGHTLY1(msg,$outStream) + --if called by checkDocFile (see file checkdoc.boot) + +checkDocMessage u == + sourcefile := GETDATABASE($constructorName,'SOURCEFILE) + person := whoOwns $constructorName or '"---" + middle := + BOUNDP '$x => ['"(",$x,'"): "] + ['": "] + concat(person,'">",sourcefile,'"-->",$constructorName,middle,u) + +checkDecorateForHt u == + count := 0 + spadflag := false --means OK to wrap single letter words with \s{} + while u repeat + x := first u + do + if x = '"\em" then + if count > 0 then spadflag := count - 1 + else checkDocError ['"\em must be enclosed in braces"] + if member(x,'("\s" "\spadop" "\spadtype" "\spad" "\spadpaste" "\spadcommand" "\footnote")) then spadflag := count + else if x = $charLbrace then count := count + 1 + else if x = $charRbrace then + count := count - 1 + if spadflag = count then spadflag := false + else if not spadflag and member(x,'("+" "*" "=" "==" "->")) then + if $checkingXmptex? then + checkDocError ["Symbol ",x,'" appearing outside \spad{}"] + x = '"$" or x = '"%" => checkDocError ['"Unescaped ",x] +-- null spadflag and STRINGP x and (member(x,$argl) or #x = 1 +-- and ALPHA_-CHAR_-P x.0) and not member(x,'("a" "A")) => +-- checkDocError1 ['"Naked ",x] +-- null spadflag and STRINGP x and (not x.0 = $charBack and not DIGITP(x.0) and DIGITP(x.(MAXINDEX x))or member(x,'("true" "false"))) +-- => checkDocError1 ["Naked ",x] + u := rest u + u + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot deleted file mode 100644 index 2d5e74ca..00000000 --- a/src/interp/cattable.boot +++ /dev/null @@ -1,501 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -hasCat(domainOrCatName,catName) == - catName='Object or catName='Type -- every domain is a Type (Object) - or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) - -showCategoryTable con == - [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* - | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] - -displayCategoryTable(:options) == - conList := IFCAR options - SETQ($ct,MAKE_-HASHTABLE 'ID) - for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat - HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)]) - for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat - sayMSG [:bright id,'"extends:"] - PRINT HGET($ct,id) - -genCategoryTable() == - SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) - SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL) - genTempCategoryTable() - domainList:= - [con for con in allConstructors() - | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] - domainTable:= [addDomainToTable(con,getConstrCat catl) for con - in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] - -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT - specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) - domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) - for id in specialDs], :domainTable] - for [id,:entry] in domainTable repeat - for [a,:b] in encodeCategoryAlist(id,entry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b) - simpTempCategoryTable() - compressHashTable _*ANCESTORS_-HASH_* - simpCategoryTable() - compressHashTable _*HASCATEGORY_-HASH_* - -simpTempCategoryTable() == - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACA(u,SUBST('Type,'Object,a)) - RPLACD(u,simpHasPred b) - -simpCategoryTable() == main where - main == - for key in HKEYS _*HASCATEGORY_-HASH_* repeat - entry := HGET(_*HASCATEGORY_-HASH_*,key) - null entry => HREM(_*HASCATEGORY_-HASH_*,key) - change := - atom opOf entry => simpHasPred entry - [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] - HPUT(_*HASCATEGORY_-HASH_*,key,change) - -simpHasPred(pred,:options) == main where - main == - $hasArgs: local := IFCDR IFCAR options - simp pred - simp pred == - pred is [op,:r] => - op = 'has => simpHas(pred,first r,first rest r) - op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r] - op = 'HasSignature => - [op,sig] := simpDevaluate CADR r - ['has,CAR r,['SIGNATURE,op,sig]] - op = 'HasAttribute => - form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]] - simpHasAttribute(form,a,b) - MEMQ(op,'(AND OR NOT)) => - null (u := MKPF([simp p for p in r],op)) => nil - u is '(QUOTE T) => true - simpBool u - op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) - null r and opOf op = 'has => simp first pred - pred is '(QUOTE T) => true - op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] - simp first pred --REMOVE THIS HACK !!!! - pred in '(T etc) => pred - null pred => nil - pred - simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) - simpHas(pred,a,b) == - b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr) - b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) - IDENTP a or hasIdent b => pred - npred := eval pred - IDENTP npred or null hasIdent npred => npred - pred - eval (pred := ['has,d,cat]) == - x := hasCat(CAR d,CAR cat) - y := CDR cat => - npred := or/[p for [args,:p] in x | y = args] => simp npred - false --if not there, it is false - x - -simpHasSignature(pred,conform,op,sig) == --eval w/o loading - IDENTP conform => pred - [conname,:args] := conform - n := #sig - u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) - candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false - match := or/[x for (x := [sig1,:.]) in candidates - | sig = sublisFormal(args,sig1)] or return false - simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) - -simpHasAttribute(pred,conform,attr) == --eval w/o loading - IDENTP conform => pred - conname := opOf conform - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - simpCatHasAttribute(conform,attr) - asharpConstructorName? conname => - p := LASSOC(attr,GETDATABASE(conname,'attributes)) => - simpHasPred sublisFormal(rest conform,p) - infovec := dbInfovec conname - k := LASSOC(attr,infovec.2) or return nil --if not listed then false - k = 0 => true - $domain => kTestPred k --from koOps - predvec := $predvec or sublisFormal(rest conform, - GETDATABASE(conname,'PREDICATES)) - simpHasPred predvec.(k - 1) - -simpCatHasAttribute(domform,attr) == - conform := getConstructorForm opOf domform - catval := EVAL mkEvalable conform - if atom KDR attr then attr := IFCAR attr - pred := - u := LASSOC(attr,catval . 2) => first u - return false --exit: not there - pred = true => true - EVAL SUBLISLIS(rest domform,rest conform,pred) - -hasIdent pred == - pred is [op,:r] => - op = 'QUOTE => false - or/[hasIdent x for x in r] - pred = '_$ => false - IDENTP pred => true - false - -addDomainToTable(id,catl) == - alist:= nil - for cat in catl repeat - cat is ['CATEGORY,:.] => nil - cat is ['IF,pred,cat1,:.] => - newAlist:= - [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] - alist:= [:alist,:newAlist] - alist:= [:alist,:getCategoryExtensionAlist0 cat] - [id,:alist] - -domainHput(table,key:=[id,:a],b) == - HPUT(table,key,b) - -genTempCategoryTable() == - --generates hashtable with key=categoryName and value of the form - -- ((form . pred) ..) meaning that - -- "IF pred THEN ofCategory(key,form)" - -- where form can involve #1, #2, ... the parameters of key - for con in allConstructors() repeat - GETDATABASE(con,'CONSTRUCTORKIND) = 'category => - addToCategoryTable con - for id in HKEYS _*ANCESTORS_-HASH_* repeat - item := HGET(_*ANCESTORS_-HASH_*, id) - for (u:=[.,:b]) in item repeat - RPLACD(u,simpCatPredicate simpBool b) - HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) - -addToCategoryTable con == - -- adds an entry to $tempCategoryTable with key=con and alist entries - u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain - alist := getCategoryExtensionAlist u - HPUT(_*ANCESTORS_-HASH_*,first u,alist) - alist - -encodeCategoryAlist(id,alist) == - newAl:= nil - for [a,:b] in alist repeat - [key,:argl] := a - newEntry:= - argl => [[argl,:b]] - b - u:= ASSOC(key,newAl) => - argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) - if newEntry ^= rest u then - p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) - sayMSG '"Duplicate entries:" - PRINT [newEntry,rest u] - newAl:= [[key,:newEntry],:newAl] - newAl - -encodeUnion(id,new:=[a,:b],alist) == - u := ASSOC(a,alist) => - RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) - alist - [new,:alist] - -moreGeneralCategoryPredicate(id,new,old) == - old = 'T or new = 'T => 'T - old is ['has,a,b] and new is ['has,=a,c] => - tempExtendsCat(b,c) => new - tempExtendsCat(c,b) => old - ['OR,old,new] - mkCategoryOr(new,old) - -mkCategoryOr(new,old) == - old is ['OR,:l] => simpCategoryOr(new,l) - ['OR,old,new] - -simpCategoryOr(new,l) == - newExtendsAnOld:= false - anOldExtendsNew:= false - ['has,a,b] := new - newList:= nil - for pred in l repeat - pred is ['has,=a,c] => - tempExtendsCat(c,b) => anOldExtendsNew:= true - if tempExtendsCat(b,c) then newExtendsAnOld:= true - newList:= [pred,:newList] - newList:= [pred,:newList] - if not newExtendsAnOld then newList:= [new,:newList] - newList is [.] => first newList - ['OR,:newList] - -tempExtendsCat(b,c) == - or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] - -getCategoryExtensionAlist0 cform == - [[cform,:'T],:getCategoryExtensionAlist cform] - -getCategoryExtensionAlist cform == - --avoids substitution as much as possible - u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) - mkCategoryExtensionAlist cform - -formalSubstitute(form:=[.,:argl],u) == - isFormalArgumentList argl => u - EQSUBSTLIST(argl,$FormalMapVariableList,u) - -isFormalArgumentList argl == - and/[x=fa for x in argl for fa in $FormalMapVariableList] - -mkCategoryExtensionAlist cform == - not CONSP cform => nil - cop := first cform - MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform - catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) - extendsList:= nil - for [cat,:pred] in catlist repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - --- following code to handle Unions Records Mapping etc. -mkCategoryExtensionAlistBasic cform == - cop := first cform ---category:= eval cform - category := -- changed by RSS on 7/29/87 - macrop cop => eval cform - APPLY(cop, rest cform) - extendsList:= [[x,:'T] for x in category.4.0] - for [cat,pred,:.] in category.4.1 repeat - newList := getCategoryExtensionAlist0 cat - finalList := - pred = 'T => newList - [[a,:quickAnd(b,pred)] for [a,:b] in newList] - extendsList:= catPairUnion(extendsList,finalList,cop,cat) - extendsList - -catPairUnion(oldList,newList,op,cat) == - for pair in newList repeat - u:= ASSOC(first pair,oldList) => - rest u = rest pair => nil - RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == - quickOr(new,old) - oldList:= [pair,:oldList] - oldList - -simpCatPredicate p == - p is ['OR,:l] => - (u:= simpOrUnion l) is [p] => p - ['OR,:u] - p - -simpOrUnion l == - if l then simpOrUnion1(first l,simpOrUnion rest l) - else l - -simpOrUnion1(x,l) == - null l => [x] - p:= mergeOr(x,first l) => [p,:rest l] - [first l,:simpOrUnion1(x,rest l)] - -mergeOr(x,y) == - x is ['has,a,b] and y is ['has,=a,c] => - testExtend(b,c) => y - testExtend(c,b) => x - nil - nil - -testExtend(a:=[op,:argl],b) == - (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => - formalSubstitute(a,val) - nil - -getConstrCat(x) == --- gets a different representation of the constructorCategory from the --- lisplib, which is a list of named categories or conditions - x:= if x is ['Join,:y] then y else [x] - cats:= NIL - for y in x repeat - y is ['CATEGORY,.,:z] => - for zz in z repeat cats := makeCatPred(zz, cats, true) - cats:= CONS(y,cats) - cats:= nreverse cats - cats - - -makeCatPred(zz, cats, thePred) == - if zz is ['IF,curPred := ['has,z1,z2],ats,.] then - ats := if ats is ['PROGN,:atl] then atl else [ats] - for at in ats repeat - if at is ['ATTRIBUTE,z3] and not atom z3 and - constructor? CAR z3 then - cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) - at is ['IF, pred, :.] => - cats := makeCatPred(at, cats, curPred) - cats - -getConstructorExports(conform,:options) == categoryParts(conform, - GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) - -categoryParts(conform,category,:options) == main where - main == - cons? := IFCAR options --means to include constructors as well - $attrlist: local := nil - $oplist : local := nil - $conslist: local := nil - conname := opOf conform - for x in exportsOf(category) repeat build(x,true) - $attrlist := listSort(function GLESSEQP,$attrlist) - $oplist := listSort(function GLESSEQP,$oplist) - res := [$attrlist,:$oplist] - if cons? then res := [listSort(function GLESSEQP,$conslist),:res] - if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then - tvl := TAKE(#rest conform,$TriangleVariableList) - res := SUBLISLIS($FormalMapVariableList,tvl,res) - res - build(item,pred) == - item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] - --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) - item is ['ATTRIBUTE,attr] => - constructor? opOf attr => - $conslist := [[attr,:pred],:$conslist] - nil - opOf attr = 'nothing => 'skip - $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] - item is ['TYPE,op,type] => - $oplist := [[op,[type],:pred],:$oplist] - item is ['IF,pred1,s1,s2] => - build(s1,quickAnd(pred,pred1)) - s2 => build(s2,quickAnd(pred,['NOT,pred1])) - item is ['PROGN,:r] => for x in r repeat build(x,pred) - item in '(noBranch) => 'ok - null item => 'ok - systemError '"build error" - exportsOf(target) == - target is ['CATEGORY,.,:r] => r - target is ['Join,:r,f] => - for x in r repeat $conslist := [[x,:true],:$conslist] - exportsOf f - $conslist := [[target,:true],:$conslist] - nil - ---------------------> NEW DEFINITION (override in patches.lisp.pamphlet) -compressHashTable ht == --- compresses hash table ht, to give maximal sharing of cells - sayBrightlyNT '"compressing hash table..." - $found: local := MAKE_-HASHTABLE 'UEQUAL - for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil) - sayBrightly "done" - ht - -compressSexpr(x,left,right) == --- recursive version of compressHashTable - atom x => nil - u:= HGET($found,x) => - left => RPLACA(left,u) - right => RPLACD(right,u) - nil - compressSexpr(first x,x,nil) - compressSexpr(rest x,nil,x) - HPUT($found,x,x) - -squeezeList(l) == --- changes the list l, so that is has maximal sharing of cells - $found:local:= NIL - squeeze1 l - -squeeze1(l) == --- recursive version of squeezeList - x:= CAR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACA(l,y) - x:= CDR l - y:= - atom x => x - z:= member(x,$found) => CAR z - $found:= CONS(x,$found) - squeeze1 x - RPLACD(l,y) - -updateCategoryTable(cname,kind) == - $newcompMode = true => nil - $updateCatTableIfTrue => - kind = 'package => nil - kind = 'category => updateCategoryTableForCategory(cname) - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) ---+ - kind = 'domain and $NRTflag = true => - updateCategoryTableForDomain(cname,getConstrCat( - GETDATABASE(cname,'CONSTRUCTORCATEGORY))) - -updateCategoryTableForCategory(cname) == - clearTempCategoryTable([[cname,'category]]) - addToCategoryTable(cname) - for id in HKEYS _*ANCESTORS_-HASH_* repeat - for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat - RPLACD(u,simpCatPredicate simpBool b) - -updateCategoryTableForDomain(cname,category) == - clearCategoryTable(cname) - [cname,:domainEntry]:= addDomainToTable(cname,category) - for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat - HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b) - $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_* - compressHashTable _*HASCATEGORY_-HASH_* - -clearCategoryTable($cname) == - MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) - -clearCategoryTable1(key,val) == - (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) - nil - -clearTempCategoryTable(catNames) == - for key in HKEYS(_*ANCESTORS_-HASH_*) repeat - MEMQ(key,catNames) => nil - extensions:= nil - for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) - repeat - MEMQ(CAR catForm,catNames) => nil - extensions:= [extension,:extensions] - HPUT(_*ANCESTORS_-HASH_*,key,extensions) - - - - - - - - diff --git a/src/interp/cattable.boot.pamphlet b/src/interp/cattable.boot.pamphlet new file mode 100644 index 00000000..d25eaf80 --- /dev/null +++ b/src/interp/cattable.boot.pamphlet @@ -0,0 +1,527 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp cattable.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +hasCat(domainOrCatName,catName) == + catName='Object or catName='Type -- every domain is a Type (Object) + or GETDATABASE([domainOrCatName,:catName],'HASCATEGORY) + +showCategoryTable con == + [[b,:val] for (key :=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* + | a = con and (val := HGET(_*HASCATEGORY_-HASH_*,key))] + +displayCategoryTable(:options) == + conList := IFCAR options + SETQ($ct,MAKE_-HASHTABLE 'ID) + for (key:=[a,:b]) in HKEYS _*HASCATEGORY_-HASH_* repeat + HPUT($ct,a,[[b,:HGET(_*HASCATEGORY_-HASH_*,key)],:HGET($ct,a)]) + for id in HKEYS $ct | null conList or MEMQ(id,conList) repeat + sayMSG [:bright id,'"extends:"] + PRINT HGET($ct,id) + +genCategoryTable() == + SETQ(_*ANCESTORS_-HASH_*, MAKE_-HASHTABLE 'ID) + SETQ(_*HASCATEGORY_-HASH_*,MAKE_-HASHTABLE 'UEQUAL) + genTempCategoryTable() + domainList:= + [con for con in allConstructors() + | GETDATABASE(con,'CONSTRUCTORKIND) = 'domain] + domainTable:= [addDomainToTable(con,getConstrCat catl) for con + in domainList | catl := GETDATABASE(con,'CONSTRUCTORCATEGORY)] + -- $nonLisplibDomains, $noCategoryDomains are set in BUILDOM BOOT + specialDs := SETDIFFERENCE($nonLisplibDomains,$noCategoryDomains) + domainTable:= [:[addDomainToTable(id, getConstrCat (eval [id]).3) + for id in specialDs], :domainTable] + for [id,:entry] in domainTable repeat + for [a,:b] in encodeCategoryAlist(id,entry) repeat + HPUT(_*HASCATEGORY_-HASH_*,[id,:a],b) + simpTempCategoryTable() + compressHashTable _*ANCESTORS_-HASH_* + simpCategoryTable() + compressHashTable _*HASCATEGORY_-HASH_* + +simpTempCategoryTable() == + for id in HKEYS _*ANCESTORS_-HASH_* repeat + for (u:=[a,:b]) in GETDATABASE(id,'ANCESTORS) repeat + RPLACA(u,SUBST('Type,'Object,a)) + RPLACD(u,simpHasPred b) + +simpCategoryTable() == main where + main == + for key in HKEYS _*HASCATEGORY_-HASH_* repeat + entry := HGET(_*HASCATEGORY_-HASH_*,key) + null entry => HREM(_*HASCATEGORY_-HASH_*,key) + change := + atom opOf entry => simpHasPred entry + [[x,:npred] for [x,:pred] in entry | npred := simpHasPred pred] + HPUT(_*HASCATEGORY_-HASH_*,key,change) + +simpHasPred(pred,:options) == main where + main == + $hasArgs: local := IFCDR IFCAR options + simp pred + simp pred == + pred is [op,:r] => + op = 'has => simpHas(pred,first r,first rest r) + op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r] + op = 'HasSignature => + [op,sig] := simpDevaluate CADR r + ['has,CAR r,['SIGNATURE,op,sig]] + op = 'HasAttribute => + form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]] + simpHasAttribute(form,a,b) + MEMQ(op,'(AND OR NOT)) => + null (u := MKPF([simp p for p in r],op)) => nil + u is '(QUOTE T) => true + simpBool u + op = 'hasArgs => ($hasArgs => $hasArgs = r; pred) + null r and opOf op = 'has => simp first pred + pred is '(QUOTE T) => true + op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] + simp first pred --REMOVE THIS HACK !!!! + pred in '(T etc) => pred + null pred => nil + pred + simpDevaluate a == EVAL SUBST('QUOTE,'devaluate,a) + simpHas(pred,a,b) == + b is ['ATTRIBUTE,attr] => simpHasAttribute(pred,a,attr) + b is ['SIGNATURE,op,sig] => simpHasSignature(pred,a,op,sig) + IDENTP a or hasIdent b => pred + npred := eval pred + IDENTP npred or null hasIdent npred => npred + pred + eval (pred := ['has,d,cat]) == + x := hasCat(CAR d,CAR cat) + y := CDR cat => + npred := or/[p for [args,:p] in x | y = args] => simp npred + false --if not there, it is false + x + +simpHasSignature(pred,conform,op,sig) == --eval w/o loading + IDENTP conform => pred + [conname,:args] := conform + n := #sig + u := LASSOC(op,GETDATABASE(conname,'OPERATIONALIST)) + candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false + match := or/[x for (x := [sig1,:.]) in candidates + | sig = sublisFormal(args,sig1)] or return false + simpHasPred(match is [sig,.,:p] and sublisFormal(args,p) or true) + +simpHasAttribute(pred,conform,attr) == --eval w/o loading + IDENTP conform => pred + conname := opOf conform + GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + simpCatHasAttribute(conform,attr) + asharpConstructorName? conname => + p := LASSOC(attr,GETDATABASE(conname,'attributes)) => + simpHasPred sublisFormal(rest conform,p) + infovec := dbInfovec conname + k := LASSOC(attr,infovec.2) or return nil --if not listed then false + k = 0 => true + $domain => kTestPred k --from koOps + predvec := $predvec or sublisFormal(rest conform, + GETDATABASE(conname,'PREDICATES)) + simpHasPred predvec.(k - 1) + +simpCatHasAttribute(domform,attr) == + conform := getConstructorForm opOf domform + catval := EVAL mkEvalable conform + if atom KDR attr then attr := IFCAR attr + pred := + u := LASSOC(attr,catval . 2) => first u + return false --exit: not there + pred = true => true + EVAL SUBLISLIS(rest domform,rest conform,pred) + +hasIdent pred == + pred is [op,:r] => + op = 'QUOTE => false + or/[hasIdent x for x in r] + pred = '_$ => false + IDENTP pred => true + false + +addDomainToTable(id,catl) == + alist:= nil + for cat in catl repeat + cat is ['CATEGORY,:.] => nil + cat is ['IF,pred,cat1,:.] => + newAlist:= + [[a,:quickAnd(pred,b)] for [a,:b] in getCategoryExtensionAlist0 cat1] + alist:= [:alist,:newAlist] + alist:= [:alist,:getCategoryExtensionAlist0 cat] + [id,:alist] + +domainHput(table,key:=[id,:a],b) == + HPUT(table,key,b) + +genTempCategoryTable() == + --generates hashtable with key=categoryName and value of the form + -- ((form . pred) ..) meaning that + -- "IF pred THEN ofCategory(key,form)" + -- where form can involve #1, #2, ... the parameters of key + for con in allConstructors() repeat + GETDATABASE(con,'CONSTRUCTORKIND) = 'category => + addToCategoryTable con + for id in HKEYS _*ANCESTORS_-HASH_* repeat + item := HGET(_*ANCESTORS_-HASH_*, id) + for (u:=[.,:b]) in item repeat + RPLACD(u,simpCatPredicate simpBool b) + HPUT(_*ANCESTORS_-HASH_*,id,listSort(function GLESSEQP,item)) + +addToCategoryTable con == + -- adds an entry to $tempCategoryTable with key=con and alist entries + u := CAAR GETDATABASE(con,'CONSTRUCTORMODEMAP) --domain + alist := getCategoryExtensionAlist u + HPUT(_*ANCESTORS_-HASH_*,first u,alist) + alist + +encodeCategoryAlist(id,alist) == + newAl:= nil + for [a,:b] in alist repeat + [key,:argl] := a + newEntry:= + argl => [[argl,:b]] + b + u:= ASSOC(key,newAl) => + argl => RPLACD(u,encodeUnion(id,first newEntry,rest u)) + if newEntry ^= rest u then + p:= moreGeneralCategoryPredicate(id,newEntry,rest u) => RPLACD(u,p) + sayMSG '"Duplicate entries:" + PRINT [newEntry,rest u] + newAl:= [[key,:newEntry],:newAl] + newAl + +encodeUnion(id,new:=[a,:b],alist) == + u := ASSOC(a,alist) => + RPLACD(u,moreGeneralCategoryPredicate(id,b,rest u)) + alist + [new,:alist] + +moreGeneralCategoryPredicate(id,new,old) == + old = 'T or new = 'T => 'T + old is ['has,a,b] and new is ['has,=a,c] => + tempExtendsCat(b,c) => new + tempExtendsCat(c,b) => old + ['OR,old,new] + mkCategoryOr(new,old) + +mkCategoryOr(new,old) == + old is ['OR,:l] => simpCategoryOr(new,l) + ['OR,old,new] + +simpCategoryOr(new,l) == + newExtendsAnOld:= false + anOldExtendsNew:= false + ['has,a,b] := new + newList:= nil + for pred in l repeat + pred is ['has,=a,c] => + tempExtendsCat(c,b) => anOldExtendsNew:= true + if tempExtendsCat(b,c) then newExtendsAnOld:= true + newList:= [pred,:newList] + newList:= [pred,:newList] + if not newExtendsAnOld then newList:= [new,:newList] + newList is [.] => first newList + ['OR,:newList] + +tempExtendsCat(b,c) == + or/[first c = a for [[a,:.],:.] in GETDATABASE(first b,'ANCESTORS)] + +getCategoryExtensionAlist0 cform == + [[cform,:'T],:getCategoryExtensionAlist cform] + +getCategoryExtensionAlist cform == + --avoids substitution as much as possible + u:= GETDATABASE(first cform,'ANCESTORS) => formalSubstitute(cform,u) + mkCategoryExtensionAlist cform + +formalSubstitute(form:=[.,:argl],u) == + isFormalArgumentList argl => u + EQSUBSTLIST(argl,$FormalMapVariableList,u) + +isFormalArgumentList argl == + and/[x=fa for x in argl for fa in $FormalMapVariableList] + +mkCategoryExtensionAlist cform == + not CONSP cform => nil + cop := first cform + MEMQ(cop, $CategoryNames) => mkCategoryExtensionAlistBasic cform + catlist := formalSubstitute(cform, first getConstructorExports(cform, true)) + extendsList:= nil + for [cat,:pred] in catlist repeat + newList := getCategoryExtensionAlist0 cat + finalList := + pred = 'T => newList + [[a,:quickAnd(b,pred)] for [a,:b] in newList] + extendsList:= catPairUnion(extendsList,finalList,cop,cat) + extendsList + +-- following code to handle Unions Records Mapping etc. +mkCategoryExtensionAlistBasic cform == + cop := first cform +--category:= eval cform + category := -- changed by RSS on 7/29/87 + macrop cop => eval cform + APPLY(cop, rest cform) + extendsList:= [[x,:'T] for x in category.4.0] + for [cat,pred,:.] in category.4.1 repeat + newList := getCategoryExtensionAlist0 cat + finalList := + pred = 'T => newList + [[a,:quickAnd(b,pred)] for [a,:b] in newList] + extendsList:= catPairUnion(extendsList,finalList,cop,cat) + extendsList + +catPairUnion(oldList,newList,op,cat) == + for pair in newList repeat + u:= ASSOC(first pair,oldList) => + rest u = rest pair => nil + RPLACD(u,addConflict(rest pair,rest u)) where addConflict(new,old) == + quickOr(new,old) + oldList:= [pair,:oldList] + oldList + +simpCatPredicate p == + p is ['OR,:l] => + (u:= simpOrUnion l) is [p] => p + ['OR,:u] + p + +simpOrUnion l == + if l then simpOrUnion1(first l,simpOrUnion rest l) + else l + +simpOrUnion1(x,l) == + null l => [x] + p:= mergeOr(x,first l) => [p,:rest l] + [first l,:simpOrUnion1(x,rest l)] + +mergeOr(x,y) == + x is ['has,a,b] and y is ['has,=a,c] => + testExtend(b,c) => y + testExtend(c,b) => x + nil + nil + +testExtend(a:=[op,:argl],b) == + (u:= GETDATABASE(op,'ANCESTORS)) and (val:= LASSOC(b,u)) => + formalSubstitute(a,val) + nil + +getConstrCat(x) == +-- gets a different representation of the constructorCategory from the +-- lisplib, which is a list of named categories or conditions + x:= if x is ['Join,:y] then y else [x] + cats:= NIL + for y in x repeat + y is ['CATEGORY,.,:z] => + for zz in z repeat cats := makeCatPred(zz, cats, true) + cats:= CONS(y,cats) + cats:= nreverse cats + cats + + +makeCatPred(zz, cats, thePred) == + if zz is ['IF,curPred := ['has,z1,z2],ats,.] then + ats := if ats is ['PROGN,:atl] then atl else [ats] + for at in ats repeat + if at is ['ATTRIBUTE,z3] and not atom z3 and + constructor? CAR z3 then + cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'noBranch],cats) + at is ['IF, pred, :.] => + cats := makeCatPred(at, cats, curPred) + cats + +getConstructorExports(conform,:options) == categoryParts(conform, + GETDATABASE(opOf conform,'CONSTRUCTORCATEGORY),IFCAR options) + +categoryParts(conform,category,:options) == main where + main == + cons? := IFCAR options --means to include constructors as well + $attrlist: local := nil + $oplist : local := nil + $conslist: local := nil + conname := opOf conform + for x in exportsOf(category) repeat build(x,true) + $attrlist := listSort(function GLESSEQP,$attrlist) + $oplist := listSort(function GLESSEQP,$oplist) + res := [$attrlist,:$oplist] + if cons? then res := [listSort(function GLESSEQP,$conslist),:res] + if GETDATABASE(conname,'CONSTRUCTORKIND) = 'category then + tvl := TAKE(#rest conform,$TriangleVariableList) + res := SUBLISLIS($FormalMapVariableList,tvl,res) + res + build(item,pred) == + item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] + --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) + item is ['ATTRIBUTE,attr] => + constructor? opOf attr => + $conslist := [[attr,:pred],:$conslist] + nil + opOf attr = 'nothing => 'skip + $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] + item is ['TYPE,op,type] => + $oplist := [[op,[type],:pred],:$oplist] + item is ['IF,pred1,s1,s2] => + build(s1,quickAnd(pred,pred1)) + s2 => build(s2,quickAnd(pred,['NOT,pred1])) + item is ['PROGN,:r] => for x in r repeat build(x,pred) + item in '(noBranch) => 'ok + null item => 'ok + systemError '"build error" + exportsOf(target) == + target is ['CATEGORY,.,:r] => r + target is ['Join,:r,f] => + for x in r repeat $conslist := [[x,:true],:$conslist] + exportsOf f + $conslist := [[target,:true],:$conslist] + nil + +--------------------> NEW DEFINITION (override in patches.lisp.pamphlet) +compressHashTable ht == +-- compresses hash table ht, to give maximal sharing of cells + sayBrightlyNT '"compressing hash table..." + $found: local := MAKE_-HASHTABLE 'UEQUAL + for x in HKEYS ht repeat compressSexpr(HGET(ht,x),nil,nil) + sayBrightly "done" + ht + +compressSexpr(x,left,right) == +-- recursive version of compressHashTable + atom x => nil + u:= HGET($found,x) => + left => RPLACA(left,u) + right => RPLACD(right,u) + nil + compressSexpr(first x,x,nil) + compressSexpr(rest x,nil,x) + HPUT($found,x,x) + +squeezeList(l) == +-- changes the list l, so that is has maximal sharing of cells + $found:local:= NIL + squeeze1 l + +squeeze1(l) == +-- recursive version of squeezeList + x:= CAR l + y:= + atom x => x + z:= member(x,$found) => CAR z + $found:= CONS(x,$found) + squeeze1 x + RPLACA(l,y) + x:= CDR l + y:= + atom x => x + z:= member(x,$found) => CAR z + $found:= CONS(x,$found) + squeeze1 x + RPLACD(l,y) + +updateCategoryTable(cname,kind) == + $newcompMode = true => nil + $updateCatTableIfTrue => + kind = 'package => nil + kind = 'category => updateCategoryTableForCategory(cname) + updateCategoryTableForDomain(cname,getConstrCat( + GETDATABASE(cname,'CONSTRUCTORCATEGORY))) +--+ + kind = 'domain and $NRTflag = true => + updateCategoryTableForDomain(cname,getConstrCat( + GETDATABASE(cname,'CONSTRUCTORCATEGORY))) + +updateCategoryTableForCategory(cname) == + clearTempCategoryTable([[cname,'category]]) + addToCategoryTable(cname) + for id in HKEYS _*ANCESTORS_-HASH_* repeat + for (u:=[.,:b]) in GETDATABASE(id,'ANCESTORS) repeat + RPLACD(u,simpCatPredicate simpBool b) + +updateCategoryTableForDomain(cname,category) == + clearCategoryTable(cname) + [cname,:domainEntry]:= addDomainToTable(cname,category) + for [a,:b] in encodeCategoryAlist(cname,domainEntry) repeat + HPUT(_*HASCATEGORY_-HASH_*,[cname,:a],b) + $doNotCompressHashTableIfTrue = true => _*HASCATEGORY_-HASH_* + compressHashTable _*HASCATEGORY_-HASH_* + +clearCategoryTable($cname) == + MAPHASH('clearCategoryTable1,_*HASCATEGORY_-HASH_*) + +clearCategoryTable1(key,val) == + (CAR key=$cname)=> HREM(_*HASCATEGORY_-HASH_*,key) + nil + +clearTempCategoryTable(catNames) == + for key in HKEYS(_*ANCESTORS_-HASH_*) repeat + MEMQ(key,catNames) => nil + extensions:= nil + for (extension:= [catForm,:.]) in GETDATABASE(key,'ANCESTORS) + repeat + MEMQ(CAR catForm,catNames) => nil + extensions:= [extension,:extensions] + HPUT(_*ANCESTORS_-HASH_*,key,extensions) + + + + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/cfuns.lisp b/src/interp/cfuns.lisp deleted file mode 100644 index dbe77db4..00000000 --- a/src/interp/cfuns.lisp +++ /dev/null @@ -1,101 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn -; (system:define-foreign-function :c '|findString| :fixnum) - (system:define-foreign-function :c '|addtopath| :fixnum) - (system:define-foreign-function :c '|chdir| :fixnum) - (system:define-foreign-function :c '|writeablep| :fixnum) - (system:define-foreign-function :c '|directoryp| :fixnum) - (system:define-foreign-function :c '|copyEnvValue| :fixnum) - ) - -#+KCL -(progn - (defentry |directoryp| (string) (int "directoryp")) - (defentry |writeablep| (string) (int "writeablep")) -; (defentry |findString| (string string) (int "findString")) - ) - -#+:CCL -(defun |directoryp| (fn) - (cond ((not (probe-file fn)) -1) - ((directoryp fn) 1) - (t 0))) - - - -; (defun |findStringInFile| (str p) -; (|findString| (namestring p) str) ) - - -(defun |getEnv| (var-name) (system::getenv var-name)) - -;;stolen from AXIOM-XL src/strops.c -#+(AND KCL (NOT ELF)) -(Clines -"MYHASH(s)" -"char *s;" -"{" -" register unsigned int h = 0;" -" register int c;" -"" -" while ((c = *s++) != 0) {" -" h ^= (h << 8);" -" h += ((c) + 200041);" -" h &= 0x3FFFFFFF;" -" }" -" return h;" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashString| (string) (int "MYHASH")) -#+(AND KCL ELF) -(defun |hashString| (string) (system:|hashString| string)) - -#+(AND KCL (NOT ELF)) -(Clines -"int MYCOMBINE(i,j)" -"int i,j;" -"{" -"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" -"}" -) -#+(AND KCL (NOT ELF)) -(defentry |hashCombine| (int int) (int "MYCOMBINE")) -#+(AND KCL ELF) -(defun |hashCombine| (x y) (system:|hashCombine| x y)) - - diff --git a/src/interp/cfuns.lisp.pamphlet b/src/interp/cfuns.lisp.pamphlet new file mode 100644 index 00000000..d9bf72d5 --- /dev/null +++ b/src/interp/cfuns.lisp.pamphlet @@ -0,0 +1,123 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp cfuns.lisp} +\author{Timothy Daly} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn +; (system:define-foreign-function :c '|findString| :fixnum) + (system:define-foreign-function :c '|addtopath| :fixnum) + (system:define-foreign-function :c '|chdir| :fixnum) + (system:define-foreign-function :c '|writeablep| :fixnum) + (system:define-foreign-function :c '|directoryp| :fixnum) + (system:define-foreign-function :c '|copyEnvValue| :fixnum) + ) + +#+KCL +(progn + (defentry |directoryp| (string) (int "directoryp")) + (defentry |writeablep| (string) (int "writeablep")) +; (defentry |findString| (string string) (int "findString")) + ) + +#+:CCL +(defun |directoryp| (fn) + (cond ((not (probe-file fn)) -1) + ((directoryp fn) 1) + (t 0))) + + + +; (defun |findStringInFile| (str p) +; (|findString| (namestring p) str) ) + + +(defun |getEnv| (var-name) (system::getenv var-name)) + +;;stolen from AXIOM-XL src/strops.c +#+(AND KCL (NOT ELF)) +(Clines +"MYHASH(s)" +"char *s;" +"{" +" register unsigned int h = 0;" +" register int c;" +"" +" while ((c = *s++) != 0) {" +" h ^= (h << 8);" +" h += ((c) + 200041);" +" h &= 0x3FFFFFFF;" +" }" +" return h;" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashString| (string) (int "MYHASH")) +#+(AND KCL ELF) +(defun |hashString| (string) (system:|hashString| string)) + +#+(AND KCL (NOT ELF)) +(Clines +"int MYCOMBINE(i,j)" +"int i,j;" +"{" +"return ( (((((unsigned int)j) & 16777215) << 6)+((unsigned int)i)) % 1073741789);" +"}" +) +#+(AND KCL (NOT ELF)) +(defentry |hashCombine| (int int) (int "MYCOMBINE")) +#+(AND KCL ELF) +(defun |hashCombine| (x y) (system:|hashCombine| x y)) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/clam.boot b/src/interp/clam.boot deleted file mode 100644 index 3095753f..00000000 --- a/src/interp/clam.boot +++ /dev/null @@ -1,702 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - ---% Cache Lambda Facility --- for remembering previous values to functions - ---to CLAM a function f, there must be an entry on $clamList as follows: --- (functionName --the name of the function to be CLAMed (e.g. f) --- kind --"hash" or number of values to be stored in --- circular list --- eqEtc --the equal function to be used --- (EQ, EQUAL, UEQUAL,..) --- "shift" --(opt) for circular lists, shift most recently --- used to front --- "count") --(opt) use reference counts (see below) --- --- Notes: --- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL --- Functions with some other as kind hashed as property --- lists with eqEtc used to compare entries --- Functions which have 0 arguments may only be CLAMmed when kind is --- identifier other than hash (circular/private hashtable for no args --- makes no sense) --- --- Functions which have more than 1 argument must never be CLAMed with EQ --- since arguments are cached as lists --- For circular lists, "count" will do "shift"ing; entries with lowest --- use count are replaced --- For cache option without "count", all entries are cleared on garbage --- collection; For cache option with "count", --- entries have their use count set --- to 0 on garbage collection; those with 0 use count at garbage collection --- are cleared --- see definition of COMP,2 in COMP LISP which calls clamComp below - --- see SETQ LISP for initial def of $hashNode - -compClam(op,argl,body,$clamList) == - --similar to reportFunctionCompilation in SLAM BOOT - if $InteractiveMode then startTimingProcess 'compilation - if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options] - then keyedSystemError("S2GE0004",[op]) - $clamList:= nil --clear to avoid looping - if u:= S_-(options,'(shift count)) then - keyedSystemError("S2GE0006",[op,:u]) - shiftFl := MEMQ('shift,options) - countFl := MEMQ('count,options) - if #argl > 1 and eqEtc= 'EQ then - keyedSystemError("S2GE0007",[op]) - (not IDENTP kind) and (not INTEGERP kind or kind < 1) => - keyedSystemError("S2GE0005",[op]) - IDENTP kind => - shiftFl => keyedSystemError("S2GE0008",[op]) - compHash(op,argl,body,(kind='hash => nil; kind),eqEtc,countFl) - cacheCount:= kind - if null argl then keyedSystemError("S2GE0009",[op]) - phrase:= - cacheCount=1 => ['"computed value only"] - [:bright cacheCount,'"computed values"] - sayBrightly [:bright op,'"will save last",:phrase] - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - argl is [.] => [[g1],[auxfn,g1]] --g1 is a parameter - [g1,['APPLX,['function,auxfn],g1]] --g1 is a parameter list - cacheName:= INTERNL(op,'";AL") - if $reportCounts=true then - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - SET(hitCounter,0) - SET(callCounter,0) - callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] - hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - lookUpFunction:= - shiftFl => - countFl => 'assocCacheShiftCount - 'assocCacheShift - countFl => 'assocCacheCount - 'assocCache - returnFoundValue:= - countFl => ['CDDR,g3] - ['CDR,g3] - namePart:= - countFl => cacheName - MKQ cacheName - secondPredPair:= --- null argl => [cacheName] - [['SETQ,g3,[lookUpFunction,g1,namePart,eqEtc]], - :hitCountCode, - returnFoundValue] - resetCacheEntry:= - countFl => ['CONS,1,g2] - g2 - thirdPredPair:= --- null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3,['CAR,cacheName]], - ['RPLACA,g3,g1], - ['RPLACD,g3,resetCacheEntry], - g2] - codeBody:= ['PROG,[g2,g3], - :callCountCode, - ['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - - -- compile generated function stub - compileInteractive mainFunction - - -- compile main body: this has already been compTran'ed - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp computeFunction - compileQuietly [computeFunction] - - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['initCache,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= mkCacheVec(op,cacheName,cacheType, - cacheResetCode,cacheCountCode) - LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] - LAM_,EVALANDFILEACTQ cacheResetCode - if $InteractiveMode then stopTimingProcess 'compilation - op - -compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) == - --Note: when cacheNameOrNil^=nil, it names a global hashtable - --- cacheNameOrNil => compHashGlobal(op,argl,body,cacheNameOrNil,eqEtc,countFl) --- This branch to compHashGlobal is now omitted; as a result, --- entries will be stored on the global hashtable in a uniform way: --- (, ,:) --- where the reference count is optional - - if cacheNameOrNil and cacheNameOrNil^='_$ConstructorCache then - keyedSystemError("S2GE0010",[op]) - --restriction due to omission of call to hputNewValue (see *** lines below) - - if null argl then - null cacheNameOrNil => keyedSystemError("S2GE0011",[op]) - nil - (not cacheNameOrNil) and (not MEMQ(eqEtc,'(EQ CVEC UEQUAL))) => - keyedSystemError("S2GE0012",[op]) ---withWithout := (countFl => "with"; "without") ---middle:= --- cacheNameOrNil => ["on","%b",cacheNameOrNil,"%d"] --- '"privately " ---sayBrightly --- ["%b",op,"%d","hashes ",:middle,withWithout," reference counts"] - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,cacheArgKey,computeValue] := - -- arg: to be used as formal argument of lambda construction; - -- cacheArgKey: the form used to look up the value in the cache - -- computeValue: the form used to compute the value from arg - null argl => [nil,nil,[auxfn]] - argl is [.] => - key:= (cacheNameOrNil => ['devaluate,g1]; g1) - [[g1],['LIST,key],[auxfn,g1]] --g1 is a parameter - key:= (cacheNameOrNil => ['devaluateList,g1] ; g1) - [g1,key,['APPLY,['function,auxfn],g1]] --g1 is a parameter list - cacheName:= cacheNameOrNil or INTERNL(op,'";AL") - if $reportCounts=true then - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - SET(hitCounter,0) - SET(callCounter,0) - callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] - hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] - g2:= GENSYM() --value computed by calling function - returnFoundValue:= - null argl => - -- if we have a global hastable, functions with no arguments are - -- stored in the same format as those with several arguments, e.g. - -- to cache the value given by f(), the structure - -- ((nil )) is stored in the cache - countFl => ['CDRwithIncrement,['CDAR,g2]] - ['CDAR,g2] - countFl => ['CDRwithIncrement,g2] - g2 - getCode:= - null argl => ['HGET,cacheName,MKQ op] - cacheNameOrNil => - eqEtc^='EQUAL => - ['lassocShiftWithFunction,cacheArgKey, - ['HGET,cacheNameOrNil,MKQ op],MKQ eqEtc] - ['lassocShift,cacheArgKey,['HGET,cacheNameOrNil,MKQ op]] - ['HGET,cacheName,g1] - secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue] - putCode:= - null argl => - cacheNameOrNil => - countFl => ['CDDAR,['HPUT,cacheNameOrNil,MKQ op, - ['LIST,['CONS,nil,['CONS,1,computeValue]]]]] - ['HPUT,cacheNameOrNil,MKQ op,['LIST,['CONS,nil,computeValue]]] - systemError '"unexpected" - cacheNameOrNil => computeValue - --countFl => ['CDR,['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey, --*** - -- ['CONS,1,computeValue]]] --*** - --['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey,computeValue] --*** - countFl => ['CDR,['HPUT,cacheName,g1,['CONS,1,computeValue]]] - ['HPUT,cacheName,g1,computeValue] - if cacheNameOrNil then putCode := - ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]], - ['COND,[['NOT,g2],['HREM,cacheName,MKQ op]]]] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], - :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - - -- compile generated function stub - compileInteractive mainFunction - - -- compile main body: this has already been compTran'ed - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp computeFunction - compileQuietly [computeFunction] - - if null cacheNameOrNil then - cacheType:= - countFl => 'hash_-tableWithCounts - 'hash_-table - weakStrong:= (countFl => 'STRONG; 'WEAK) - --note: WEAK means that key/value pairs disappear at garbage collection - cacheResetCode:= - ['SETQ,cacheName,['MAKE_-HASHTABLE,MKQ eqEtc]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] - LAM_,EVALANDFILEACTQ cacheResetCode - op - -compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) == - --Note: when cacheNameOrNil^=nil, it names a global hashtable - - if (not MEMQ(eqEtc,'(UEQUAL))) then - sayBrightly "for hash option, only EQ, CVEC, and UEQUAL are allowed" - auxfn:= INTERNL(op,'";") - g1:= GENSYM() --argument or argument list - [arg,cacheArgKey,computeValue] := - -- arg: to be used as formal argument of lambda construction; - -- cacheArgKey: the form used to look up the value in the cache - -- computeValue: the form used to compute the value from arg - application:= - null argl => [auxfn] - argl is [.] => [auxfn,g1] --g1 is a parameter - ['APPLX,['function,auxfn],g1] --g1 is a parameter list - [g1,['consForHashLookup,MKQ op,g1],application] - g2:= GENSYM() --value computed by calling function - returnFoundValue:= - countFl => ['CDRwithIncrement,g2] - g2 - getCode:= ['HGET,cacheName,cacheArgKey] - secondPredPair:= [['SETQ,g2,getCode],returnFoundValue] - putForm:= ['CONS,MKQ op,g1] - putCode:= - countFl => ['HPUT,cacheName,putForm,['CONS,1,computeValue]] - ['HPUT,cacheName,putForm,computeValue] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], ['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [op,lamex] - computeFunction:= [auxfn,['LAMBDA,argl,:body]] - compileInteractive mainFunction - compileInteractive computeFunction - op - -consForHashLookup(a,b) == - RPLACA($hashNode,a) - RPLACD($hashNode,b) - $hashNode - -CDRwithIncrement x == - RPLACA(x,QSADD1 CAR x) - CDR x - -HGETandCount(hashTable,prop) == - u:= HGET(hashTable,prop) or return nil - RPLACA(u,QSADD1 CAR u) - u - -clearClams() == - for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat - clearClam fn - -clearClam fn == - infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) - eval infovec.cacheReset - -reportAndClearClams() == - cacheStats() - clearClams() - -clearConstructorCaches() == - clearCategoryCaches() - CLRHASH $ConstructorCache - -clearConstructorCache(cname) == - (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => - kind = 'category => clearCategoryCache cname - HREM($ConstructorCache,cname) - -clearConstructorAndLisplibCaches() == - clearClams() - clearConstructorCaches() - -clearCategoryCaches() == - for name in allConstructors() repeat - if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then - if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL")) - then SET(cacheName,nil) - if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT")) - then SET(cacheName,nil) - -clearCategoryCache catName == - cacheName:= INTERNL STRCONC(PNAME catName,'";AL") - SET(cacheName,nil) - -displayHashtable x == - l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) - for [a,b] in l repeat - sayBrightlyNT ['%b,a,'%d] - pp b - -cacheStats() == - for [fn,kind,:u] in $clamList repeat - not MEMQ('count,u) => - sayBrightly ["%b",fn,"%d","does not keep reference counts"] - INTEGERP kind => reportCircularCacheStats(fn,kind) - kind = 'hash => reportHashCacheStats fn - sayBrightly ["Unknown cache type for","%b",fn,"%d"] - -reportCircularCacheStats(fn,n) == - infovec:= GETL(fn,'cacheInfo) - circList:= eval infovec.cacheName - numberUsed := - +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]] - sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] - displayCacheFrequency mkCircularCountAlist(circList,n) - TERPRI() - -displayCacheFrequency al == - al := NREVERSE SORTBY('CAR,al) - sayBrightlyNT " #hits/#occurrences: " - for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] - TERPRI() - -mkCircularCountAlist(cl,len) == - for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat - u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) - if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then - sayBrightlyNT [" ",count," "] - pp x - al:= [[count,:1],:al] - al - -reportHashCacheStats fn == - infovec:= GETL(fn,'cacheInfo) - hashTable:= eval infovec.cacheName - hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] - sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] - displayCacheFrequency mkHashCountAlist hashValues - TERPRI() - -mkHashCountAlist vl == - for [count,:.] in vl repeat - u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) - al:= [[count,:1],:al] - al - -clearHashReferenceCounts() == - --free all cells with 0 reference counts; clear other counts to 0 - for x in $clamList repeat - x.cacheType='hash_-tableWithCounts => - remHashEntriesWith0Count eval x.cacheName - x.cacheType='hash_-table => CLRHASH eval x.cacheName - -remHashEntriesWith0Count $hashTable == - MAPHASH(fn,$hashTable) where fn(key,obj) == - CAR obj = 0 => HREM($hashTable,key) --free store - nil - -initCache n == - tail:= '(0 . $failed) - l:= [[$failed,:tail] for i in 1..n] - RPLACD(LASTNODE l,l) - -assocCache(x,cacheName,fn) == - --fn=equality function; do not SHIFT or COUNT - al:= eval cacheName - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - FUNCALL(fn,CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - backPointer:= forwardPointer - forwardPointer:= CDR forwardPointer - val => val - SET(cacheName,backPointer) - nil - -assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular - --fn=equality function; SHIFT but do not COUNT - al:= eval cacheName - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => - if not EQ(forwardPointer,al) then --shift referenced entry to front - RPLACA(forwardPointer,CAR al) - RPLACA(al,y) - return (val:= y) - backPointer := forwardPointer --CAR is slot replaced on failure - forwardPointer:= CDR forwardPointer - val => val - SET(cacheName,backPointer) - nil - -assocCacheShiftCount(x,al,fn) == - -- if x is found, entry containing x becomes first element of list; if - -- x is not found, entry with smallest use count is shifted to front so - -- as to be replaced - --fn=equality function; COUNT and SHIFT - forwardPointer:= al - val:= nil - minCount:= 10000 --preset minCount but not newFrontPointer here - until EQ(forwardPointer,al) repeat - FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => - newFrontPointer := forwardPointer - RPLAC(CADR y,QSADD1 CADR y) --increment use count - return (val:= y) - if QSLESSP(c := CADR y,minCount) then --initial c is 1 so is true 1st time - minCount := c - newFrontPointer := forwardPointer --CAR is slot replaced on failure - forwardPointer:= CDR forwardPointer - if not EQ(newFrontPointer,al) then --shift referenced entry to front - temp:= CAR newFrontPointer --or entry with smallest count - RPLACA(newFrontPointer,CAR al) - RPLACA(al,temp) - val - -clamStats() == - for [op,kind,:.] in $clamList repeat - cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats" - prefix:= - $reportCounts^= true => nil - hitCounter:= INTERNL(op,'";hit") - callCounter:= INTERNL(op,'";calls") - res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "] - SET(hitCounter,0) - SET(callCounter,0) - res - postString:= - cacheValue:= eval cacheVec.cacheName - kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"] - empties:= numberOfEmptySlots eval cacheVec.cacheName - empties = 0 => nil - [" (","%b",kind-empties,"/",kind,"%d","slots used)"] - sayBrightly - [:prefix,op,:postString] - -numberOfEmptySlots cache== - count:= (CAAR cache ='$failed => 1; 0) - for x in tails rest cache while NE(x,cache) repeat - if CAAR x='$failed then count:= count+1 - count - -addToSlam([name,:argnames],shell) == - $mutableDomain => return nil - null argnames => addToConstructorCache(name,nil,shell) - args:= ['LIST,:[mkDevaluate a for a in argnames]] - addToConstructorCache(name,args,shell) - -addToConstructorCache(op,args,value) == - ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] - -haddProp(ht,op,prop,val) == - --called inside functors (except for union and record types ??) - --presently, ht always = $ConstructorCache - statRecordInstantiationEvent() - if $reportInstantiations = true or $reportEachInstantiation = true then - startTimingProcess 'debug - recordInstantiation(op,prop,false) - stopTimingProcess 'debug - u:= HGET(ht,op) => --hope that one exists most of the time - ASSOC(prop,u) => val --value is already there--must = val; exit now - RPLACD(u,[CAR u,:CDR u]) - RPLACA(u,[prop,:val]) - $op: local := op - listTruncate(u,20) --save at most 20 instantiations - val - HPUT(ht,op,[[prop,:val]]) - val - -recordInstantiation(op,prop,dropIfTrue) == - startTimingProcess 'debug - recordInstantiation1(op,prop,dropIfTrue) - stopTimingProcess 'debug - -recordInstantiation1(op,prop,dropIfTrue) == - op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now - if $reportEachInstantiation = true then - trailer:= (dropIfTrue => '" dropped"; '" instantiated") - if $insideCoerceInteractive= true then - $instantCoerceCount:= 1+$instantCoerceCount - if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then - $instantCanCoerceCount:= 1+$instantCanCoerceCount - xtra:= - ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] - if $insideEvalMmCondIfTrue = true and null dropIfTrue then - $instantMmCondCount:= $instantMmCondCount + 1 - typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] - null $reportInstantiations => nil - u:= HGET($instantRecord,op) => --hope that one exists most of the time - v := LASSOC(prop,u) => - dropIfTrue => RPLAC(CDR v,1+CDR v) - RPLAC(CAR v,1+CAR v) - RPLACD(u,[CAR u,:CDR u]) - val := - dropIfTrue => [0,:1] - [1,:0] - RPLACA(u,[prop,:val]) - val := - dropIfTrue => [0,:1] - [1,:0] - HPUT($instantRecord,op,[[prop,:val]]) - -reportInstantiations() == - --assumed to be a hashtable with reference counts - conList:= - [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)] - for key in HKEYS $instantRecord] - sayBrightly ['"# instantiated/# dropped/domain name", - "%l",'"------------------------------------"] - nTotal:= mTotal:= rTotal := nForms:= 0 - for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat - nTotal:= nTotal+n; mTotal:= mTotal+m - if n > 1 then rTotal:= rTotal + n-1 - nForms:= nForms + 1 - typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] - sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", - '" ",$instantCoerceCount,'" inside coerceInteractive","%l", - '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", - '" ",$instantMmCondCount,'" inside evalMmCond","%l", - '" ",rTotal,'" reinstantiated","%l", - '" ",mTotal,'" dropped","%l", - '" ",nForms,'" distinct domains instantiated/dropped"] - -hputNewProp(ht,op,argList,val) == - --NOTE: obselete if lines *** are commented out - -- Warning!!! This function should only be called for - -- $ConstructorCache slamming --- since it maps devaluate onto prop, an - -- argument list - -- - -- This function may be called when property is already there; for - -- example, Polynomial applied to '(Integer), not finding it in the - -- cache will invoke Polynomial to compute it; inside of Polynomial is - -- a call to this function which will hputNewProp the property onto the - -- cache so that when this function is called by the outer Polynomial, - -- the value will always be there - - prop:= [devaluate x for x in argList] - haddProp(ht,op,prop,val) - -listTruncate(l,n) == - u:= l - n:= QSSUB1 n - while NEQ(n,0) and null atom u repeat - n:= QSSUB1 n - u:= QCDR u - if null atom u then - if null atom rest u and $reportInstantiations = true then - recordInstantiation($op,CAADR u,true) - RPLACD(u,nil) - l - -lassocShift(x,l) == - y:= l - while not atom y repeat - EQUAL(x,CAR QCAR y) => return (result := QCAR y) - y:= QCDR y - result => - if NEQ(y,l) then - QRPLACA(y,CAR l) - QRPLACA(l,result) - QCDR result - nil - -lassocShiftWithFunction(x,l,fn) == - y:= l - while not atom y repeat - FUNCALL(fn,x,CAR QCAR y) => return (result := QCAR y) - y:= QCDR y - result => - if NEQ(y,l) then - QRPLACA(y,CAR l) - QRPLACA(l,result) - QCDR result - nil - -lassocShiftQ(x,l) == - y:= l - while not atom y repeat - EQ(x,CAR CAR y) => return (result := CAR y) - y:= CDR y - result => - if NEQ(y,l) then - RPLACA(y,CAR l) - RPLACA(l,result) - CDR result - nil - --- rassocShiftQ(x,l) == --- y:= l --- while not atom y repeat --- EQ(x,CDR CAR y) => return (result := CAR y) --- y:= CDR y --- result => --- if NEQ(y,l) then --- RPLACA(y,CAR l) --- RPLACA(l,result) --- CAR result --- nil - -globalHashtableStats(x,sortFn) == - --assumed to be a hashtable with reference counts - keys:= HKEYS x - for key in keys repeat - u:= HGET(x,key) - for [argList,n,:.] in u repeat - not INTEGERP n => keyedSystemError("S2GE0013",[x]) - argList1:= [constructor2ConstructorForm x for x in argList] - reportList:= [[n,key,argList1],:reportList] - sayBrightly ["%b"," USE NAME ARGS","%d"] - for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat - sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "] - pp args - -constructor2ConstructorForm x == - VECP x => x.0 - x - -rightJustifyString(x,maxWidth) == - size:= entryWidth x - size > maxWidth => keyedSystemError("S2GE0014",[x]) - [fillerSpaces(maxWidth-size," "),x] - -domainEqualList(argl1,argl2) == - --function used to match argument lists of constructors - while argl1 and argl2 repeat - item1:= devaluate CAR argl1 - item2:= CAR argl2 - partsMatch:= - item1 = item2 => true - false - null partsMatch => return nil - argl1:= rest argl1; argl2 := rest argl2 - argl1 or argl2 => nil - true - -removeAllClams() == - for [fun,:.] in $clamList repeat - sayBrightly ['"Un-clamming function",'%b,fun,'%d] - SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) diff --git a/src/interp/clam.boot.pamphlet b/src/interp/clam.boot.pamphlet new file mode 100644 index 00000000..d811c00a --- /dev/null +++ b/src/interp/clam.boot.pamphlet @@ -0,0 +1,729 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{/src/interp/clam.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +--% Cache Lambda Facility +-- for remembering previous values to functions + +--to CLAM a function f, there must be an entry on $clamList as follows: +-- (functionName --the name of the function to be CLAMed (e.g. f) +-- kind --"hash" or number of values to be stored in +-- circular list +-- eqEtc --the equal function to be used +-- (EQ, EQUAL, UEQUAL,..) +-- "shift" --(opt) for circular lists, shift most recently +-- used to front +-- "count") --(opt) use reference counts (see below) +-- +-- Notes: +-- Functions with "hash" as kind must give EQ, CVEC, or UEQUAL +-- Functions with some other as kind hashed as property +-- lists with eqEtc used to compare entries +-- Functions which have 0 arguments may only be CLAMmed when kind is +-- identifier other than hash (circular/private hashtable for no args +-- makes no sense) +-- +-- Functions which have more than 1 argument must never be CLAMed with EQ +-- since arguments are cached as lists +-- For circular lists, "count" will do "shift"ing; entries with lowest +-- use count are replaced +-- For cache option without "count", all entries are cleared on garbage +-- collection; For cache option with "count", +-- entries have their use count set +-- to 0 on garbage collection; those with 0 use count at garbage collection +-- are cleared +-- see definition of COMP,2 in COMP LISP which calls clamComp below + +-- see SETQ LISP for initial def of $hashNode + +compClam(op,argl,body,$clamList) == + --similar to reportFunctionCompilation in SLAM BOOT + if $InteractiveMode then startTimingProcess 'compilation + if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options] + then keyedSystemError("S2GE0004",[op]) + $clamList:= nil --clear to avoid looping + if u:= S_-(options,'(shift count)) then + keyedSystemError("S2GE0006",[op,:u]) + shiftFl := MEMQ('shift,options) + countFl := MEMQ('count,options) + if #argl > 1 and eqEtc= 'EQ then + keyedSystemError("S2GE0007",[op]) + (not IDENTP kind) and (not INTEGERP kind or kind < 1) => + keyedSystemError("S2GE0005",[op]) + IDENTP kind => + shiftFl => keyedSystemError("S2GE0008",[op]) + compHash(op,argl,body,(kind='hash => nil; kind),eqEtc,countFl) + cacheCount:= kind + if null argl then keyedSystemError("S2GE0009",[op]) + phrase:= + cacheCount=1 => ['"computed value only"] + [:bright cacheCount,'"computed values"] + sayBrightly [:bright op,'"will save last",:phrase] + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + argl is [.] => [[g1],[auxfn,g1]] --g1 is a parameter + [g1,['APPLX,['function,auxfn],g1]] --g1 is a parameter list + cacheName:= INTERNL(op,'";AL") + if $reportCounts=true then + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + SET(hitCounter,0) + SET(callCounter,0) + callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] + hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] + g2:= GENSYM() --length of cache or arg-value pair + g3:= GENSYM() --value computed by calling function + lookUpFunction:= + shiftFl => + countFl => 'assocCacheShiftCount + 'assocCacheShift + countFl => 'assocCacheCount + 'assocCache + returnFoundValue:= + countFl => ['CDDR,g3] + ['CDR,g3] + namePart:= + countFl => cacheName + MKQ cacheName + secondPredPair:= +-- null argl => [cacheName] + [['SETQ,g3,[lookUpFunction,g1,namePart,eqEtc]], + :hitCountCode, + returnFoundValue] + resetCacheEntry:= + countFl => ['CONS,1,g2] + g2 + thirdPredPair:= +-- null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] + ['(QUOTE T), + ['SETQ,g2,computeValue], + ['SETQ,g3,['CAR,cacheName]], + ['RPLACA,g3,g1], + ['RPLACD,g3,resetCacheEntry], + g2] + codeBody:= ['PROG,[g2,g3], + :callCountCode, + ['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + + -- compile generated function stub + compileInteractive mainFunction + + -- compile main body: this has already been compTran'ed + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp computeFunction + compileQuietly [computeFunction] + + cacheType:= 'function + cacheResetCode:= ['SETQ,cacheName,['initCache,cacheCount]] + cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] + cacheVector:= mkCacheVec(op,cacheName,cacheType, + cacheResetCode,cacheCountCode) + LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] + LAM_,EVALANDFILEACTQ cacheResetCode + if $InteractiveMode then stopTimingProcess 'compilation + op + +compHash(op,argl,body,cacheNameOrNil,eqEtc,countFl) == + --Note: when cacheNameOrNil^=nil, it names a global hashtable + +-- cacheNameOrNil => compHashGlobal(op,argl,body,cacheNameOrNil,eqEtc,countFl) +-- This branch to compHashGlobal is now omitted; as a result, +-- entries will be stored on the global hashtable in a uniform way: +-- (, ,:) +-- where the reference count is optional + + if cacheNameOrNil and cacheNameOrNil^='_$ConstructorCache then + keyedSystemError("S2GE0010",[op]) + --restriction due to omission of call to hputNewValue (see *** lines below) + + if null argl then + null cacheNameOrNil => keyedSystemError("S2GE0011",[op]) + nil + (not cacheNameOrNil) and (not MEMQ(eqEtc,'(EQ CVEC UEQUAL))) => + keyedSystemError("S2GE0012",[op]) +--withWithout := (countFl => "with"; "without") +--middle:= +-- cacheNameOrNil => ["on","%b",cacheNameOrNil,"%d"] +-- '"privately " +--sayBrightly +-- ["%b",op,"%d","hashes ",:middle,withWithout," reference counts"] + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,cacheArgKey,computeValue] := + -- arg: to be used as formal argument of lambda construction; + -- cacheArgKey: the form used to look up the value in the cache + -- computeValue: the form used to compute the value from arg + null argl => [nil,nil,[auxfn]] + argl is [.] => + key:= (cacheNameOrNil => ['devaluate,g1]; g1) + [[g1],['LIST,key],[auxfn,g1]] --g1 is a parameter + key:= (cacheNameOrNil => ['devaluateList,g1] ; g1) + [g1,key,['APPLY,['function,auxfn],g1]] --g1 is a parameter list + cacheName:= cacheNameOrNil or INTERNL(op,'";AL") + if $reportCounts=true then + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + SET(hitCounter,0) + SET(callCounter,0) + callCountCode:= [['SETQ,callCounter,['QSADD1,callCounter]]] + hitCountCode:= [['SETQ,hitCounter,['QSADD1,hitCounter]]] + g2:= GENSYM() --value computed by calling function + returnFoundValue:= + null argl => + -- if we have a global hastable, functions with no arguments are + -- stored in the same format as those with several arguments, e.g. + -- to cache the value given by f(), the structure + -- ((nil )) is stored in the cache + countFl => ['CDRwithIncrement,['CDAR,g2]] + ['CDAR,g2] + countFl => ['CDRwithIncrement,g2] + g2 + getCode:= + null argl => ['HGET,cacheName,MKQ op] + cacheNameOrNil => + eqEtc^='EQUAL => + ['lassocShiftWithFunction,cacheArgKey, + ['HGET,cacheNameOrNil,MKQ op],MKQ eqEtc] + ['lassocShift,cacheArgKey,['HGET,cacheNameOrNil,MKQ op]] + ['HGET,cacheName,g1] + secondPredPair:= [['SETQ,g2,getCode],:hitCountCode,returnFoundValue] + putCode:= + null argl => + cacheNameOrNil => + countFl => ['CDDAR,['HPUT,cacheNameOrNil,MKQ op, + ['LIST,['CONS,nil,['CONS,1,computeValue]]]]] + ['HPUT,cacheNameOrNil,MKQ op,['LIST,['CONS,nil,computeValue]]] + systemError '"unexpected" + cacheNameOrNil => computeValue + --countFl => ['CDR,['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey, --*** + -- ['CONS,1,computeValue]]] --*** + --['hputNewProp,cacheNameOrNil,MKQ op,cacheArgKey,computeValue] --*** + countFl => ['CDR,['HPUT,cacheName,g1,['CONS,1,computeValue]]] + ['HPUT,cacheName,g1,computeValue] + if cacheNameOrNil then putCode := + ['UNWIND_-PROTECT,['PROG1,putCode,['SETQ,g2,'T]], + ['COND,[['NOT,g2],['HREM,cacheName,MKQ op]]]] + thirdPredPair:= ['(QUOTE T),putCode] + codeBody:= ['PROG,[g2], + :callCountCode,['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + + -- compile generated function stub + compileInteractive mainFunction + + -- compile main body: this has already been compTran'ed + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp computeFunction + compileQuietly [computeFunction] + + if null cacheNameOrNil then + cacheType:= + countFl => 'hash_-tableWithCounts + 'hash_-table + weakStrong:= (countFl => 'STRONG; 'WEAK) + --note: WEAK means that key/value pairs disappear at garbage collection + cacheResetCode:= + ['SETQ,cacheName,['MAKE_-HASHTABLE,MKQ eqEtc]] + cacheCountCode:= ['hashCount,cacheName] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + LAM_,EVALANDFILEACTQ ['PUT, MKQ op, MKQ 'cacheInfo, MKQ cacheVector] + LAM_,EVALANDFILEACTQ cacheResetCode + op + +compHashGlobal(op,argl,body,cacheName,eqEtc,countFl) == + --Note: when cacheNameOrNil^=nil, it names a global hashtable + + if (not MEMQ(eqEtc,'(UEQUAL))) then + sayBrightly "for hash option, only EQ, CVEC, and UEQUAL are allowed" + auxfn:= INTERNL(op,'";") + g1:= GENSYM() --argument or argument list + [arg,cacheArgKey,computeValue] := + -- arg: to be used as formal argument of lambda construction; + -- cacheArgKey: the form used to look up the value in the cache + -- computeValue: the form used to compute the value from arg + application:= + null argl => [auxfn] + argl is [.] => [auxfn,g1] --g1 is a parameter + ['APPLX,['function,auxfn],g1] --g1 is a parameter list + [g1,['consForHashLookup,MKQ op,g1],application] + g2:= GENSYM() --value computed by calling function + returnFoundValue:= + countFl => ['CDRwithIncrement,g2] + g2 + getCode:= ['HGET,cacheName,cacheArgKey] + secondPredPair:= [['SETQ,g2,getCode],returnFoundValue] + putForm:= ['CONS,MKQ op,g1] + putCode:= + countFl => ['HPUT,cacheName,putForm,['CONS,1,computeValue]] + ['HPUT,cacheName,putForm,computeValue] + thirdPredPair:= ['(QUOTE T),putCode] + codeBody:= ['PROG,[g2], ['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [op,lamex] + computeFunction:= [auxfn,['LAMBDA,argl,:body]] + compileInteractive mainFunction + compileInteractive computeFunction + op + +consForHashLookup(a,b) == + RPLACA($hashNode,a) + RPLACD($hashNode,b) + $hashNode + +CDRwithIncrement x == + RPLACA(x,QSADD1 CAR x) + CDR x + +HGETandCount(hashTable,prop) == + u:= HGET(hashTable,prop) or return nil + RPLACA(u,QSADD1 CAR u) + u + +clearClams() == + for [fn,kind,:.] in $clamList | kind = 'hash or INTEGERP kind repeat + clearClam fn + +clearClam fn == + infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) + eval infovec.cacheReset + +reportAndClearClams() == + cacheStats() + clearClams() + +clearConstructorCaches() == + clearCategoryCaches() + CLRHASH $ConstructorCache + +clearConstructorCache(cname) == + (kind := GETDATABASE(cname,'CONSTRUCTORKIND)) => + kind = 'category => clearCategoryCache cname + HREM($ConstructorCache,cname) + +clearConstructorAndLisplibCaches() == + clearClams() + clearConstructorCaches() + +clearCategoryCaches() == + for name in allConstructors() repeat + if GETDATABASE(name,'CONSTRUCTORKIND) = 'category then + if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";AL")) + then SET(cacheName,nil) + if BOUNDP(cacheName:= INTERNL STRCONC(PNAME name,'";CAT")) + then SET(cacheName,nil) + +clearCategoryCache catName == + cacheName:= INTERNL STRCONC(PNAME catName,'";AL") + SET(cacheName,nil) + +displayHashtable x == + l:= NREVERSE SORTBY('CAR,[[opOf HGET(x,key),key] for key in HKEYS x]) + for [a,b] in l repeat + sayBrightlyNT ['%b,a,'%d] + pp b + +cacheStats() == + for [fn,kind,:u] in $clamList repeat + not MEMQ('count,u) => + sayBrightly ["%b",fn,"%d","does not keep reference counts"] + INTEGERP kind => reportCircularCacheStats(fn,kind) + kind = 'hash => reportHashCacheStats fn + sayBrightly ["Unknown cache type for","%b",fn,"%d"] + +reportCircularCacheStats(fn,n) == + infovec:= GETL(fn,'cacheInfo) + circList:= eval infovec.cacheName + numberUsed := + +/[1 for i in 1..n for x in circList while x isnt [='_$failed,:.]] + sayBrightly ["%b",fn,"%d","has","%b",numberUsed,"%d","/ ",n," values cached"] + displayCacheFrequency mkCircularCountAlist(circList,n) + TERPRI() + +displayCacheFrequency al == + al := NREVERSE SORTBY('CAR,al) + sayBrightlyNT " #hits/#occurrences: " + for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "] + TERPRI() + +mkCircularCountAlist(cl,len) == + for [x,count,:.] in cl for i in 1..len while x ^= '_$failed repeat + u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) + if INTEGERP $reportFavoritesIfNumber and count >= $reportFavoritesIfNumber then + sayBrightlyNT [" ",count," "] + pp x + al:= [[count,:1],:al] + al + +reportHashCacheStats fn == + infovec:= GETL(fn,'cacheInfo) + hashTable:= eval infovec.cacheName + hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] + sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] + displayCacheFrequency mkHashCountAlist hashValues + TERPRI() + +mkHashCountAlist vl == + for [count,:.] in vl repeat + u:= ASSOC(count,al) => RPLACD(u,1 + CDR u) + al:= [[count,:1],:al] + al + +clearHashReferenceCounts() == + --free all cells with 0 reference counts; clear other counts to 0 + for x in $clamList repeat + x.cacheType='hash_-tableWithCounts => + remHashEntriesWith0Count eval x.cacheName + x.cacheType='hash_-table => CLRHASH eval x.cacheName + +remHashEntriesWith0Count $hashTable == + MAPHASH(fn,$hashTable) where fn(key,obj) == + CAR obj = 0 => HREM($hashTable,key) --free store + nil + +initCache n == + tail:= '(0 . $failed) + l:= [[$failed,:tail] for i in 1..n] + RPLACD(LASTNODE l,l) + +assocCache(x,cacheName,fn) == + --fn=equality function; do not SHIFT or COUNT + al:= eval cacheName + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + FUNCALL(fn,CAAR forwardPointer,x) => return (val:= CAR forwardPointer) + backPointer:= forwardPointer + forwardPointer:= CDR forwardPointer + val => val + SET(cacheName,backPointer) + nil + +assocCacheShift(x,cacheName,fn) == --like ASSOC except that al is circular + --fn=equality function; SHIFT but do not COUNT + al:= eval cacheName + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => + if not EQ(forwardPointer,al) then --shift referenced entry to front + RPLACA(forwardPointer,CAR al) + RPLACA(al,y) + return (val:= y) + backPointer := forwardPointer --CAR is slot replaced on failure + forwardPointer:= CDR forwardPointer + val => val + SET(cacheName,backPointer) + nil + +assocCacheShiftCount(x,al,fn) == + -- if x is found, entry containing x becomes first element of list; if + -- x is not found, entry with smallest use count is shifted to front so + -- as to be replaced + --fn=equality function; COUNT and SHIFT + forwardPointer:= al + val:= nil + minCount:= 10000 --preset minCount but not newFrontPointer here + until EQ(forwardPointer,al) repeat + FUNCALL(fn, CAR (y:=CAR forwardPointer),x) => + newFrontPointer := forwardPointer + RPLAC(CADR y,QSADD1 CADR y) --increment use count + return (val:= y) + if QSLESSP(c := CADR y,minCount) then --initial c is 1 so is true 1st time + minCount := c + newFrontPointer := forwardPointer --CAR is slot replaced on failure + forwardPointer:= CDR forwardPointer + if not EQ(newFrontPointer,al) then --shift referenced entry to front + temp:= CAR newFrontPointer --or entry with smallest count + RPLACA(newFrontPointer,CAR al) + RPLACA(al,temp) + val + +clamStats() == + for [op,kind,:.] in $clamList repeat + cacheVec:= GETL(op,'cacheInfo) or systemErrorHere "clamStats" + prefix:= + $reportCounts^= true => nil + hitCounter:= INTERNL(op,'";hit") + callCounter:= INTERNL(op,'";calls") + res:= ["%b",eval hitCounter,"/",eval callCounter,"%d","calls to "] + SET(hitCounter,0) + SET(callCounter,0) + res + postString:= + cacheValue:= eval cacheVec.cacheName + kind = 'hash => [" (","%b",HASH_-TABLE_-COUNT cacheValue,"%d","entries)"] + empties:= numberOfEmptySlots eval cacheVec.cacheName + empties = 0 => nil + [" (","%b",kind-empties,"/",kind,"%d","slots used)"] + sayBrightly + [:prefix,op,:postString] + +numberOfEmptySlots cache== + count:= (CAAR cache ='$failed => 1; 0) + for x in tails rest cache while NE(x,cache) repeat + if CAAR x='$failed then count:= count+1 + count + +addToSlam([name,:argnames],shell) == + $mutableDomain => return nil + null argnames => addToConstructorCache(name,nil,shell) + args:= ['LIST,:[mkDevaluate a for a in argnames]] + addToConstructorCache(name,args,shell) + +addToConstructorCache(op,args,value) == + ['haddProp,'$ConstructorCache,MKQ op,args,['CONS,1,value]] + +haddProp(ht,op,prop,val) == + --called inside functors (except for union and record types ??) + --presently, ht always = $ConstructorCache + statRecordInstantiationEvent() + if $reportInstantiations = true or $reportEachInstantiation = true then + startTimingProcess 'debug + recordInstantiation(op,prop,false) + stopTimingProcess 'debug + u:= HGET(ht,op) => --hope that one exists most of the time + ASSOC(prop,u) => val --value is already there--must = val; exit now + RPLACD(u,[CAR u,:CDR u]) + RPLACA(u,[prop,:val]) + $op: local := op + listTruncate(u,20) --save at most 20 instantiations + val + HPUT(ht,op,[[prop,:val]]) + val + +recordInstantiation(op,prop,dropIfTrue) == + startTimingProcess 'debug + recordInstantiation1(op,prop,dropIfTrue) + stopTimingProcess 'debug + +recordInstantiation1(op,prop,dropIfTrue) == + op in '(CategoryDefaults RepeatedSquaring) => nil--ignore defaults for now + if $reportEachInstantiation = true then + trailer:= (dropIfTrue => '" dropped"; '" instantiated") + if $insideCoerceInteractive= true then + $instantCoerceCount:= 1+$instantCoerceCount + if $insideCanCoerceFrom is [m1,m2] and null dropIfTrue then + $instantCanCoerceCount:= 1+$instantCanCoerceCount + xtra:= + ['" for ",outputDomainConstructor m1,'"-->",outputDomainConstructor m2] + if $insideEvalMmCondIfTrue = true and null dropIfTrue then + $instantMmCondCount:= $instantMmCondCount + 1 + typeTimePrin ["CONCAT",outputDomainConstructor [op,:prop],trailer,:xtra] + null $reportInstantiations => nil + u:= HGET($instantRecord,op) => --hope that one exists most of the time + v := LASSOC(prop,u) => + dropIfTrue => RPLAC(CDR v,1+CDR v) + RPLAC(CAR v,1+CAR v) + RPLACD(u,[CAR u,:CDR u]) + val := + dropIfTrue => [0,:1] + [1,:0] + RPLACA(u,[prop,:val]) + val := + dropIfTrue => [0,:1] + [1,:0] + HPUT($instantRecord,op,[[prop,:val]]) + +reportInstantiations() == + --assumed to be a hashtable with reference counts + conList:= + [:[[n,m,[key,:argList]] for [argList,n,:m] in HGET($instantRecord,key)] + for key in HKEYS $instantRecord] + sayBrightly ['"# instantiated/# dropped/domain name", + "%l",'"------------------------------------"] + nTotal:= mTotal:= rTotal := nForms:= 0 + for [n,m,form] in NREVERSE SORTBY('CADDR,conList) repeat + nTotal:= nTotal+n; mTotal:= mTotal+m + if n > 1 then rTotal:= rTotal + n-1 + nForms:= nForms + 1 + typeTimePrin ['CONCATB,n,m,outputDomainConstructor form] + sayBrightly ["%b",'"Totals:","%d",nTotal,'" instantiated","%l", + '" ",$instantCoerceCount,'" inside coerceInteractive","%l", + '" ",$instantCanCoerceCount,'" inside canCoerceFrom","%l", + '" ",$instantMmCondCount,'" inside evalMmCond","%l", + '" ",rTotal,'" reinstantiated","%l", + '" ",mTotal,'" dropped","%l", + '" ",nForms,'" distinct domains instantiated/dropped"] + +hputNewProp(ht,op,argList,val) == + --NOTE: obselete if lines *** are commented out + -- Warning!!! This function should only be called for + -- $ConstructorCache slamming --- since it maps devaluate onto prop, an + -- argument list + -- + -- This function may be called when property is already there; for + -- example, Polynomial applied to '(Integer), not finding it in the + -- cache will invoke Polynomial to compute it; inside of Polynomial is + -- a call to this function which will hputNewProp the property onto the + -- cache so that when this function is called by the outer Polynomial, + -- the value will always be there + + prop:= [devaluate x for x in argList] + haddProp(ht,op,prop,val) + +listTruncate(l,n) == + u:= l + n:= QSSUB1 n + while NEQ(n,0) and null atom u repeat + n:= QSSUB1 n + u:= QCDR u + if null atom u then + if null atom rest u and $reportInstantiations = true then + recordInstantiation($op,CAADR u,true) + RPLACD(u,nil) + l + +lassocShift(x,l) == + y:= l + while not atom y repeat + EQUAL(x,CAR QCAR y) => return (result := QCAR y) + y:= QCDR y + result => + if NEQ(y,l) then + QRPLACA(y,CAR l) + QRPLACA(l,result) + QCDR result + nil + +lassocShiftWithFunction(x,l,fn) == + y:= l + while not atom y repeat + FUNCALL(fn,x,CAR QCAR y) => return (result := QCAR y) + y:= QCDR y + result => + if NEQ(y,l) then + QRPLACA(y,CAR l) + QRPLACA(l,result) + QCDR result + nil + +lassocShiftQ(x,l) == + y:= l + while not atom y repeat + EQ(x,CAR CAR y) => return (result := CAR y) + y:= CDR y + result => + if NEQ(y,l) then + RPLACA(y,CAR l) + RPLACA(l,result) + CDR result + nil + +-- rassocShiftQ(x,l) == +-- y:= l +-- while not atom y repeat +-- EQ(x,CDR CAR y) => return (result := CAR y) +-- y:= CDR y +-- result => +-- if NEQ(y,l) then +-- RPLACA(y,CAR l) +-- RPLACA(l,result) +-- CAR result +-- nil + +globalHashtableStats(x,sortFn) == + --assumed to be a hashtable with reference counts + keys:= HKEYS x + for key in keys repeat + u:= HGET(x,key) + for [argList,n,:.] in u repeat + not INTEGERP n => keyedSystemError("S2GE0013",[x]) + argList1:= [constructor2ConstructorForm x for x in argList] + reportList:= [[n,key,argList1],:reportList] + sayBrightly ["%b"," USE NAME ARGS","%d"] + for [n,fn,args] in NREVERSE SORTBY(sortFn,reportList) repeat + sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "] + pp args + +constructor2ConstructorForm x == + VECP x => x.0 + x + +rightJustifyString(x,maxWidth) == + size:= entryWidth x + size > maxWidth => keyedSystemError("S2GE0014",[x]) + [fillerSpaces(maxWidth-size," "),x] + +domainEqualList(argl1,argl2) == + --function used to match argument lists of constructors + while argl1 and argl2 repeat + item1:= devaluate CAR argl1 + item2:= CAR argl2 + partsMatch:= + item1 = item2 => true + false + null partsMatch => return nil + argl1:= rest argl1; argl2 := rest argl2 + argl1 or argl2 => nil + true + +removeAllClams() == + for [fun,:.] in $clamList repeat + sayBrightly ['"Un-clamming function",'%b,fun,'%d] + SET(fun,eval INTERN STRCONC(STRINGIMAGE fun,'";")) +@ + + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/clammed.boot b/src/interp/clammed.boot deleted file mode 100644 index 82cbffe9..00000000 --- a/src/interp/clammed.boot +++ /dev/null @@ -1,207 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Functions on $clamList - --- These files are read in by the system so that they can be cached --- properly. Otherwise, must read in compiled versions and then --- recompile these, resulting in wasted BPI space. - -canCoerceFrom(mr,m) == - -- bind flag for recording/reporting instantiations - -- (see recordInstantiation) - $insideCanCoerceFrom: local := [mr,m] - canCoerceFrom0(mr,m) - -canCoerce(t1, t2) == - val := canCoerce1(t1, t2) => val - t1 is ['Variable, :.] => - newMode := getMinimalVarMode(t1, nil) - canCoerce1(t1, newMode) and canCoerce1(newMode, t2) - nil - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -coerceConvertMmSelection(funName,m1,m2) == - -- calls selectMms with $Coerce=NIL and tests for required - -- target type. funName is either 'coerce or 'convert. - $declaredMode : local:= NIL - $reportBottomUpFlag : local:= NIL - l := selectMms1(funName,m2,[m1],[m1],NIL) - mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and - isEqualOrSubDomain(m1, first rest rest sig)] - mmS and CAR mmS - -hasFileProperty(p,id,abbrev) == hasFilePropertyNoCache(p,id,abbrev) - -isValidType form == - -- returns true IFF form is a type whose arguments satisfy the - -- predicate of the type constructor - -- Note that some forms are said to be invalid because they would - -- cause problems with the interpreter. Thus things like P P I - -- are not valid. - STRINGP form => true - IDENTP form => false - form in '((Mode) (Domain) (SubDomain (Domain))) => true - form is ['Record,:selectors] => - and/[isValidType type for [:.,type] in selectors] - form is ['Enumeration,:args] => - null (and/[IDENTP x for x in args]) => false - ((# args) = (# REMDUP args)) => true - false - form is ['Mapping,:mapargs] => - null mapargs => NIL - and/[isValidType type for type in mapargs] - form is ['Union,:args] => - -- check for a tagged union - args and first args is [":",:.] => - and/[isValidType type for [:.,type] in args] - null (and/[isValidType arg for arg in args]) => NIL - ((# args) = (# REMDUP args)) => true - sayKeyedMsg("S2IR0005",[form]) - NIL - - badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) - form is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL - - form is [=$QuotientField,D] and not isPartialMode(D) and - ofCategory(D,'(Field)) => NIL - form is ['UnivariatePolynomial, x, ['UnivariatePolynomial, y, .]] and x=y => - NIL - form = '(Complex (AlgebraicNumber)) => NIL - form is ['Expression, ['Kernel, . ]] => NIL - form is [op,:argl] => - null constructor? op => nil - cosig := GETDATABASE(op, 'COSIG) - cosig and null rest cosig => -- niladic constructor - null argl => true - false - null (sig := getConstructorSignature form) => nil - [.,:cl] := sig - -- following line is needed to deal with mutable domains - if # cl ^= # argl and GENSYMP last argl then argl:= DROP(-1,argl) - # cl ^= # argl => nil - cl:= replaceSharps(cl,form) - and/[isValid for x in argl for c in cl] where isValid == - categoryForm?(c) => - evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x - not GETDATABASE(opOf x,'CONSTRUCTORKIND) = 'domain - -selectMms1(op,tar,args1,args2,$Coerce) == - -- for new compiler/old world compatibility, sometimes have to look - -- for operations given two names. - - -- NEW COMPILER COMPATIBILITY ON - - op = "^" or op = "**" => - APPEND(selectMms2("**",tar,args1,args2,$Coerce), - selectMms2("^",tar,args1,args2,$Coerce)) - - -- NEW COMPILER COMPATIBILITY OFF - - selectMms2(op,tar,args1,args2,$Coerce) - - -resolveTT(t1,t2) == - -- resolves two types - -- this symmetric resolve looks for a type t to which both t1 and t2 - -- can be coerced - -- if resolveTT fails, the result will be NIL - startTimingProcess 'resolve - t1 := eqType t1 - t2 := eqType t2 - null (t := resolveTT1(t1,t2)) => - stopTimingProcess 'resolve - nil - isValidType (t := eqType t) => - stopTimingProcess 'resolve - t - stopTimingProcess 'resolve - nil - -isLegitimateMode(t,hasPolyMode,polyVarList) == - -- returns true IFF t is a valid type. i.e. if t has no repeated - -- variables, or two levels of Polynomial - null t => true -- a terminating condition with underDomainOf - t = $EmptyMode => true - STRINGP t => true - ATOM t => false - - badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) - t is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL - - t is [=$QuotientField,D] and not isPartialMode(D) and - ofCategory(D,'(Field)) => NIL - t = '(Complex (AlgebraicNumber)) => NIL - - t := equiType t - vl := isPolynomialMode t => - if vl^='all then - var:= or/[(x in polyVarList => x;nil) for x in vl] => return false - listOfDuplicates vl => return false - polyVarList:= union(vl,polyVarList) - hasPolyMode => false - con := CAR t - poly? := (con = 'Polynomial or con = 'Expression) - isLegitimateMode(underDomainOf t,poly?,polyVarList) - - constructor? first t => - isLegitimateMode(underDomainOf t,hasPolyMode,polyVarList) => t - t is ['Mapping,:ml] => - null ml => NIL - -- first arg is target, which can be Void - null isLegitimateMode(first ml,nil,nil) => NIL - for m in rest ml repeat - m = $Void => - return NIL - null isLegitimateMode(m,nil,nil) => return NIL - true - t is ['Union,:ml] => - -- check for tagged union - ml and first ml is [":",:.] => isLegitimateRecordOrTaggedUnion ml - null (and/[isLegitimateMode(m,nil,nil) for m in ml]) => NIL - ((# ml) = (# REMDUP ml)) => true - NIL - t is ['Record,:r] => isLegitimateRecordOrTaggedUnion r - t is ['Enumeration,:r] => - null (and/[IDENTP x for x in r]) => false - ((# r) = (# REMDUP r)) => true - false - false - -underDomainOf t == - t = $RationalNumber => $Integer - not PAIRP t => NIL - d := deconstructT t - 1 = #d => NIL - u := getUnderModeOf(t) => u - last d - diff --git a/src/interp/clammed.boot.pamphlet b/src/interp/clammed.boot.pamphlet new file mode 100644 index 00000000..d0689739 --- /dev/null +++ b/src/interp/clammed.boot.pamphlet @@ -0,0 +1,229 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp clammed.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Functions on $clamList + +-- These files are read in by the system so that they can be cached +-- properly. Otherwise, must read in compiled versions and then +-- recompile these, resulting in wasted BPI space. + +canCoerceFrom(mr,m) == + -- bind flag for recording/reporting instantiations + -- (see recordInstantiation) + $insideCanCoerceFrom: local := [mr,m] + canCoerceFrom0(mr,m) + +canCoerce(t1, t2) == + val := canCoerce1(t1, t2) => val + t1 is ['Variable, :.] => + newMode := getMinimalVarMode(t1, nil) + canCoerce1(t1, newMode) and canCoerce1(newMode, t2) + nil + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +coerceConvertMmSelection(funName,m1,m2) == + -- calls selectMms with $Coerce=NIL and tests for required + -- target type. funName is either 'coerce or 'convert. + $declaredMode : local:= NIL + $reportBottomUpFlag : local:= NIL + l := selectMms1(funName,m2,[m1],[m1],NIL) + mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and + isEqualOrSubDomain(m1, first rest rest sig)] + mmS and CAR mmS + +hasFileProperty(p,id,abbrev) == hasFilePropertyNoCache(p,id,abbrev) + +isValidType form == + -- returns true IFF form is a type whose arguments satisfy the + -- predicate of the type constructor + -- Note that some forms are said to be invalid because they would + -- cause problems with the interpreter. Thus things like P P I + -- are not valid. + STRINGP form => true + IDENTP form => false + form in '((Mode) (Domain) (SubDomain (Domain))) => true + form is ['Record,:selectors] => + and/[isValidType type for [:.,type] in selectors] + form is ['Enumeration,:args] => + null (and/[IDENTP x for x in args]) => false + ((# args) = (# REMDUP args)) => true + false + form is ['Mapping,:mapargs] => + null mapargs => NIL + and/[isValidType type for type in mapargs] + form is ['Union,:args] => + -- check for a tagged union + args and first args is [":",:.] => + and/[isValidType type for [:.,type] in args] + null (and/[isValidType arg for arg in args]) => NIL + ((# args) = (# REMDUP args)) => true + sayKeyedMsg("S2IR0005",[form]) + NIL + + badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) + form is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL + + form is [=$QuotientField,D] and not isPartialMode(D) and + ofCategory(D,'(Field)) => NIL + form is ['UnivariatePolynomial, x, ['UnivariatePolynomial, y, .]] and x=y => + NIL + form = '(Complex (AlgebraicNumber)) => NIL + form is ['Expression, ['Kernel, . ]] => NIL + form is [op,:argl] => + null constructor? op => nil + cosig := GETDATABASE(op, 'COSIG) + cosig and null rest cosig => -- niladic constructor + null argl => true + false + null (sig := getConstructorSignature form) => nil + [.,:cl] := sig + -- following line is needed to deal with mutable domains + if # cl ^= # argl and GENSYMP last argl then argl:= DROP(-1,argl) + # cl ^= # argl => nil + cl:= replaceSharps(cl,form) + and/[isValid for x in argl for c in cl] where isValid == + categoryForm?(c) => + evalCategory(x,MSUBSTQ(x,'_$,c)) and isValidType x + not GETDATABASE(opOf x,'CONSTRUCTORKIND) = 'domain + +selectMms1(op,tar,args1,args2,$Coerce) == + -- for new compiler/old world compatibility, sometimes have to look + -- for operations given two names. + + -- NEW COMPILER COMPATIBILITY ON + + op = "^" or op = "**" => + APPEND(selectMms2("**",tar,args1,args2,$Coerce), + selectMms2("^",tar,args1,args2,$Coerce)) + + -- NEW COMPILER COMPATIBILITY OFF + + selectMms2(op,tar,args1,args2,$Coerce) + + +resolveTT(t1,t2) == + -- resolves two types + -- this symmetric resolve looks for a type t to which both t1 and t2 + -- can be coerced + -- if resolveTT fails, the result will be NIL + startTimingProcess 'resolve + t1 := eqType t1 + t2 := eqType t2 + null (t := resolveTT1(t1,t2)) => + stopTimingProcess 'resolve + nil + isValidType (t := eqType t) => + stopTimingProcess 'resolve + t + stopTimingProcess 'resolve + nil + +isLegitimateMode(t,hasPolyMode,polyVarList) == + -- returns true IFF t is a valid type. i.e. if t has no repeated + -- variables, or two levels of Polynomial + null t => true -- a terminating condition with underDomainOf + t = $EmptyMode => true + STRINGP t => true + ATOM t => false + + badDoubles := CONS($QuotientField, '(Gaussian Complex Polynomial Expression)) + t is [T1, [T2, :.]] and T1 = T2 and member(T1, badDoubles) => NIL + + t is [=$QuotientField,D] and not isPartialMode(D) and + ofCategory(D,'(Field)) => NIL + t = '(Complex (AlgebraicNumber)) => NIL + + t := equiType t + vl := isPolynomialMode t => + if vl^='all then + var:= or/[(x in polyVarList => x;nil) for x in vl] => return false + listOfDuplicates vl => return false + polyVarList:= union(vl,polyVarList) + hasPolyMode => false + con := CAR t + poly? := (con = 'Polynomial or con = 'Expression) + isLegitimateMode(underDomainOf t,poly?,polyVarList) + + constructor? first t => + isLegitimateMode(underDomainOf t,hasPolyMode,polyVarList) => t + t is ['Mapping,:ml] => + null ml => NIL + -- first arg is target, which can be Void + null isLegitimateMode(first ml,nil,nil) => NIL + for m in rest ml repeat + m = $Void => + return NIL + null isLegitimateMode(m,nil,nil) => return NIL + true + t is ['Union,:ml] => + -- check for tagged union + ml and first ml is [":",:.] => isLegitimateRecordOrTaggedUnion ml + null (and/[isLegitimateMode(m,nil,nil) for m in ml]) => NIL + ((# ml) = (# REMDUP ml)) => true + NIL + t is ['Record,:r] => isLegitimateRecordOrTaggedUnion r + t is ['Enumeration,:r] => + null (and/[IDENTP x for x in r]) => false + ((# r) = (# REMDUP r)) => true + false + false + +underDomainOf t == + t = $RationalNumber => $Integer + not PAIRP t => NIL + d := deconstructT t + 1 = #d => NIL + u := getUnderModeOf(t) => u + last d + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/compress.boot b/src/interp/compress.boot deleted file mode 100644 index a9e41ac5..00000000 --- a/src/interp/compress.boot +++ /dev/null @@ -1,67 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- This one is not currently in general use, but can be applied --- to various situations are required - -minimalise x == - $hash:local:=MAKE_-HASHTABLE 'UEQUAL - min x where - min x == - y:=HGET($hash,x) - y => y - PAIRP x => - x = '(QUOTE T) => '(QUOTE T) - -- copes with a particular Lucid-ism, God knows why - -- This circular way of doing things is an attempt to deal with Lucid - -- Who may place quoted cells in read-only memory - z:=min CAR x - if not EQ(z,CAR x) then RPLACA(x,z) - z:=min CDR x - if not EQ(z,CDR x) then RPLACD(x,z) - HashCheck x - REFVECP x => - for i in 0..MAXINDEX x repeat - x.i:=min (x.i) - HashCheck x - STRINGP x => HashCheck x - x - HashCheck x == - y:=HGET($hash,x) - y => y - HPUT($hash,x,x) - x - x - - diff --git a/src/interp/compress.boot.pamphlet b/src/interp/compress.boot.pamphlet new file mode 100644 index 00000000..ddf74136 --- /dev/null +++ b/src/interp/compress.boot.pamphlet @@ -0,0 +1,89 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp compress.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- This one is not currently in general use, but can be applied +-- to various situations are required + +minimalise x == + $hash:local:=MAKE_-HASHTABLE 'UEQUAL + min x where + min x == + y:=HGET($hash,x) + y => y + PAIRP x => + x = '(QUOTE T) => '(QUOTE T) + -- copes with a particular Lucid-ism, God knows why + -- This circular way of doing things is an attempt to deal with Lucid + -- Who may place quoted cells in read-only memory + z:=min CAR x + if not EQ(z,CAR x) then RPLACA(x,z) + z:=min CDR x + if not EQ(z,CDR x) then RPLACD(x,z) + HashCheck x + REFVECP x => + for i in 0..MAXINDEX x repeat + x.i:=min (x.i) + HashCheck x + STRINGP x => HashCheck x + x + HashCheck x == + y:=HGET($hash,x) + y => y + HPUT($hash,x,x) + x + x + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/cstream.boot b/src/interp/cstream.boot deleted file mode 100644 index 01190dac..00000000 --- a/src/interp/cstream.boot +++ /dev/null @@ -1,111 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import '"sys-macros" - -)package "BOOT" - ---% Stream Utilities - -npNull x== StreamNull x - -StreamNull x== - null x or EQCAR (x,"nullstream") => true - while EQCAR(x,"nonnullstream") repeat - st:=APPLY(CADR x,CDDR x) - RPLACA(x,CAR st) - RPLACD(x,CDR st) - EQCAR(x,"nullstream") - -Delay(f,x)==cons("nonnullstream",[f,:x]) - -StreamNil:= ["nullstream"] - -incRgen s==Delay(function incRgen1,[s]) - -incRgen1(:z)== - [s]:=z - a:=shoeread_-line s - if NULL a - then (CLOSE s;StreamNil) - - else cons(a,incRgen s) - -incIgen n==Delay(function incIgen1,[n]) -incIgen1(:z)== - [n]:=z - n:=n+1 - cons(n,incIgen n) - -incZip(g,f1,f2)==Delay(function incZip1,[g,f1,f2]) -incZip1(:z)== - [g,f1,f2]:=z - StreamNull f1 => StreamNil - StreamNull f2 => StreamNil - cons(FUNCALL(g,car f1,car f2),incZip(g,cdr f1,cdr f2)) - -incAppend(x,y)==Delay(function incAppend1,[x,y]) - -incAppend1(:z)== - [x,y]:=z - if StreamNull x - then if StreamNull y - then StreamNil - else y - else cons(car x,incAppend(cdr x,y)) - -next(f,s)==Delay(function next1,[f,s]) -next1(:z)== - [f,s]:=z - StreamNull s=> StreamNil - h:= APPLY(f, [s]) - incAppend(car h,next(f,cdr h)) - -nextown(f,g,s)==Delay(function nextown1,[f,g,s]) -nextown1 (:z)== - [f,g,s]:=z - StreamNull s=> - spadcall1 g - StreamNil - StreamNull s - h:=spadcall2 (f, s) - incAppend(car h,nextown(f,g,cdr h)) - -nextown2(f,g,e,x)==nextown(cons(f,e),cons(g,e),x) - -spadcall1(g)== - [impl, :env] := g - APPLY(impl, [env]) - -spadcall2(f,args) == - [impl, :env] := f - APPLY(impl, [args, env]) diff --git a/src/interp/cstream.boot.pamphlet b/src/interp/cstream.boot.pamphlet new file mode 100644 index 00000000..46be9728 --- /dev/null +++ b/src/interp/cstream.boot.pamphlet @@ -0,0 +1,147 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp cstream.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +The input stream is parsed into a large s-expression by repeated calls +to Delay. Delay takes a function f and an argument x and returns a list +consisting of ("nonnullstream" f x). Eventually multiple calls are made +and a large list structure is created that consists of +("nonnullstream" f x ("nonnullstream" f1 x1 ("nonnullstream" f2 x2... + +This delay structure is given to StreamNull which walks along the +list looking at the head. If the head is "nonnullstream" then the +function is applied to the argument. + +So, in effect, the input is "zipped up" into a Delay data structure +which is then evaluated by calling StreamNull. This "zippered stream" +parser was a research project at IBM and Axiom was the testbed (which +explains the strange parsing technique). +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +import '"sys-macros" + +)package "BOOT" + +--% Stream Utilities + +npNull x== StreamNull x + +StreamNull x== + null x or EQCAR (x,"nullstream") => true + while EQCAR(x,"nonnullstream") repeat + st:=APPLY(CADR x,CDDR x) + RPLACA(x,CAR st) + RPLACD(x,CDR st) + EQCAR(x,"nullstream") + +Delay(f,x)==cons("nonnullstream",[f,:x]) + +StreamNil:= ["nullstream"] + +incRgen s==Delay(function incRgen1,[s]) + +incRgen1(:z)== + [s]:=z + a:=shoeread_-line s + if NULL a + then (CLOSE s;StreamNil) + + else cons(a,incRgen s) + +incIgen n==Delay(function incIgen1,[n]) +incIgen1(:z)== + [n]:=z + n:=n+1 + cons(n,incIgen n) + +incZip(g,f1,f2)==Delay(function incZip1,[g,f1,f2]) +incZip1(:z)== + [g,f1,f2]:=z + StreamNull f1 => StreamNil + StreamNull f2 => StreamNil + cons(FUNCALL(g,car f1,car f2),incZip(g,cdr f1,cdr f2)) + +incAppend(x,y)==Delay(function incAppend1,[x,y]) + +incAppend1(:z)== + [x,y]:=z + if StreamNull x + then if StreamNull y + then StreamNil + else y + else cons(car x,incAppend(cdr x,y)) + +next(f,s)==Delay(function next1,[f,s]) +next1(:z)== + [f,s]:=z + StreamNull s=> StreamNil + h:= APPLY(f, [s]) + incAppend(car h,next(f,cdr h)) + +nextown(f,g,s)==Delay(function nextown1,[f,g,s]) +nextown1 (:z)== + [f,g,s]:=z + StreamNull s=> + spadcall1 g + StreamNil + StreamNull s + h:=spadcall2 (f, s) + incAppend(car h,nextown(f,g,cdr h)) + +nextown2(f,g,e,x)==nextown(cons(f,e),cons(g,e),x) + +spadcall1(g)== + [impl, :env] := g + APPLY(impl, [env]) + +spadcall2(f,args) == + [impl, :env] := f + APPLY(impl, [args, env]) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/database.boot b/src/interp/database.boot deleted file mode 100644 index e1c9e069..00000000 --- a/src/interp/database.boot +++ /dev/null @@ -1,671 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -SETANDFILEQ($getUnexposedOperations,true) - ---% Functions for manipulating MODEMAP DATABASE - -augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == - sl := [["$",:"*1"],:[[a,:p] for a in argl - for p in rest $PatternVariableList]] - form:= SUBLIS(sl,form) - body:= SUBLIS(sl,body) - signature:= SUBLIS(sl,signature) - opAlist:= SUBLIS(sl,$domainShell.(1)) or return nil - nonCategorySigAlist:= - mkAlistOfExplicitCategoryOps substitute("*1","$",body) - domainList:= - [[a,m] for a in rest form for m in rest signature | - isCategoryForm(m,$EmptyEnvironment)] - catPredList:= [['ofCategory,:u] for u in [["*1",form],:domainList]] - for (entry:= [[op,sig,:.],pred,sel]) in opAlist | - member(sig,LASSOC(op,nonCategorySigAlist)) repeat - pred':= MKPF([pred,:catPredList],'AND) - modemap:= [["*1",:sig],[pred',sel]] - $lisplibModemapAlist:= - [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] - -augmentLisplibModemapsFromFunctor(form,opAlist,signature) == - form:= [formOp,:argl]:= formal2Pattern form - opAlist:= formal2Pattern opAlist - signature:= formal2Pattern signature - for u in form for v in signature repeat - if MEMQ(u,$PatternVariableList) then - -- we are going to be EVALing categories containing these - -- pattern variables - $e:=put(u,'mode,v,$e) - nonCategorySigAlist:= - mkAlistOfExplicitCategoryOps first signature or return nil - for (entry:= [[op,sig,:.],pred,sel]) in opAlist | - or/[(sig in catSig) for catSig in - allLASSOCs(op,nonCategorySigAlist)] repeat - skip:= - argl and CONTAINED("$",rest sig) => 'SKIP - nil - sel:= substitute(form,"$",sel) - patternList:= listOfPatternIds sig - --get relevant predicates - predList:= - [[a,m] for a in argl for m in rest signature - | MEMQ(a,$PatternVariableList)] - sig:= substitute(form,"$",sig) - pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) - l:=listOfPatternIds predList - if "OR"/[null MEMQ(u,l) for u in argl] then - sayMSG ['"cannot handle modemap for",:bright op, - '"by pattern match" ] - skip:= 'SKIP - modemap:= [[form,:sig],[pred',sel,:skip]] - $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], - :$lisplibModemapAlist] - -rebuildCDT(filemode) == - clearConstructorAndLisplibCaches() - $databaseQueue:local :=nil - $e: local := [[NIL]] -- We may need to evaluate Categories - buildDatabase(filemode,false) - $IOindex:= 1 - $InteractiveFrame:= [[NIL]] - 0 - -buildDatabase(filemode,expensive) == - $InteractiveMode: local:= true - $constructorList := nil --looked at by buildLibdb - $ConstructorCache:= MAKE_-HASHTABLE('ID) - SAY '"Making constructor autoload" - makeConstructorsAutoLoad() - SAY '"Building category table" - genCategoryTable() - SAY '"Building libdb.text" - buildLibdb() - SAY '"splitting libdb.text" - dbSplitLibdb() - SAY '"creating browse constructor index" - dbAugmentConstructorDataTable() - SAY '"Building browse.lisp" - buildBrowsedb() - SAY '"Building constructor users database" - mkUsersHashTable() - SAY '"Saving constructor users database" - saveUsersHashTable() - SAY '"Building constructor dependents database" - mkDependentsHashTable() - SAY '"Saving constructor dependents database" - saveDependentsHashTable() - SAY '"Building glossary files" - buildGloss() - -saveUsersHashTable() == - _$ERASE('USERS,'DATABASE,'a) - stream:= writeLib1('USERS,'DATABASE,'a) - for k in MSORT HKEYS $usersTb repeat - rwrite(k, HGET($usersTb, k), stream) - RSHUT stream - -saveDependentsHashTable() == - _$ERASE('DEPENDENTS,'DATABASE,'a) - stream:= writeLib1('DEPENDENTS,'DATABASE,'a) - for k in MSORT HKEYS $depTb repeat - rwrite(k, HGET($depTb, k), stream) - RSHUT stream - -getUsersOfConstructor(con) == - stream := readLib1('USERS, 'DATABASE, 'a) - val := rread(con, stream, nil) - RSHUT stream - val - -getDependentsOfConstructor(con) == - stream := readLib1('DEPENDENTS, 'DATABASE, 'a) - val := rread(con, stream, nil) - RSHUT stream - val - -putModemapIntoDatabase(name,modemap,fileName) == - $forceAdd: local:= nil - mml:= ASSOC(name,$databaseQueue) - if mml = [] then - $databaseQueue:=[[name, modemap],:$databaseQueue] - else - or/[modemap=map' for map' in CDR mml] => "already there" - newEntry:= [modemap,:CDR mml] - RPLACD(mml,newEntry) - newEntry - -orderPredicateItems(pred1,sig,skip) == - pred:= signatureTran pred1 - pred is ["AND",:l] => orderPredTran(l,sig,skip) - pred - -orderPredTran(oldList,sig,skip) == - lastPreds:=nil - --(1) make two kinds of predicates appear last: - ----- (op *target ..) when *target does not appear later in sig - ----- (isDomain *1 ..) - for pred in oldList repeat - ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) - and pvar=first sig and ^(pvar in rest sig)) or - (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => - oldList:=delete(pred,oldList) - lastPreds:=[pred,:lastPreds] ---sayBrightlyNT "lastPreds=" ---pp lastPreds - - --(2a) lastDependList=list of all variables that lastPred forms depend upon - lastDependList := "UNIONQ"/[listOfPatternIds x for x in lastPreds] ---sayBrightlyNT "lastDependList=" ---pp lastDependList - - --(2b) dependList=list of all variables that isDom/ofCat forms depend upon - dependList := - "UNIONQ"/[listOfPatternIds y for x in oldList | - x is ['isDomain,.,y] or x is ['ofCategory,.,y]] ---sayBrightlyNT "dependList=" ---pp dependList - - --(3a) newList= list of ofCat/isDom entries that don't depend on - for x in oldList repeat - if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then - indepvl:=listOfPatternIds v - depvl:=listOfPatternIds body - else - indepvl := listOfPatternIds x - depvl := nil - (INTERSECTIONQ(indepvl,dependList) = nil) - and INTERSECTIONQ(indepvl,lastDependList) => - somethingDone := true - lastPreds := [:lastPreds,x] - oldList := delete(x,oldList) ---if somethingDone then --- sayBrightlyNT "Again lastPreds=" --- pp lastPreds --- sayBrightlyNT "Again oldList=" --- pp oldList - - --(3b) newList= list of ofCat/isDom entries that don't depend on - while oldList repeat - for x in oldList repeat - if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then - indepvl:=listOfPatternIds v - depvl:=listOfPatternIds body - else - indepvl := listOfPatternIds x - depvl := nil - (INTERSECTIONQ(indepvl,dependList) = nil) => - dependList:= setDifference(dependList,depvl) - newList:= [:newList,x] --- sayBrightlyNT "newList=" --- pp newList - - --(4) noldList= what is left over - (noldList:= setDifference(oldList,newList)) = oldList => --- sayMSG '"NOTE: Parameters to domain have circular dependencies" - newList := [:newList,:oldList] - return nil - oldList:=noldList --- sayBrightlyNT "noldList=" --- pp noldList - - for pred in newList repeat - if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then - ids:= listOfPatternIds y - if and/[id in fullDependList for id in ids] then - fullDependList:= insertWOC(x,fullDependList) - fullDependList:= UNIONQ(fullDependList,ids) - - newList:=[:newList,:lastPreds] - ---substitute (isDomain ..) forms as completely as possible to avoid false paths - newList := isDomainSubst newList - answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] ---sayBrightlyNT '"answer=" ---pp answer - -isDomainSubst u == main where - main == - u is [head,:tail] => - nhead := - head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] - head - [nhead,:isDomainSubst rest u] - u - fn(x,alist) == - atom x => - IDENTP x and MEMQ(x,$PatternVariableList) and (s := findSub(x,alist)) => s - x - [CAR x,:[fn(y,alist) for y in CDR x]] - findSub(x,alist) == - null alist => nil - alist is [['isDomain,y,z],:.] and x = y => z - findSub(x,rest alist) - -signatureTran pred == - atom pred => pred - pred is ['has,D,catForm] and isCategoryForm(catForm,$e) => - ['ofCategory,D,catForm] - [signatureTran p for p in pred] - -interactiveModemapForm mm == - -- create modemap form for use by the interpreter. This function - -- replaces all specific domains mentioned in the modemap with pattern - -- variables, and predicates - mm := replaceVars(COPY mm,$PatternVariableList,$FormalMapVariableList) - [pattern:=[dc,:sig],pred] := mm - pred := [fn x for x in pred] where fn x == - x is [a,b,c] and a ^= 'isFreeFunction and atom c => [a,b,[c]] - x ---pp pred - [mmpat, patternAlist, partial, patvars] := - modemapPattern(pattern,sig) ---pp [pattern, mmpat, patternAlist, partial, patvars] - [pred,domainPredicateList] := - substVars(pred,patternAlist,patvars) ---pp [pred,domainPredicateList] - [pred,:dependList]:= - fixUpPredicate(pred,domainPredicateList,partial,rest mmpat) ---pp [pred,dependList] - [cond, :.] := pred - [mmpat, cond] - -modemapPattern(mmPattern,sig) == - -- Returns a list of the pattern of a modemap, an Alist of the - -- substitutions made, a boolean flag indicating whether - -- the result type is partial, and a list of unused pattern variables - patternAlist := nil - mmpat := nil - patvars := $PatternVariableList - partial := false - for xTails in tails mmPattern repeat - x := first xTails - if x is ['Union,dom,tag] and tag = '"failed" and xTails=sig then - x := dom - partial := true - patvar := rassoc(x,patternAlist) - not null patvar => mmpat := [patvar,:mmpat] - patvar := first patvars - patvars := rest patvars - mmpat := [patvar,:mmpat] - patternAlist := [[patvar,:x],:patternAlist] - [NREVERSE mmpat,patternAlist,partial,patvars] - -substVars(pred,patternAlist,patternVarList) == - --make pattern variable substitutions - domainPredicates := nil - for [[patVar,:value],:.] in tails patternAlist repeat - pred := substitute(patVar,value,pred) - patternAlist := nsubst(patVar,value,patternAlist) - domainPredicates := substitute(patVar,value,domainPredicates) - if ^MEMQ(value,$FormalMapVariableList) then - domainPredicates := [["isDomain",patVar,value],:domainPredicates] - everything := [pred,patternAlist,domainPredicates] - for var in $FormalMapVariableList repeat - CONTAINED(var,everything) => - replacementVar := first patternVarList - patternVarList := rest patternVarList - pred := substitute(replacementVar,var,pred) - domainPredicates := substitute(replacementVar,var,domainPredicates) - [pred, domainPredicates] - -fixUpPredicate(predClause, domainPreds, partial, sig) == - -- merge the predicates in predClause and domainPreds into a - -- single predicate - [predicate, fn, :skip] := predClause - if first predicate = "AND" then - predicates := APPEND(domainPreds,rest predicate) - else if predicate ^= MKQ "T" ---was->then predicates:= REVERSE [predicate, :domainPreds] - then predicates:= [predicate, :domainPreds] - else predicates := domainPreds or [predicate] - if #predicates > 1 then - pred := ["AND",:predicates] - [pred,:dependList]:=orderPredicateItems(pred,sig,skip) - else - pred := orderPredicateItems(first predicates,sig,skip) - dependList:= if pred is ['isDomain,pvar,[.]] then [pvar] else nil - pred := moveORsOutside pred - if partial then pred := ["partial", :pred] - [[pred, fn, :skip],:dependList] - -moveORsOutside p == - p is ['AND,:q] => - q := [moveORsOutside r for r in q] - x := or/[r for r in q | r is ['OR,:s]] => - moveORsOutside(['OR,:[['AND,:SUBST(t,x,q)] for t in CDR x]]) - ['AND,:q] - p - -replaceVars(x,oldvars,newvars) == - -- replace every identifier in oldvars with the corresponding - -- identifier in newvars in the expression x - for old in oldvars for new in newvars repeat - x := substitute(new,old,x) - x - -getDomainFromMm mm == - -- Returns the Domain (or package or category) of origin from a pattern - -- modemap - [., cond] := mm - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - val := - for condition in condList repeat - condition is ['isDomain, "*1", dom] => return opOf dom - condition is ['ofCategory, "*1", cat] => return opOf cat - null val => - keyedSystemError("S2GE0016", - ['"getDomainFromMm",'"Can't find domain in modemap condition"]) - val - -getFirstArgTypeFromMm mm == - -- Returns the type of the first argument or nil - [pats, cond] := mm - [.,.,:args] := pats - null args => nil - arg1 := first args - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - type := nil - for condition in condList while not type repeat - if condition is ['isDomain, a1, dom] and a1=arg1 then type := dom - type - -isFreeFunctionFromMm mm == - -- This returns true is the modemap represents a free function, ie, - -- one not coming from a domain or category. - [., cond] := mm - isFreeFunctionFromMmCond cond - -isFreeFunctionFromMmCond cond == - -- This returns true is the modemap represents a free function, ie, - -- one not coming from a domain or category. - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - iff := false - for condition in condList while not iff repeat - if condition is ['isFreeFunction, :.] then iff := true - iff - -getAllModemapsFromDatabase(op,nargs) == - $getUnexposedOperations: local := true - startTimingProcess 'diskread - ans := getSystemModemaps(op,nargs) - stopTimingProcess 'diskread - ans - -getModemapsFromDatabase(op,nargs) == - $getUnexposedOperations: local := false - startTimingProcess 'diskread - ans := getSystemModemaps(op,nargs) - stopTimingProcess 'diskread - ans - -getSystemModemaps(op,nargs) == - mml:= GETDATABASE(op,'OPERATION) => - mms := NIL - for (x := [[.,:sig],.]) in mml repeat - (NUMBERP nargs) and (nargs ^= #QCDR sig) => 'iterate - $getUnexposedOperations or isFreeFunctionFromMm(x) or - isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] - 'iterate - mms - nil - -getInCoreModemaps(modemapList,op,nargs) == - mml:= LASSOC (op,modemapList) => - mml:= CAR mml - [x for (x:= [[dc,:sig],.]) in mml | - (NUMBERP nargs => nargs=#rest sig; true) and - (cfn := abbreviate (domName := getDomainFromMm x)) and - ($getUnexposedOperations or isExposedConstructor(domName))] - nil - -mkAlistOfExplicitCategoryOps target == - if target is ['add,a,:l] then - target:=a - target is ['Join,:l] => - "union"/[mkAlistOfExplicitCategoryOps cat for cat in l] - target is ['CATEGORY,.,:l] => - l:= flattenSignatureList ['PROGN,:l] - u:= - [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] - where - atomizeOp op == - atom op => op - op is [a] => a - keyedSystemError("S2GE0016", - ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) - opList:= REMDUP ASSOCLEFT u - [[x,:fn(x,u)] for x in opList] where - fn(op,u) == - u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) - isCategoryForm(target,$e) => nil - keyedSystemError("S2GE0016", - ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) - -flattenSignatureList(x) == - atom x => nil - x is ['SIGNATURE,:.] => [x] - x is ['IF,cond,b1,b2] => - append(flattenSignatureList b1, flattenSignatureList b2) - x is ['PROGN,:l] => - ll:= [] - for x in l repeat - x is ['SIGNATURE,:.] => ll:=cons(x,ll) - ll:= append(flattenSignatureList x,ll) - ll - nil - -mkDatabasePred [a,t] == - isCategoryForm(t,$e) => ['ofCategory,a,t] - ['ofType,a,t] - -formal2Pattern x == - SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) - -updateDatabase(fname,cname,systemdir?) == - -- for now in NRUNTIME do database update only if forced - not $forceDatabaseUpdate => nil - $newcompMode = 'true => nil - -- these modemaps are never needed in the old scheme - if oldFname := constructor? cname then - clearClams() - clearAllSlams [] - if GETL(cname, 'LOADED) then - clearConstructorCaches() - if $forceDatabaseUpdate or not systemdir? then - clearClams() - clearAllSlams [] - -removeCoreModemaps(modemapList,c) == - newUserModemaps:= nil - c := opOf unabbrev c - for [op,mmList] in modemapList repeat - temp:= nil - for mm in mmList repeat - cname := getDomainFromMm mm - if cname ^= c then temp:= [:temp,mm] - if temp then newUserModemaps:= [:newUserModemaps,[op,temp]] - newUserModemaps - -addCoreModemap(modemapList,op,modemap,cname) == - entry:= ASSQ(op,modemapList) => - RPLAC(CADR entry,[modemap,:CADR entry]) - modemapList - modeMapList:= [:modemapList,[op,[ modemap]]] - -REMOVER(lst,item) == - --destructively removes item from lst - not PAIRP lst => - lst=item => nil - lst - first lst=item => rest lst - RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) - -allLASSOCs(op,alist) == - [value for [key,:value] in alist | key = op] - -loadDependents fn == - isExistingFile [fn,$spadLibFT,"*"] => - MEMQ("dependents",RKEYIDS(fn,$spadLibFT)) => - stream:= readLib1(fn,$spadLibFT,"*") - l:= rread('dependents,stream,nil) - RSHUT stream - for x in l repeat - x='SubDomain => nil - loadIfNecessary x - ---% Miscellaneous Stuff - -getOplistForConstructorForm (form := [op,:argl]) == - -- The new form is an op-Alist which has entries ( . signature-Alist) - -- where signature-Alist has entries ( . item) - -- where item has form ( ) - -- where = ELT | CONST | Subsumed | (XLAM..) .. - pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] - opAlist := getOperationAlistFromLisplib op - [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) - for [op,:signatureAlist] in opAlist] - -getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == - alist:= nil - for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat - alist:= insertAlist(SUBLIS(pairlis,[op,sig]), - SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), - alist) - alist - ---% Code For Modemap Insertion - -insertModemap(new,mmList) == - null mmList => [new] ---isMoreSpecific(new,old:= first mmList) => [new,:mmList] ---[old,:insertModemap(new,rest mmList)] - [new,:mmList] - ---% Exposure Group Code - -dropPrefix(fn) == - member(fn.0,[char "?",char "-",char "+"]) => SUBSTRING(fn,1,nil) - fn - ---moved to util.lisp ---++loadExposureGroupData() == ---++ egFile := ['INTERP,'EXPOSED] ---++-- null MAKE_-INPUT_-FILENAME(egFile) => ---++-- throwKeyedMsg("S2IL0003",[namestring egFile]) ---++ stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,:egFile]],80,0) ---++ $globalExposureGroupAlist := NIL ---++ egName := NIL ---++ egFiles := NIL ---++ while (not PLACEP (x:= READ_-LINE stream)) repeat ---++ x := DROPTRAILINGBLANKS x ---++ SIZE(x) = 0 => 'iterate -- blank line ---++ (x.0 = char "#") or (x.0 = char "*") => 'iterate -- comment ---++ x.0 = char " " => ---++ -- possible exposure group member name and library name ---++ null egName => ---++ throwKeyedMsg("S2IZ0069A",[namestring egFile,x]) ---++ x := dropLeadingBlanks x ---++ -- should be two tokens on the line ---++ p := STRPOS('" ",x,1,NIL) ---++ NULL p => ---++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) ---++ n := object2Identifier SUBSTRING(x,0,p) ---++ x := dropLeadingBlanks SUBSTRING(x,p+1,NIL) ---++ SIZE(x) = 0 => ---++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) ---++ egFiles := [[n,:object2Identifier x],:egFiles] ---++ -- have a new group name ---++ if egName then $globalExposureGroupAlist := ---++ [[egName,:nreverse egFiles],:$globalExposureGroupAlist] ---++ egFiles := NIL ---++ STRPOS('" ",x,1,NIL) => ---++ throwKeyedMsg("S2IZ0069C",[namestring egFile,x]) ---++ egName := object2Identifier x ---++ if egFiles then $globalExposureGroupAlist := ---++ [[egName,:nreverse egFiles],:$globalExposureGroupAlist] ---++ SHUT stream ---++ $globalExposureGroupAlist := nreverse $globalExposureGroupAlist ---++ 'done - -isExposedConstructor name == - -- this function checks the local exposure data in the frame to - -- see if the given constructor is exposed. The format of - -- $localExposureData is a vector with - -- slot 0: list of groups exposed in the frame - -- slot 1: list of constructors explicitly exposed - -- slot 2: list of constructors explicitly hidden - -- check if it is explicitly hidden - MEMQ(name,'(Union Record Mapping)) => true - MEMQ(name,$localExposureData.2) => false - -- check if it is explicitly exposed - MEMQ(name,$localExposureData.1) => true - -- check if it is in an exposed group - found := NIL - for g in $localExposureData.0 while not found repeat - null (x := GETALIST($globalExposureGroupAlist,g)) => 'iterate - if GETALIST(x,name) then found := true - found - -displayExposedGroups() == - sayKeyedMsg("S2IZ0049A",[$interpreterFrameName]) - if null $localExposureData.0 - then centerAndHighlight '"there are no exposed groups" - else for g in $localExposureData.0 repeat - centerAndHighlight g - -displayExposedConstructors() == - sayKeyedMsg("S2IZ0049B",NIL) - if null $localExposureData.1 - then centerAndHighlight - '"there are no explicitly exposed constructors" - else for c in $localExposureData.1 repeat - centerAndHighlight c - -displayHiddenConstructors() == - sayKeyedMsg("S2IZ0049C",NIL) - if null $localExposureData.2 - then centerAndHighlight - '"there are no explicitly hidden constructors" - else for c in $localExposureData.2 repeat - centerAndHighlight c - - diff --git a/src/interp/database.boot.pamphlet b/src/interp/database.boot.pamphlet new file mode 100644 index 00000000..f33d9333 --- /dev/null +++ b/src/interp/database.boot.pamphlet @@ -0,0 +1,697 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/database.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +SETANDFILEQ($getUnexposedOperations,true) + +--% Functions for manipulating MODEMAP DATABASE + +augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == + sl := [["$",:"*1"],:[[a,:p] for a in argl + for p in rest $PatternVariableList]] + form:= SUBLIS(sl,form) + body:= SUBLIS(sl,body) + signature:= SUBLIS(sl,signature) + opAlist:= SUBLIS(sl,$domainShell.(1)) or return nil + nonCategorySigAlist:= + mkAlistOfExplicitCategoryOps substitute("*1","$",body) + domainList:= + [[a,m] for a in rest form for m in rest signature | + isCategoryForm(m,$EmptyEnvironment)] + catPredList:= [['ofCategory,:u] for u in [["*1",form],:domainList]] + for (entry:= [[op,sig,:.],pred,sel]) in opAlist | + member(sig,LASSOC(op,nonCategorySigAlist)) repeat + pred':= MKPF([pred,:catPredList],'AND) + modemap:= [["*1",:sig],[pred',sel]] + $lisplibModemapAlist:= + [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] + +augmentLisplibModemapsFromFunctor(form,opAlist,signature) == + form:= [formOp,:argl]:= formal2Pattern form + opAlist:= formal2Pattern opAlist + signature:= formal2Pattern signature + for u in form for v in signature repeat + if MEMQ(u,$PatternVariableList) then + -- we are going to be EVALing categories containing these + -- pattern variables + $e:=put(u,'mode,v,$e) + nonCategorySigAlist:= + mkAlistOfExplicitCategoryOps first signature or return nil + for (entry:= [[op,sig,:.],pred,sel]) in opAlist | + or/[(sig in catSig) for catSig in + allLASSOCs(op,nonCategorySigAlist)] repeat + skip:= + argl and CONTAINED("$",rest sig) => 'SKIP + nil + sel:= substitute(form,"$",sel) + patternList:= listOfPatternIds sig + --get relevant predicates + predList:= + [[a,m] for a in argl for m in rest signature + | MEMQ(a,$PatternVariableList)] + sig:= substitute(form,"$",sig) + pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) + l:=listOfPatternIds predList + if "OR"/[null MEMQ(u,l) for u in argl] then + sayMSG ['"cannot handle modemap for",:bright op, + '"by pattern match" ] + skip:= 'SKIP + modemap:= [[form,:sig],[pred',sel,:skip]] + $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], + :$lisplibModemapAlist] + +rebuildCDT(filemode) == + clearConstructorAndLisplibCaches() + $databaseQueue:local :=nil + $e: local := [[NIL]] -- We may need to evaluate Categories + buildDatabase(filemode,false) + $IOindex:= 1 + $InteractiveFrame:= [[NIL]] + 0 + +buildDatabase(filemode,expensive) == + $InteractiveMode: local:= true + $constructorList := nil --looked at by buildLibdb + $ConstructorCache:= MAKE_-HASHTABLE('ID) + SAY '"Making constructor autoload" + makeConstructorsAutoLoad() + SAY '"Building category table" + genCategoryTable() + SAY '"Building libdb.text" + buildLibdb() + SAY '"splitting libdb.text" + dbSplitLibdb() + SAY '"creating browse constructor index" + dbAugmentConstructorDataTable() + SAY '"Building browse.lisp" + buildBrowsedb() + SAY '"Building constructor users database" + mkUsersHashTable() + SAY '"Saving constructor users database" + saveUsersHashTable() + SAY '"Building constructor dependents database" + mkDependentsHashTable() + SAY '"Saving constructor dependents database" + saveDependentsHashTable() + SAY '"Building glossary files" + buildGloss() + +saveUsersHashTable() == + _$ERASE('USERS,'DATABASE,'a) + stream:= writeLib1('USERS,'DATABASE,'a) + for k in MSORT HKEYS $usersTb repeat + rwrite(k, HGET($usersTb, k), stream) + RSHUT stream + +saveDependentsHashTable() == + _$ERASE('DEPENDENTS,'DATABASE,'a) + stream:= writeLib1('DEPENDENTS,'DATABASE,'a) + for k in MSORT HKEYS $depTb repeat + rwrite(k, HGET($depTb, k), stream) + RSHUT stream + +getUsersOfConstructor(con) == + stream := readLib1('USERS, 'DATABASE, 'a) + val := rread(con, stream, nil) + RSHUT stream + val + +getDependentsOfConstructor(con) == + stream := readLib1('DEPENDENTS, 'DATABASE, 'a) + val := rread(con, stream, nil) + RSHUT stream + val + +putModemapIntoDatabase(name,modemap,fileName) == + $forceAdd: local:= nil + mml:= ASSOC(name,$databaseQueue) + if mml = [] then + $databaseQueue:=[[name, modemap],:$databaseQueue] + else + or/[modemap=map' for map' in CDR mml] => "already there" + newEntry:= [modemap,:CDR mml] + RPLACD(mml,newEntry) + newEntry + +orderPredicateItems(pred1,sig,skip) == + pred:= signatureTran pred1 + pred is ["AND",:l] => orderPredTran(l,sig,skip) + pred + +orderPredTran(oldList,sig,skip) == + lastPreds:=nil + --(1) make two kinds of predicates appear last: + ----- (op *target ..) when *target does not appear later in sig + ----- (isDomain *1 ..) + for pred in oldList repeat + ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) + and pvar=first sig and ^(pvar in rest sig)) or + (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => + oldList:=delete(pred,oldList) + lastPreds:=[pred,:lastPreds] +--sayBrightlyNT "lastPreds=" +--pp lastPreds + + --(2a) lastDependList=list of all variables that lastPred forms depend upon + lastDependList := "UNIONQ"/[listOfPatternIds x for x in lastPreds] +--sayBrightlyNT "lastDependList=" +--pp lastDependList + + --(2b) dependList=list of all variables that isDom/ofCat forms depend upon + dependList := + "UNIONQ"/[listOfPatternIds y for x in oldList | + x is ['isDomain,.,y] or x is ['ofCategory,.,y]] +--sayBrightlyNT "dependList=" +--pp dependList + + --(3a) newList= list of ofCat/isDom entries that don't depend on + for x in oldList repeat + if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then + indepvl:=listOfPatternIds v + depvl:=listOfPatternIds body + else + indepvl := listOfPatternIds x + depvl := nil + (INTERSECTIONQ(indepvl,dependList) = nil) + and INTERSECTIONQ(indepvl,lastDependList) => + somethingDone := true + lastPreds := [:lastPreds,x] + oldList := delete(x,oldList) +--if somethingDone then +-- sayBrightlyNT "Again lastPreds=" +-- pp lastPreds +-- sayBrightlyNT "Again oldList=" +-- pp oldList + + --(3b) newList= list of ofCat/isDom entries that don't depend on + while oldList repeat + for x in oldList repeat + if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then + indepvl:=listOfPatternIds v + depvl:=listOfPatternIds body + else + indepvl := listOfPatternIds x + depvl := nil + (INTERSECTIONQ(indepvl,dependList) = nil) => + dependList:= setDifference(dependList,depvl) + newList:= [:newList,x] +-- sayBrightlyNT "newList=" +-- pp newList + + --(4) noldList= what is left over + (noldList:= setDifference(oldList,newList)) = oldList => +-- sayMSG '"NOTE: Parameters to domain have circular dependencies" + newList := [:newList,:oldList] + return nil + oldList:=noldList +-- sayBrightlyNT "noldList=" +-- pp noldList + + for pred in newList repeat + if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then + ids:= listOfPatternIds y + if and/[id in fullDependList for id in ids] then + fullDependList:= insertWOC(x,fullDependList) + fullDependList:= UNIONQ(fullDependList,ids) + + newList:=[:newList,:lastPreds] + +--substitute (isDomain ..) forms as completely as possible to avoid false paths + newList := isDomainSubst newList + answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] +--sayBrightlyNT '"answer=" +--pp answer + +isDomainSubst u == main where + main == + u is [head,:tail] => + nhead := + head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] + head + [nhead,:isDomainSubst rest u] + u + fn(x,alist) == + atom x => + IDENTP x and MEMQ(x,$PatternVariableList) and (s := findSub(x,alist)) => s + x + [CAR x,:[fn(y,alist) for y in CDR x]] + findSub(x,alist) == + null alist => nil + alist is [['isDomain,y,z],:.] and x = y => z + findSub(x,rest alist) + +signatureTran pred == + atom pred => pred + pred is ['has,D,catForm] and isCategoryForm(catForm,$e) => + ['ofCategory,D,catForm] + [signatureTran p for p in pred] + +interactiveModemapForm mm == + -- create modemap form for use by the interpreter. This function + -- replaces all specific domains mentioned in the modemap with pattern + -- variables, and predicates + mm := replaceVars(COPY mm,$PatternVariableList,$FormalMapVariableList) + [pattern:=[dc,:sig],pred] := mm + pred := [fn x for x in pred] where fn x == + x is [a,b,c] and a ^= 'isFreeFunction and atom c => [a,b,[c]] + x +--pp pred + [mmpat, patternAlist, partial, patvars] := + modemapPattern(pattern,sig) +--pp [pattern, mmpat, patternAlist, partial, patvars] + [pred,domainPredicateList] := + substVars(pred,patternAlist,patvars) +--pp [pred,domainPredicateList] + [pred,:dependList]:= + fixUpPredicate(pred,domainPredicateList,partial,rest mmpat) +--pp [pred,dependList] + [cond, :.] := pred + [mmpat, cond] + +modemapPattern(mmPattern,sig) == + -- Returns a list of the pattern of a modemap, an Alist of the + -- substitutions made, a boolean flag indicating whether + -- the result type is partial, and a list of unused pattern variables + patternAlist := nil + mmpat := nil + patvars := $PatternVariableList + partial := false + for xTails in tails mmPattern repeat + x := first xTails + if x is ['Union,dom,tag] and tag = '"failed" and xTails=sig then + x := dom + partial := true + patvar := rassoc(x,patternAlist) + not null patvar => mmpat := [patvar,:mmpat] + patvar := first patvars + patvars := rest patvars + mmpat := [patvar,:mmpat] + patternAlist := [[patvar,:x],:patternAlist] + [NREVERSE mmpat,patternAlist,partial,patvars] + +substVars(pred,patternAlist,patternVarList) == + --make pattern variable substitutions + domainPredicates := nil + for [[patVar,:value],:.] in tails patternAlist repeat + pred := substitute(patVar,value,pred) + patternAlist := nsubst(patVar,value,patternAlist) + domainPredicates := substitute(patVar,value,domainPredicates) + if ^MEMQ(value,$FormalMapVariableList) then + domainPredicates := [["isDomain",patVar,value],:domainPredicates] + everything := [pred,patternAlist,domainPredicates] + for var in $FormalMapVariableList repeat + CONTAINED(var,everything) => + replacementVar := first patternVarList + patternVarList := rest patternVarList + pred := substitute(replacementVar,var,pred) + domainPredicates := substitute(replacementVar,var,domainPredicates) + [pred, domainPredicates] + +fixUpPredicate(predClause, domainPreds, partial, sig) == + -- merge the predicates in predClause and domainPreds into a + -- single predicate + [predicate, fn, :skip] := predClause + if first predicate = "AND" then + predicates := APPEND(domainPreds,rest predicate) + else if predicate ^= MKQ "T" +--was->then predicates:= REVERSE [predicate, :domainPreds] + then predicates:= [predicate, :domainPreds] + else predicates := domainPreds or [predicate] + if #predicates > 1 then + pred := ["AND",:predicates] + [pred,:dependList]:=orderPredicateItems(pred,sig,skip) + else + pred := orderPredicateItems(first predicates,sig,skip) + dependList:= if pred is ['isDomain,pvar,[.]] then [pvar] else nil + pred := moveORsOutside pred + if partial then pred := ["partial", :pred] + [[pred, fn, :skip],:dependList] + +moveORsOutside p == + p is ['AND,:q] => + q := [moveORsOutside r for r in q] + x := or/[r for r in q | r is ['OR,:s]] => + moveORsOutside(['OR,:[['AND,:SUBST(t,x,q)] for t in CDR x]]) + ['AND,:q] + p + +replaceVars(x,oldvars,newvars) == + -- replace every identifier in oldvars with the corresponding + -- identifier in newvars in the expression x + for old in oldvars for new in newvars repeat + x := substitute(new,old,x) + x + +getDomainFromMm mm == + -- Returns the Domain (or package or category) of origin from a pattern + -- modemap + [., cond] := mm + if cond is ['partial, :c] then cond := c + condList := + cond is ['AND, :cl] => cl + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + [cond] + val := + for condition in condList repeat + condition is ['isDomain, "*1", dom] => return opOf dom + condition is ['ofCategory, "*1", cat] => return opOf cat + null val => + keyedSystemError("S2GE0016", + ['"getDomainFromMm",'"Can't find domain in modemap condition"]) + val + +getFirstArgTypeFromMm mm == + -- Returns the type of the first argument or nil + [pats, cond] := mm + [.,.,:args] := pats + null args => nil + arg1 := first args + if cond is ['partial, :c] then cond := c + condList := + cond is ['AND, :cl] => cl + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + [cond] + type := nil + for condition in condList while not type repeat + if condition is ['isDomain, a1, dom] and a1=arg1 then type := dom + type + +isFreeFunctionFromMm mm == + -- This returns true is the modemap represents a free function, ie, + -- one not coming from a domain or category. + [., cond] := mm + isFreeFunctionFromMmCond cond + +isFreeFunctionFromMmCond cond == + -- This returns true is the modemap represents a free function, ie, + -- one not coming from a domain or category. + if cond is ['partial, :c] then cond := c + condList := + cond is ['AND, :cl] => cl + cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info + [cond] + iff := false + for condition in condList while not iff repeat + if condition is ['isFreeFunction, :.] then iff := true + iff + +getAllModemapsFromDatabase(op,nargs) == + $getUnexposedOperations: local := true + startTimingProcess 'diskread + ans := getSystemModemaps(op,nargs) + stopTimingProcess 'diskread + ans + +getModemapsFromDatabase(op,nargs) == + $getUnexposedOperations: local := false + startTimingProcess 'diskread + ans := getSystemModemaps(op,nargs) + stopTimingProcess 'diskread + ans + +getSystemModemaps(op,nargs) == + mml:= GETDATABASE(op,'OPERATION) => + mms := NIL + for (x := [[.,:sig],.]) in mml repeat + (NUMBERP nargs) and (nargs ^= #QCDR sig) => 'iterate + $getUnexposedOperations or isFreeFunctionFromMm(x) or + isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] + 'iterate + mms + nil + +getInCoreModemaps(modemapList,op,nargs) == + mml:= LASSOC (op,modemapList) => + mml:= CAR mml + [x for (x:= [[dc,:sig],.]) in mml | + (NUMBERP nargs => nargs=#rest sig; true) and + (cfn := abbreviate (domName := getDomainFromMm x)) and + ($getUnexposedOperations or isExposedConstructor(domName))] + nil + +mkAlistOfExplicitCategoryOps target == + if target is ['add,a,:l] then + target:=a + target is ['Join,:l] => + "union"/[mkAlistOfExplicitCategoryOps cat for cat in l] + target is ['CATEGORY,.,:l] => + l:= flattenSignatureList ['PROGN,:l] + u:= + [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] + where + atomizeOp op == + atom op => op + op is [a] => a + keyedSystemError("S2GE0016", + ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) + opList:= REMDUP ASSOCLEFT u + [[x,:fn(x,u)] for x in opList] where + fn(op,u) == + u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) + isCategoryForm(target,$e) => nil + keyedSystemError("S2GE0016", + ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) + +flattenSignatureList(x) == + atom x => nil + x is ['SIGNATURE,:.] => [x] + x is ['IF,cond,b1,b2] => + append(flattenSignatureList b1, flattenSignatureList b2) + x is ['PROGN,:l] => + ll:= [] + for x in l repeat + x is ['SIGNATURE,:.] => ll:=cons(x,ll) + ll:= append(flattenSignatureList x,ll) + ll + nil + +mkDatabasePred [a,t] == + isCategoryForm(t,$e) => ['ofCategory,a,t] + ['ofType,a,t] + +formal2Pattern x == + SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) + +updateDatabase(fname,cname,systemdir?) == + -- for now in NRUNTIME do database update only if forced + not $forceDatabaseUpdate => nil + $newcompMode = 'true => nil + -- these modemaps are never needed in the old scheme + if oldFname := constructor? cname then + clearClams() + clearAllSlams [] + if GETL(cname, 'LOADED) then + clearConstructorCaches() + if $forceDatabaseUpdate or not systemdir? then + clearClams() + clearAllSlams [] + +removeCoreModemaps(modemapList,c) == + newUserModemaps:= nil + c := opOf unabbrev c + for [op,mmList] in modemapList repeat + temp:= nil + for mm in mmList repeat + cname := getDomainFromMm mm + if cname ^= c then temp:= [:temp,mm] + if temp then newUserModemaps:= [:newUserModemaps,[op,temp]] + newUserModemaps + +addCoreModemap(modemapList,op,modemap,cname) == + entry:= ASSQ(op,modemapList) => + RPLAC(CADR entry,[modemap,:CADR entry]) + modemapList + modeMapList:= [:modemapList,[op,[ modemap]]] + +REMOVER(lst,item) == + --destructively removes item from lst + not PAIRP lst => + lst=item => nil + lst + first lst=item => rest lst + RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) + +allLASSOCs(op,alist) == + [value for [key,:value] in alist | key = op] + +loadDependents fn == + isExistingFile [fn,$spadLibFT,"*"] => + MEMQ("dependents",RKEYIDS(fn,$spadLibFT)) => + stream:= readLib1(fn,$spadLibFT,"*") + l:= rread('dependents,stream,nil) + RSHUT stream + for x in l repeat + x='SubDomain => nil + loadIfNecessary x + +--% Miscellaneous Stuff + +getOplistForConstructorForm (form := [op,:argl]) == + -- The new form is an op-Alist which has entries ( . signature-Alist) + -- where signature-Alist has entries ( . item) + -- where item has form ( ) + -- where = ELT | CONST | Subsumed | (XLAM..) .. + pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] + opAlist := getOperationAlistFromLisplib op + [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) + for [op,:signatureAlist] in opAlist] + +getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == + alist:= nil + for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat + alist:= insertAlist(SUBLIS(pairlis,[op,sig]), + SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), + alist) + alist + +--% Code For Modemap Insertion + +insertModemap(new,mmList) == + null mmList => [new] +--isMoreSpecific(new,old:= first mmList) => [new,:mmList] +--[old,:insertModemap(new,rest mmList)] + [new,:mmList] + +--% Exposure Group Code + +dropPrefix(fn) == + member(fn.0,[char "?",char "-",char "+"]) => SUBSTRING(fn,1,nil) + fn + +--moved to util.lisp +--++loadExposureGroupData() == +--++ egFile := ['INTERP,'EXPOSED] +--++-- null MAKE_-INPUT_-FILENAME(egFile) => +--++-- throwKeyedMsg("S2IL0003",[namestring egFile]) +--++ stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,:egFile]],80,0) +--++ $globalExposureGroupAlist := NIL +--++ egName := NIL +--++ egFiles := NIL +--++ while (not PLACEP (x:= READ_-LINE stream)) repeat +--++ x := DROPTRAILINGBLANKS x +--++ SIZE(x) = 0 => 'iterate -- blank line +--++ (x.0 = char "#") or (x.0 = char "*") => 'iterate -- comment +--++ x.0 = char " " => +--++ -- possible exposure group member name and library name +--++ null egName => +--++ throwKeyedMsg("S2IZ0069A",[namestring egFile,x]) +--++ x := dropLeadingBlanks x +--++ -- should be two tokens on the line +--++ p := STRPOS('" ",x,1,NIL) +--++ NULL p => +--++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) +--++ n := object2Identifier SUBSTRING(x,0,p) +--++ x := dropLeadingBlanks SUBSTRING(x,p+1,NIL) +--++ SIZE(x) = 0 => +--++ throwKeyedMsg("S2IZ0069B",[namestring egFile,x]) +--++ egFiles := [[n,:object2Identifier x],:egFiles] +--++ -- have a new group name +--++ if egName then $globalExposureGroupAlist := +--++ [[egName,:nreverse egFiles],:$globalExposureGroupAlist] +--++ egFiles := NIL +--++ STRPOS('" ",x,1,NIL) => +--++ throwKeyedMsg("S2IZ0069C",[namestring egFile,x]) +--++ egName := object2Identifier x +--++ if egFiles then $globalExposureGroupAlist := +--++ [[egName,:nreverse egFiles],:$globalExposureGroupAlist] +--++ SHUT stream +--++ $globalExposureGroupAlist := nreverse $globalExposureGroupAlist +--++ 'done + +isExposedConstructor name == + -- this function checks the local exposure data in the frame to + -- see if the given constructor is exposed. The format of + -- $localExposureData is a vector with + -- slot 0: list of groups exposed in the frame + -- slot 1: list of constructors explicitly exposed + -- slot 2: list of constructors explicitly hidden + -- check if it is explicitly hidden + MEMQ(name,'(Union Record Mapping)) => true + MEMQ(name,$localExposureData.2) => false + -- check if it is explicitly exposed + MEMQ(name,$localExposureData.1) => true + -- check if it is in an exposed group + found := NIL + for g in $localExposureData.0 while not found repeat + null (x := GETALIST($globalExposureGroupAlist,g)) => 'iterate + if GETALIST(x,name) then found := true + found + +displayExposedGroups() == + sayKeyedMsg("S2IZ0049A",[$interpreterFrameName]) + if null $localExposureData.0 + then centerAndHighlight '"there are no exposed groups" + else for g in $localExposureData.0 repeat + centerAndHighlight g + +displayExposedConstructors() == + sayKeyedMsg("S2IZ0049B",NIL) + if null $localExposureData.1 + then centerAndHighlight + '"there are no explicitly exposed constructors" + else for c in $localExposureData.1 repeat + centerAndHighlight c + +displayHiddenConstructors() == + sayKeyedMsg("S2IZ0049C",NIL) + if null $localExposureData.2 + then centerAndHighlight + '"there are no explicitly hidden constructors" + else for c in $localExposureData.2 repeat + centerAndHighlight c + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/domain.lisp.pamphlet b/src/interp/domain.lisp.pamphlet new file mode 100644 index 00000000..775f3526 --- /dev/null +++ b/src/interp/domain.lisp.pamphlet @@ -0,0 +1,247 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp domain.lisp} +\author{Timothy Daly} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +;; lisp support for creating domain stubs + +(in-package "BOOT") +;;(SETQ |$optimizableConstructorNames| nil) + +(defstruct domain constructor args + (dollar (check-dollar-fields constructor args))) + +(defstruct (old-compiler-domain (:include domain) (:conc-name oldom-)) + (devaluate (if dollar (|devaluate| dollar) + (CONS constructor (MAPCAR #'|devaluate| args)))) + (vector nil)) + +(defun check-dollar-fields (constructor arglist) + (if (some #'(lambda (x) (and (domain-p x) (domain-dollar x))) arglist) + (apply constructor (mapcar #'(lambda (x) (if (domain-p x) + (or (domain-dollar x) x) + x)) arglist)) + nil)) + +(defun |domain?| (x) (domain-p x)) + +(defun |Mapping| (&rest args) + (make-old-compiler-domain :constructor '|Mapping| :args args + :vector '|Mapping0|)) + +(defun |Record| (&rest args) + (make-old-compiler-domain :constructor '|Record| :args args + :vector '|Record0|)) + +(defun |Union| (&rest args) + (make-old-compiler-domain :constructor '|Union| :args args + :vector '|Union0|)) + +(defun |devaluate| (x &aux tag dom) + (cond ((REFVECP x) + (if (> (QVSIZE x) 5) + (cond ((equal (qvelt x 3) '(|Category|)) + (qvelt x 0)) +;; next line will become obsolete + ((|isFunctor| (qvelt x 0)) (qvelt x 0)) + ((domain-p (qvelt x 0)) (|devaluate| (qvelt x 0))) + (t x)) + x)) + ((and (pairp x) (eq (car x) '|:|) (dcq (tag dom) (cdr x))) + (list (car x) tag (|devaluate| dom))) +; 20030527 note that domain-p does not exist + ((not (domain-p x)) x) +; 20030527 note that old-compiler-domain-p does not exist + ((old-compiler-domain-p x) (oldom-devaluate x)) + (t (error "devaluate of new compiler domain")))) + +(defun |domainEqual| (x y) + (cond ((old-compiler-domain-p x) + (if (old-compiler-domain-p y) + (equalp (oldom-devaluate x) (oldom-devaluate y)) + nil)) + ((old-compiler-domain-p y) nil) + (t (error "no new compiler domains yet")))) + +(defun |domainSelectDollar| (dom) + (or (domain-dollar dom) dom)) + +(defun |domainSetDollar| (dom dollar) + (setf (domain-dollar dom) dollar) + (if (old-compiler-domain-p dom) + (setf (oldom-devaluate dom) (|devaluate| dollar)))) + +(defun |domainSelectVector| (dom) + (let ((vec (oldom-vector dom))) + (cond ((vectorp vec) vec) + ((null vec) nil) + ((symbolp vec) ;; case for Records and Unions + (setq vec (funcall vec (domain-args dom))) + (setf (elt vec 0) dom) + (setf (oldom-vector dom) vec)) + ((or (fboundp (car vec)) + (|loadLib| (cdr vec)) t) + (instantiate (car vec) dom))))) + +;;(defun instantiate (innername dom) +;; (let ((vec (apply innername (domain-args dom)))) +;; (setelt vec 0 dom) +;; (setf (oldom-vector dom) vec) +;; vec)) + +(defun instantiate (innername dom) + (let* ((infovec (get (domain-constructor dom) '|infovec|)) + (|$dollarVec| (getrefv (size (car infovec ))))) + (declare (special |$dollarVec|)) + (setf (elt |$dollarVec| 0) dom) + (setf (elt |$dollarVec| 1) + (list (symbol-function (|getLookupFun| infovec)) + |$dollarVec| + (elt infovec 1))) + (setf (elt |$dollarVec| 2) (elt infovec 2)) + (setf (oldom-vector dom) |$dollarVec|) + (apply innername (domain-args dom)) + |$dollarVec|)) + +(defun universal-domain-constructor (&rest args-env) + (let* ((args (fix-domain-args (butlast args-env))) + (env (car (last args-env)))) + (check-constructor-cache env args))) + +(defun fix-domain-args (args) + (mapcar #'(lambda (x) (if (and (vectorp x) (domain-p (elt x 0))) + (elt x 0) x)) args)) + +(defun universal-nocache-domain-constructor (&rest args-env) + (let* ((args (butlast args-env)) + (env (car (last args-env)))) + (make-old-compiler-domain :constructor (car env) + :args args + :vector (cdr env)))) + +(defun universal-category-defaults-constructor (&rest args-env) + (let* ((args (butlast args-env)) + (env (car (last args-env)))) + (make-old-compiler-domain :constructor (car env) + :args args + :dollar (car args) + :vector (cdr env)))) + +(defun cached-constructor (cname) + (if (or (|isCategoryPackageName| cname) + (and (boundp '|$mutableDomains|) + (memq cname |$mutableDomains|))) + nil + t)) + +(defun |makeDomainStub| (con) + (|systemDependentMkAutoload| (|constructor?| con) con)) + +(defun |mkAutoLoad| (fn cname) + (cond ((or (memq cname |$CategoryNames|) + (eq (GETDATABSE cname 'CONSTRUCTORKIND) '|category|)) + (function (lambda (&rest args) + (|autoLoad| fn cname) + (apply cname args)))) + (t (|systemDependentMkAutoload| fn cname) + (symbol-function cname)))) + +(defun |systemDependentMkAutoload| (fn cname) + (let* ((cnameInner (intern (strconc cname ";"))) + (env (list* cname cnameInner fn)) + (spadfun + (cond ((|isCategoryPackageName| cname) + (cons #'universal-category-defaults-constructor env)) + ((and (boundp '|$mutableDomains|) + (memq cname |$mutableDomains|)) + (cons #'universal-nocache-domain-constructor env)) + (t (cons #'universal-domain-constructor env))))) + (setf (symbol-function cname) (mkConstructor spadfun)) + (set cname spadfun))) + +(defun mkConstructor (spadfun) + (function (lambda (&rest args) + (apply (car spadfun) (append args (list (cdr spadfun))))))) + +(defun |makeAddDomain| (add-domain dollar) + (cond ((old-compiler-domain-p add-domain) + (make-old-compiler-domain :constructor (domain-constructor add-domain) + :args (domain-args add-domain) + :dollar dollar + :vector (cddr (eval (domain-constructor add-domain))))) + (t (error "no new compiler adds supported yet")))) + +(defun check-constructor-cache (env arglist) + (let ((dollar (check-dollar-fields (car env) arglist))) + (if dollar (make-old-compiler-domain :constructor (car env) + :args arglist + :dollar dollar + :vector (cdr env)) + (let* ((constructor (car env)) + (devargs (mapcar #'|devaluate| arglist)) + (cacheddom + (|lassocShiftWithFunction| devargs + (HGET |$ConstructorCache| constructor) + #'|domainEqualList|))) + (if cacheddom (|CDRwithIncrement| cacheddom) + (cdr (|haddProp| |$ConstructorCache| constructor devargs + (cons 1 (make-old-compiler-domain :constructor constructor + :args arglist + :devaluate + (cons constructor devargs) + :vector (cdr env)))))))))) + + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp deleted file mode 100644 index aa0bd478..00000000 --- a/src/interp/fnewmeta.lisp +++ /dev/null @@ -1,740 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(IMPORT-MODULE "parsing") -(IN-PACKAGE "BOOT" ) - - -(DEFPARAMETER |tmptok| NIL) -(DEFPARAMETER TOK NIL) -(DEFPARAMETER |ParseMode| NIL) -(DEFPARAMETER DEFINITION_NAME NIL) -(DEFPARAMETER LABLASOC NIL) - -(defun |isTokenDelimiter| () - (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) - - -(DEFUN |PARSE-NewExpr| () - (OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|)) - (MUST (|PARSE-Command|))) - (AND (ACTION (SETQ DEFINITION_NAME (CURRENT-SYMBOL))) - (|PARSE-Statement|)))) - - -(DEFUN |PARSE-Command| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-SpecialKeyWord|)) - (MUST (|PARSE-SpecialCommand|)) - (PUSH-REDUCTION '|PARSE-Command| NIL))) - - -(DEFUN |PARSE-SpecialKeyWord| () - (AND (MATCH-CURRENT-TOKEN 'IDENTIFIER) - (ACTION (SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) - (|unAbbreviateKeyword| (CURRENT-SYMBOL)))))) - - -(DEFUN |PARSE-SpecialCommand| () - (OR (AND (MATCH-ADVANCE-STRING "show") - (BANG FIL_TEST - (OPTIONAL - (OR (MATCH-ADVANCE-STRING "?") - (|PARSE-Expression|)))) - (PUSH-REDUCTION '|PARSE-SpecialCommand| - (CONS '|show| (CONS (POP-STACK-1) NIL))) - (MUST (|PARSE-CommandTail|))) - (AND (MEMBER (CURRENT-SYMBOL) |$noParseCommands|) - (ACTION (FUNCALL (CURRENT-SYMBOL)))) - (AND (MEMBER (CURRENT-SYMBOL) |$tokenCommands|) - (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|))) - (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|)) - (MUST (|PARSE-CommandTail|))))) - - -(DEFUN |PARSE-TokenList| () - (STAR REPEATOR - (AND (NOT (|isTokenDelimiter|)) - (PUSH-REDUCTION '|PARSE-TokenList| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))))) - - -(DEFUN |PARSE-TokenCommandTail| () - (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-TokenOption|)))) - (|atEndOfLine|) - (PUSH-REDUCTION '|PARSE-TokenCommandTail| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) - (ACTION (|systemCommand| (POP-STACK-1))))) - - -(DEFUN |PARSE-TokenOption| () - (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-TokenList|)))) - - -(DEFUN |PARSE-CommandTail| () - (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|)))) - (|atEndOfLine|) - (PUSH-REDUCTION '|PARSE-CommandTail| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) - (ACTION (|systemCommand| (POP-STACK-1))))) - - -(DEFUN |PARSE-PrimaryOrQM| () - (OR (AND (MATCH-ADVANCE-STRING "?") - (PUSH-REDUCTION '|PARSE-PrimaryOrQM| '?)) - (|PARSE-Primary|))) - - -(DEFUN |PARSE-Option| () - (AND (MATCH-ADVANCE-STRING ")") - (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) - - -(DEFUN |PARSE-Statement| () - (AND (|PARSE-Expr| 0) - (OPTIONAL - (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 0)))) - (PUSH-REDUCTION '|PARSE-Statement| - (CONS '|Series| - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-InfixWith| () - (AND (|PARSE-With|) - (PUSH-REDUCTION '|PARSE-InfixWith| - (CONS '|Join| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-With| () - (AND (MATCH-ADVANCE-STRING "with") (MUST (|PARSE-Category|)) - (PUSH-REDUCTION '|PARSE-With| - (CONS '|with| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Category| () - (PROG (G1) - (RETURN - (OR (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) - (MUST (MATCH-ADVANCE-STRING "then")) - (MUST (|PARSE-Category|)) - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "else") - (MUST (|PARSE-Category|))))) - (PUSH-REDUCTION '|PARSE-Category| - (CONS '|if| - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (AND (MATCH-ADVANCE-STRING "(") (MUST (|PARSE-Category|)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") - (MUST (|PARSE-Category|)))))) - (MUST (MATCH-ADVANCE-STRING ")")) - (PUSH-REDUCTION '|PARSE-Category| - (CONS 'CATEGORY - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL))))) - (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE))) - (|PARSE-Application|) - (MUST (OR (AND (MATCH-ADVANCE-STRING ":") - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Category| - (CONS '|Signature| - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))) - (ACTION (|recordSignatureDocumentation| - (NTH-STACK 1) G1))) - (AND (PUSH-REDUCTION '|PARSE-Category| - (CONS '|Attribute| - (CONS (POP-STACK-1) NIL))) - (ACTION (|recordAttributeDocumentation| - (NTH-STACK 1) G1)))))))))) - - -(DEFUN |PARSE-Expression| () - (AND (|PARSE-Expr| - (|PARSE-rightBindingPowerOf| (MAKE-SYMBOL-OF PRIOR-TOKEN) - |ParseMode|)) - (PUSH-REDUCTION '|PARSE-Expression| (POP-STACK-1)))) - - -(DEFUN |PARSE-Import| () - (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) - (BANG FIL_TEST - (OPTIONAL - (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ",") - (MUST (|PARSE-Expr| 1000)))))) - (PUSH-REDUCTION '|PARSE-Import| - (CONS '|import| - (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Infix| () - (AND (PUSH-REDUCTION '|PARSE-Infix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Infix| - (CONS (POP-STACK-2) - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Prefix| () - (AND (PUSH-REDUCTION '|PARSE-Prefix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Prefix| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Suffix| () - (AND (PUSH-REDUCTION '|PARSE-Suffix| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) - (PUSH-REDUCTION '|PARSE-Suffix| - (CONS (POP-STACK-1) (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-TokTail| () - (PROG (G1) - (RETURN - (AND (NULL $BOOT) (EQ (CURRENT-SYMBOL) '$) - (OR (ALPHA-CHAR-P (CURRENT-CHAR)) - (CHAR-EQ (CURRENT-CHAR) "$") - (CHAR-EQ (CURRENT-CHAR) "%") - (CHAR-EQ (CURRENT-CHAR) "(")) - (ACTION (SETQ G1 (COPY-TOKEN PRIOR-TOKEN))) - (|PARSE-Qualification|) (ACTION (SETQ PRIOR-TOKEN G1)))))) - - -(DEFUN |PARSE-Qualification| () - (AND (MATCH-ADVANCE-STRING "$") (MUST (|PARSE-Primary1|)) - (PUSH-REDUCTION '|PARSE-Qualification| - (|dollarTran| (POP-STACK-1) (POP-STACK-1))))) - - -(DEFUN |PARSE-SemiColon| () - (AND (MATCH-ADVANCE-STRING ";") - (MUST (OR (|PARSE-Expr| 82) - (PUSH-REDUCTION '|PARSE-SemiColon| '|/throwAway|))) - (PUSH-REDUCTION '|PARSE-SemiColon| - (CONS '|;| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Return| () - (AND (MATCH-ADVANCE-STRING "return") (MUST (|PARSE-Expression|)) - (PUSH-REDUCTION '|PARSE-Return| - (CONS '|return| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Exit| () - (AND (MATCH-ADVANCE-STRING "exit") - (MUST (OR (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Exit| '|$NoValue|))) - (PUSH-REDUCTION '|PARSE-Exit| - (CONS '|exit| (CONS (POP-STACK-1) NIL))))) - - -(DEFUN |PARSE-Leave| () - (AND (MATCH-ADVANCE-STRING "leave") - (MUST (OR (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Leave| '|$NoValue|))) - (MUST (OR (AND (MATCH-ADVANCE-STRING "from") - (MUST (|PARSE-Label|)) - (PUSH-REDUCTION '|PARSE-Leave| - (CONS '|leaveFrom| - (CONS (POP-STACK-1) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Leave| - (CONS '|leave| (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-Seg| () - (AND (|PARSE-GliphTok| '|..|) - (BANG FIL_TEST (OPTIONAL (|PARSE-Expression|))) - (PUSH-REDUCTION '|PARSE-Seg| - (CONS 'SEGMENT - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Conditional| () - (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) - (MUST (MATCH-ADVANCE-STRING "then")) (MUST (|PARSE-Expression|)) - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "else") - (MUST (|PARSE-ElseClause|))))) - (PUSH-REDUCTION '|PARSE-Conditional| - (CONS '|if| - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-ElseClause| () - (OR (AND (EQ (CURRENT-SYMBOL) '|if|) (|PARSE-Conditional|)) - (|PARSE-Expression|))) - - -(DEFUN |PARSE-Loop| () - (OR (AND (STAR REPEATOR (|PARSE-Iterator|)) - (MUST (MATCH-ADVANCE-STRING "repeat")) - (MUST (|PARSE-Expr| 110)) - (PUSH-REDUCTION '|PARSE-Loop| - (CONS 'REPEAT - (APPEND (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) - (AND (MATCH-ADVANCE-STRING "repeat") (MUST (|PARSE-Expr| 110)) - (PUSH-REDUCTION '|PARSE-Loop| - (CONS 'REPEAT (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Iterator| () - (OR (AND (MATCH-ADVANCE-STRING "for") (MUST (|PARSE-Primary|)) - (MUST (MATCH-ADVANCE-STRING "in")) - (MUST (|PARSE-Expression|)) - (MUST (OR (AND (MATCH-ADVANCE-STRING "by") - (MUST (|PARSE-Expr| 200)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'INBY - (CONS (POP-STACK-3) - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'IN - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL)))))) - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "|") - (MUST (|PARSE-Expr| 111)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS '|\|| (CONS (POP-STACK-1) NIL)))))) - (AND (MATCH-ADVANCE-STRING "while") (MUST (|PARSE-Expr| 190)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'WHILE (CONS (POP-STACK-1) NIL)))) - (AND (MATCH-ADVANCE-STRING "until") (MUST (|PARSE-Expr| 190)) - (PUSH-REDUCTION '|PARSE-Iterator| - (CONS 'UNTIL (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Expr| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (|PARSE-NudPart| RBP) - (OPTIONAL (STAR OPT_EXPR (|PARSE-LedPart| RBP))) - (PUSH-REDUCTION '|PARSE-Expr| (POP-STACK-1)))) - - -(DEFUN |PARSE-LabelExpr| () - (AND (|PARSE-Label|) (MUST (|PARSE-Expr| 120)) - (PUSH-REDUCTION '|PARSE-LabelExpr| - (CONS 'LABEL (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Label| () - (AND (MATCH-ADVANCE-STRING "<<") (MUST (|PARSE-Name|)) - (MUST (MATCH-ADVANCE-STRING ">>")))) - - -(DEFUN |PARSE-LedPart| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (|PARSE-Operation| '|Led| RBP) - (PUSH-REDUCTION '|PARSE-LedPart| (POP-STACK-1)))) - - -(DEFUN |PARSE-NudPart| (RBP) - (DECLARE (SPECIAL RBP)) - (AND (OR (|PARSE-Operation| '|Nud| RBP) (|PARSE-Reduction|) - (|PARSE-Form|)) - (PUSH-REDUCTION '|PARSE-NudPart| (POP-STACK-1)))) - - -(DEFUN |PARSE-Operation| (|ParseMode| RBP) - (DECLARE (SPECIAL |ParseMode| RBP)) - (AND (NOT (MATCH-CURRENT-TOKEN 'IDENTIFIER)) - (GETL (SETQ |tmptok| (CURRENT-SYMBOL)) |ParseMode|) - (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|)) - (ACTION (SETQ RBP - (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|))) - (|PARSE-getSemanticForm| |tmptok| |ParseMode| - (ELEMN (GETL |tmptok| |ParseMode|) 5 NIL)))) - - -(DEFUN |PARSE-leftBindingPowerOf| (X IND) - (DECLARE (SPECIAL X IND)) - (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0))) - - -(DEFUN |PARSE-rightBindingPowerOf| (X IND) - (DECLARE (SPECIAL X IND)) - (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105))) - - -(DEFUN |PARSE-getSemanticForm| (X IND Y) - (DECLARE (SPECIAL X IND Y)) - (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|PARSE-Prefix|)) - (AND (EQ IND '|Led|) (|PARSE-Infix|)))) - - -(DEFUN |PARSE-Reduction| () - (AND (|PARSE-ReductionOp|) (MUST (|PARSE-Expr| 1000)) - (PUSH-REDUCTION '|PARSE-Reduction| - (CONS '|Reduce| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-ReductionOp| () - (AND (GETL (CURRENT-SYMBOL) '|Led|) - (MATCH-NEXT-TOKEN 'SPECIAL-CHAR (CODE-CHAR 47)) - (PUSH-REDUCTION '|PARSE-ReductionOp| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN)) (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-Form| () - (OR (AND (MATCH-ADVANCE-STRING "iterate") - (BANG FIL_TEST - (OPTIONAL - (AND (MATCH-ADVANCE-STRING "from") - (MUST (|PARSE-Label|)) - (PUSH-REDUCTION '|PARSE-Form| - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Form| - (CONS '|iterate| (APPEND (POP-STACK-1) NIL)))) - (AND (MATCH-ADVANCE-STRING "yield") (MUST (|PARSE-Application|)) - (PUSH-REDUCTION '|PARSE-Form| - (CONS '|yield| (CONS (POP-STACK-1) NIL)))) - (|PARSE-Application|))) - - -(DEFUN |PARSE-Application| () - (AND (|PARSE-Primary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|))) - (OPTIONAL - (AND (|PARSE-Application|) - (PUSH-REDUCTION '|PARSE-Application| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) - - -(DEFUN |PARSE-Selector| () - (OR (AND NONBLANK (EQ (CURRENT-SYMBOL) '|.|) - (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") - (MUST (|PARSE-PrimaryNoFloat|)) - (MUST (OR (AND $BOOT - (PUSH-REDUCTION '|PARSE-Selector| - (CONS 'ELT - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Selector| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (AND (OR (|PARSE-Float|) - (AND (MATCH-ADVANCE-STRING ".") - (MUST (|PARSE-Primary|)))) - (MUST (OR (AND $BOOT - (PUSH-REDUCTION '|PARSE-Selector| - (CONS 'ELT - (CONS (POP-STACK-2) - (CONS (POP-STACK-1) NIL))))) - (PUSH-REDUCTION '|PARSE-Selector| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-PrimaryNoFloat| () - (AND (|PARSE-Primary1|) (OPTIONAL (|PARSE-TokTail|)))) - - -(DEFUN |PARSE-Primary| () - (OR (|PARSE-Float|) (|PARSE-PrimaryNoFloat|))) - - -(DEFUN |PARSE-Primary1| () - (OR (AND (|PARSE-VarForm|) - (OPTIONAL - (AND NONBLANK (EQ (CURRENT-SYMBOL) '|(|) - (MUST (|PARSE-Primary1|)) - (PUSH-REDUCTION '|PARSE-Primary1| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (|PARSE-Quad|) (|PARSE-String|) (|PARSE-IntegerTok|) - (|PARSE-FormalParameter|) - (AND (MATCH-STRING "'") - (MUST (OR (AND $BOOT (|PARSE-Data|)) - (AND (MATCH-ADVANCE-STRING "'") - (MUST (|PARSE-Expr| 999)) - (PUSH-REDUCTION '|PARSE-Primary1| - (CONS 'QUOTE (CONS (POP-STACK-1) NIL))))))) - (|PARSE-Sequence|) (|PARSE-Enclosure|))) - - -(DEFUN |PARSE-Float| () - (AND (|PARSE-FloatBase|) - (MUST (OR (AND NONBLANK (|PARSE-FloatExponent|)) - (PUSH-REDUCTION '|PARSE-Float| 0))) - (PUSH-REDUCTION '|PARSE-Float| - (MAKE-FLOAT (POP-STACK-4) (POP-STACK-2) (POP-STACK-2) - (POP-STACK-1))))) - - -(DEFUN |PARSE-FloatBase| () - (OR (AND (FIXP (CURRENT-SYMBOL)) (CHAR-EQ (CURRENT-CHAR) ".") - (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) - (MUST (|PARSE-FloatBasePart|))) - (AND (FIXP (CURRENT-SYMBOL)) - (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) - (|PARSE-IntegerTok|) (PUSH-REDUCTION '|PARSE-FloatBase| 0) - (PUSH-REDUCTION '|PARSE-FloatBase| 0)) - (AND (DIGITP (CURRENT-CHAR)) (EQ (CURRENT-SYMBOL) '|.|) - (PUSH-REDUCTION '|PARSE-FloatBase| 0) - (|PARSE-FloatBasePart|)))) - - -(DEFUN |PARSE-FloatBasePart| () - (AND (MATCH-ADVANCE-STRING ".") - (MUST (OR (AND (DIGITP (CURRENT-CHAR)) - (PUSH-REDUCTION '|PARSE-FloatBasePart| - (TOKEN-NONBLANK (CURRENT-TOKEN))) - (|PARSE-IntegerTok|)) - (AND (PUSH-REDUCTION '|PARSE-FloatBasePart| 0) - (PUSH-REDUCTION '|PARSE-FloatBasePart| 0)))))) - - -(DEFUN |PARSE-FloatExponent| () - (PROG (G1) - (RETURN - (OR (AND (MEMBER (CURRENT-SYMBOL) '(E |e|)) - (FIND (CURRENT-CHAR) "+-") (ACTION (ADVANCE-TOKEN)) - (MUST (OR (|PARSE-IntegerTok|) - (AND (MATCH-ADVANCE-STRING "+") - (MUST (|PARSE-IntegerTok|))) - (AND (MATCH-ADVANCE-STRING "-") - (MUST (|PARSE-IntegerTok|)) - (PUSH-REDUCTION '|PARSE-FloatExponent| - (MINUS (POP-STACK-1)))) - (PUSH-REDUCTION '|PARSE-FloatExponent| 0)))) - (AND (IDENTP (CURRENT-SYMBOL)) - (SETQ G1 (FLOATEXPID (CURRENT-SYMBOL))) - (ACTION (ADVANCE-TOKEN)) - (PUSH-REDUCTION '|PARSE-FloatExponent| G1)))))) - - -(DEFUN |PARSE-Enclosure| () - (OR (AND (MATCH-ADVANCE-STRING "(") - (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING ")"))) - (AND (MATCH-ADVANCE-STRING ")") - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|Tuple| NIL)))))) - (AND (MATCH-ADVANCE-STRING "{") - (MUST (OR (AND (|PARSE-Expr| 6) - (MUST (MATCH-ADVANCE-STRING "}")) - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|brace| - (CONS - (CONS '|construct| - (CONS (POP-STACK-1) NIL)) - NIL)))) - (AND (MATCH-ADVANCE-STRING "}") - (PUSH-REDUCTION '|PARSE-Enclosure| - (CONS '|brace| NIL)))))))) - - -(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER)) - - -(DEFUN |PARSE-FloatTok| () - (AND (PARSE-NUMBER) - (PUSH-REDUCTION '|PARSE-FloatTok| - (IF $BOOT (POP-STACK-1) (BFP- (POP-STACK-1)))))) - - -(DEFUN |PARSE-FormalParameter| () (|PARSE-FormalParameterTok|)) - - -(DEFUN |PARSE-FormalParameterTok| () (PARSE-ARGUMENT-DESIGNATOR)) - - -(DEFUN |PARSE-Quad| () - (OR (AND (MATCH-ADVANCE-STRING "$") - (PUSH-REDUCTION '|PARSE-Quad| '$)) - (AND $BOOT (|PARSE-GliphTok| '|.|) - (PUSH-REDUCTION '|PARSE-Quad| '|.|)))) - - -(DEFUN |PARSE-String| () (PARSE-SPADSTRING)) - - -(DEFUN |PARSE-VarForm| () - (AND (|PARSE-Name|) - (OPTIONAL - (AND (|PARSE-Scripts|) - (PUSH-REDUCTION '|PARSE-VarForm| - (CONS '|Scripts| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) - (PUSH-REDUCTION '|PARSE-VarForm| (POP-STACK-1)))) - - -(DEFUN |PARSE-Scripts| () - (AND NONBLANK (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) - (MUST (MATCH-ADVANCE-STRING "]")))) - - -(DEFUN |PARSE-ScriptItem| () - (OR (AND (|PARSE-Expr| 90) - (OPTIONAL - (AND (STAR REPEATOR - (AND (MATCH-ADVANCE-STRING ";") - (MUST (|PARSE-ScriptItem|)))) - (PUSH-REDUCTION '|PARSE-ScriptItem| - (CONS '|;| - (CONS (POP-STACK-2) - (APPEND (POP-STACK-1) NIL))))))) - (AND (MATCH-ADVANCE-STRING ";") (MUST (|PARSE-ScriptItem|)) - (PUSH-REDUCTION '|PARSE-ScriptItem| - (CONS '|PrefixSC| (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Name| () - (AND (PARSE-IDENTIFIER) (PUSH-REDUCTION '|PARSE-Name| (POP-STACK-1)))) - - -(DEFUN |PARSE-Data| () - (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|) - (PUSH-REDUCTION '|PARSE-Data| - (CONS 'QUOTE (CONS (TRANSLABEL (POP-STACK-1) LABLASOC) NIL))))) - - -(DEFUN |PARSE-Sexpr| () - (AND (ACTION (ADVANCE-TOKEN)) (|PARSE-Sexpr1|))) - - -(DEFUN |PARSE-Sexpr1| () - (OR (AND (|PARSE-AnyId|) - (OPTIONAL - (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|)) - (ACTION (SETQ LABLASOC - (CONS (CONS (POP-STACK-2) - (NTH-STACK 1)) - LABLASOC)))))) - (AND (MATCH-ADVANCE-STRING "'") (MUST (|PARSE-Sexpr1|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| - (CONS 'QUOTE (CONS (POP-STACK-1) NIL)))) - (|PARSE-IntegerTok|) - (AND (MATCH-ADVANCE-STRING "-") (MUST (|PARSE-IntegerTok|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| (MINUS (POP-STACK-1)))) - (|PARSE-String|) - (AND (MATCH-ADVANCE-STRING "<") - (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|)))) - (MUST (MATCH-ADVANCE-STRING ">")) - (PUSH-REDUCTION '|PARSE-Sexpr1| (LIST2VEC (POP-STACK-1)))) - (AND (MATCH-ADVANCE-STRING "(") - (BANG FIL_TEST - (OPTIONAL - (AND (STAR REPEATOR (|PARSE-Sexpr1|)) - (OPTIONAL - (AND (|PARSE-GliphTok| '|.|) - (MUST (|PARSE-Sexpr1|)) - (PUSH-REDUCTION '|PARSE-Sexpr1| - (NCONC (POP-STACK-2) (POP-STACK-1)))))))) - (MUST (MATCH-ADVANCE-STRING ")"))))) - - -(DEFUN |PARSE-NBGliphTok| (|tok|) - (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) NONBLANK - (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-GliphTok| (|tok|) - (DECLARE (SPECIAL |tok|)) - (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) (ACTION (ADVANCE-TOKEN)))) - - -(DEFUN |PARSE-AnyId| () - (OR (PARSE-IDENTIFIER) - (OR (AND (MATCH-STRING "$") - (PUSH-REDUCTION '|PARSE-AnyId| (CURRENT-SYMBOL)) - (ACTION (ADVANCE-TOKEN))) - (PARSE-KEYWORD)))) - - -(DEFUN |PARSE-Sequence| () - (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "]"))) - (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|)) - (MUST (MATCH-ADVANCE-STRING "}")) - (PUSH-REDUCTION '|PARSE-Sequence| - (CONS '|brace| (CONS (POP-STACK-1) NIL)))))) - - -(DEFUN |PARSE-Sequence1| () - (AND (OR (AND (|PARSE-Expression|) - (PUSH-REDUCTION '|PARSE-Sequence1| - (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))) - (PUSH-REDUCTION '|PARSE-Sequence1| (CONS (POP-STACK-1) NIL))) - (OPTIONAL - (AND (|PARSE-IteratorTail|) - (PUSH-REDUCTION '|PARSE-Sequence1| - (CONS 'COLLECT - (APPEND (POP-STACK-1) - (CONS (POP-STACK-1) NIL)))))))) - - -(DEFUN |PARSE-OpenBracket| () - (PROG (G1) - (RETURN - (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '[) - (MUST (OR (AND (EQCAR G1 '|elt|) - (PUSH-REDUCTION '|PARSE-OpenBracket| - (CONS '|elt| - (CONS (CADR G1) - (CONS '|construct| NIL))))) - (PUSH-REDUCTION '|PARSE-OpenBracket| '|construct|))) - (ACTION (ADVANCE-TOKEN)))))) - - -(DEFUN |PARSE-OpenBrace| () - (PROG (G1) - (RETURN - (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '{) - (MUST (OR (AND (EQCAR G1 '|elt|) - (PUSH-REDUCTION '|PARSE-OpenBrace| - (CONS '|elt| - (CONS (CADR G1) - (CONS '|brace| NIL))))) - (PUSH-REDUCTION '|PARSE-OpenBrace| '|construct|))) - (ACTION (ADVANCE-TOKEN)))))) - - -(DEFUN |PARSE-IteratorTail| () - (OR (AND (MATCH-ADVANCE-STRING "repeat") - (BANG FIL_TEST - (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|))))) - (STAR REPEATOR (|PARSE-Iterator|)))) - diff --git a/src/interp/fnewmeta.lisp.pamphlet b/src/interp/fnewmeta.lisp.pamphlet new file mode 100644 index 00000000..be041a6a --- /dev/null +++ b/src/interp/fnewmeta.lisp.pamphlet @@ -0,0 +1,1012 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp fnewmeta.lisp} +\author{William Burge} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<>= +% Scratchpad II Boot Language Grammar, Common Lisp Version +% IBM Thomas J. Watson Research Center +% Summer, 1986 +% +% NOTE: Substantially different from VM/LISP version, due to +% different parser and attempt to render more within META proper. + +.META(New NewExpr Process) +.PACKAGE 'BOOT' +.DECLARE(tmptok TOK ParseMode DEFINITION_NAME LABLASOC) +.PREFIX 'PARSE-' + +NewExpr: =')' .(processSynonyms) Command + / .(SETQ DEFINITION_NAME (CURRENT-SYMBOL)) Statement ; + +Command: ')' SpecialKeyWord SpecialCommand +() ; + +SpecialKeyWord: =(MATCH-CURRENT-TOKEN "IDENTIFIER) + .(SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) (unAbbreviateKeyword (CURRENT-SYMBOL))) ; + +SpecialCommand: 'show' <'?' / Expression>! +(show #1) CommandTail + / ?(MEMBER (CURRENT-SYMBOL) \$noParseCommands) + .(FUNCALL (CURRENT-SYMBOL)) + / ?(MEMBER (CURRENT-SYMBOL) \$tokenCommands) TokenList + TokenCommandTail + / PrimaryOrQM* CommandTail ; + +TokenList: (^?(isTokenDelimiter) +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN))* ; + +TokenCommandTail: + ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; + +TokenOption: ')' TokenList ; + +CommandTail: ! ?(atEndOfLine) +(#2 -#1) .(systemCommand #1) ; + +PrimaryOrQM: '?' +\? / Primary ; + +Option: ')' PrimaryOrQM* ; + +Statement: Expr{0} <(',' Expr{0})* +(Series #2 -#1)>; + +InfixWith: With +(Join #2 #1) ; + +With: 'with' Category +(with #1) ; + +Category: 'if' Expression 'then' Category <'else' Category>! +(if #3 #2 #1) + / '(' Category <(';' Category)*>! ')' +(CATEGORY #2 -#1) + / .(SETQ $1 (LINE-NUMBER CURRENT-LINE)) Application + ( ':' Expression +(Signature #2 #1) + .(recordSignatureDocumentation ##1 $1) + / +(Attribute #1) + .(recordAttributeDocumentation ##1 $1)); + +Expression: Expr{(PARSE-rightBindingPowerOf (MAKE-SYMBOL-OF PRIOR-TOKEN) ParseMode)} + +#1 ; + +Import: 'import' Expr{1000} <(',' Expr{1000})*>! +(import #2 -#1) ; + +Infix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) + Expression +(#2 #2 #1) ; + +Prefix: =TRUE +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) + Expression +(#2 #1) ; + +Suffix: +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) +(#1 #1) ; + +TokTail: ?(AND (NULL \$BOOT) (EQ (CURRENT-SYMBOL) "\$) + (OR (ALPHA-CHAR-P (CURRENT-CHAR)) + (CHAR-EQ (CURRENT-CHAR) '$') + (CHAR-EQ (CURRENT-CHAR) '\%') + (CHAR-EQ (CURRENT-CHAR) '('))) + .(SETQ $1 (COPY-TOKEN PRIOR-TOKEN)) Qualification + .(SETQ PRIOR-TOKEN $1) ; + +Qualification: '$' Primary1 +=(dollarTran #1 #1) ; + +SemiColon: ';' (Expr{82} / + \/throwAway) +(\; #2 #1) ; + +Return: 'return' Expression +(return #1) ; + +Exit: 'exit' (Expression / +\$NoValue) +(exit #1) ; + +Leave: 'leave' ( Expression / +\$NoValue ) + ('from' Label +(leaveFrom #1 #1) / +(leave #1)) ; + +Seg: GliphTok{"\.\.} ! +(SEGMENT #2 #1) ; + +Conditional: 'if' Expression 'then' Expression <'else' ElseClause>! + +(if #3 #2 #1) ; + +ElseClause: ?(EQ (CURRENT-SYMBOL) "if) Conditional / Expression ; + +Loop: Iterator* 'repeat' Expr{110} +(REPEAT -#2 #1) + / 'repeat' Expr{110} +(REPEAT #1) ; + +Iterator: 'for' Primary 'in' Expression + ( 'by' Expr{200} +(INBY #3 #2 #1) / +(IN #2 #1) ) + < '\|' Expr{111} +(\| #1) > + / 'while' Expr{190} +(WHILE #1) + / 'until' Expr{190} +(UNTIL #1) ; + +Expr{RBP}: NudPart{RBP} * +#1; + +LabelExpr: Label Expr{120} +(LABEL #2 #1) ; + +Label: '<<' Name '>>' ; + +LedPart{RBP}: Operation{"Led RBP} +#1; + +NudPart{RBP}: (Operation{"Nud RBP} / Reduction / Form) +#1 ; + +Operation{ParseMode RBP}: + ^?(MATCH-CURRENT-TOKEN "IDENTIFIER) + ?(GETL (SETQ tmptok (CURRENT-SYMBOL)) ParseMode) + ?(LT RBP (PARSE-leftBindingPowerOf tmptok ParseMode)) + .(SETQ RBP (PARSE-rightBindingPowerOf tmptok ParseMode)) + getSemanticForm{tmptok ParseMode (ELEMN (GETL tmptok ParseMode) 5 NIL)} ; + +% Binding powers stored under the Led and Red properties of an operator +% are set up by the file BOTTOMUP.LISP. The format for a Led property +% is , and the same for a Nud, except that +% it may also have a fourth component . ELEMN attempts to +% get the Nth indicator, counting from 1. + +leftBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0)) ; + +rightBindingPowerOf{X IND}: =(LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105)) ; + +getSemanticForm{X IND Y}: + ?(AND Y (EVAL Y)) / ?(EQ IND "Nud) Prefix / ?(EQ IND "Led) Infix ; + + +Reduction: ReductionOp Expr{1000} +(Reduce #2 #1) ; + +ReductionOp: ?(AND (GETL (CURRENT-SYMBOL) "Led) + (MATCH-NEXT-TOKEN "SPECIAL-CHAR (CODE-CHAR 47))) % Forgive me! + +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) .(ADVANCE-TOKEN) ; + +Form: 'iterate' < 'from' Label +(#1) >! +(iterate -#1) + / 'yield' Application +(yield #1) + / Application ; + +Application: Primary * ; + +Selector: ?NONBLANK ?(EQ (CURRENT-SYMBOL) "\.) ?(CHAR-NE (CURRENT-CHAR) "\ ) + '.' PrimaryNoFloat (=\$BOOT +(ELT #2 #1)/ +(#2 #1)) + / (Float /'.' Primary) (=\$BOOT +(ELT #2 #1)/ +(#2 #1)); + +PrimaryNoFloat: Primary1 ; + +Primary: Float /PrimaryNoFloat ; + +Primary1: VarForm <=(AND NONBLANK (EQ (CURRENT-SYMBOL) "\()) Primary1 +(#2 #1)> + /Quad + /String + /IntegerTok + /FormalParameter + /='\'' (?\$BOOT Data / '\'' Expr{999} +(QUOTE #1)) + /Sequence + /Enclosure ; + +Float: FloatBase (?NONBLANK FloatExponent / +0) +=(MAKE-FLOAT #4 #2 #2 #1) ; + +FloatBase: ?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CURRENT-CHAR) '.') + ?(CHAR-NE (NEXT-CHAR) '.') + IntegerTok FloatBasePart + /?(FIXP (CURRENT-SYMBOL)) ?(CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) "E) + IntegerTok +0 +0 + /?(DIGITP (CURRENT-CHAR)) ?(EQ (CURRENT-SYMBOL) "\.) + +0 FloatBasePart ; + +FloatBasePart: '.' + (?(DIGITP (CURRENT-CHAR)) +=(TOKEN-NONBLANK (CURRENT-TOKEN)) IntegerTok + / +0 +0); + + +FloatExponent: =(AND (MEMBER (CURRENT-SYMBOL) "(E e)) + (FIND (CURRENT-CHAR) '+-')) + .(ADVANCE-TOKEN) + (IntegerTok/'+' IntegerTok/'-' IntegerTok +=(MINUS #1)/+0) + /?(IDENTP (CURRENT-SYMBOL)) =(SETQ $1 (FLOATEXPID (CURRENT-SYMBOL))) + .(ADVANCE-TOKEN) +=$1 ; + +Enclosure: '(' ( Expr{6} ')' / ')' +(Tuple) ) + / '{' ( Expr{6} '}' +(brace (construct #1)) / '}' +(brace)) ; + +IntegerTok: NUMBER ; + +FloatTok: NUMBER +=(IF \$BOOT #1 (BFP- #1)) ; + +FormalParameter: FormalParameterTok ; + +FormalParameterTok: ARGUMENT-DESIGNATOR ; + +Quad: '$' +\$ / ?\$BOOT GliphTok{"\.} +\. ; + +String: SPADSTRING ; + +VarForm: Name +#1 ; + +Scripts: ?NONBLANK '[' ScriptItem ']' ; + +ScriptItem: Expr{90} <(';' ScriptItem)* +(\; #2 -#1)> + / ';' ScriptItem +(PrefixSC #1) ; + +Name: IDENTIFIER +#1 ; + +Data: .(SETQ LABLASOC NIL) Sexpr +(QUOTE =(TRANSLABEL #1 LABLASOC)) ; + +Sexpr: .(ADVANCE-TOKEN) Sexpr1 ; + +Sexpr1: AnyId + < NBGliphTok{"\=} Sexpr1 + .(SETQ LABLASOC (CONS (CONS #2 ##1) LABLASOC))> + / '\'' Sexpr1 +(QUOTE #1) + / IntegerTok + / '-' IntegerTok +=(MINUS #1) + / String + / '<' ! '>' +=(LIST2VEC #1) + / '(' >! ')' ; + +NBGliphTok{tok}: ?(AND (MATCH-CURRENT-TOKEN "GLIPH tok) NONBLANK) + .(ADVANCE-TOKEN) ; + +GliphTok{tok}: ?(MATCH-CURRENT-TOKEN "GLIPH tok) .(ADVANCE-TOKEN) ; + +AnyId: IDENTIFIER + / (='$' +=(CURRENT-SYMBOL) .(ADVANCE-TOKEN) / KEYWORD) ; + +Sequence: OpenBracket Sequence1 ']' + / OpenBrace Sequence1 '}' +(brace #1) ; + +Sequence1: (Expression +(#2 #1) / +(#1)) ; + +OpenBracket: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\[ ) + (=(EQCAR $1 "elt) +(elt =(CADR $1) construct) + / +construct) .(ADVANCE-TOKEN) ; + +OpenBrace: =(EQ (getToken (SETQ $1 (CURRENT-SYMBOL))) "\{ ) + (=(EQCAR $1 "elt) +(elt =(CADR $1) brace) + / +construct) .(ADVANCE-TOKEN) ; + +IteratorTail: ('repeat' ! / Iterator*) ; + +.FIN ; + + +@ +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(IMPORT-MODULE "parsing") +(IN-PACKAGE "BOOT" ) + + +(DEFPARAMETER |tmptok| NIL) +(DEFPARAMETER TOK NIL) +(DEFPARAMETER |ParseMode| NIL) +(DEFPARAMETER DEFINITION_NAME NIL) +(DEFPARAMETER LABLASOC NIL) + +(defun |isTokenDelimiter| () + (MEMBER (CURRENT-SYMBOL) '(\) END\_UNIT NIL))) + + +(DEFUN |PARSE-NewExpr| () + (OR (AND (MATCH-STRING ")") (ACTION (|processSynonyms|)) + (MUST (|PARSE-Command|))) + (AND (ACTION (SETQ DEFINITION_NAME (CURRENT-SYMBOL))) + (|PARSE-Statement|)))) + + +(DEFUN |PARSE-Command| () + (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-SpecialKeyWord|)) + (MUST (|PARSE-SpecialCommand|)) + (PUSH-REDUCTION '|PARSE-Command| NIL))) + + +(DEFUN |PARSE-SpecialKeyWord| () + (AND (MATCH-CURRENT-TOKEN 'IDENTIFIER) + (ACTION (SETF (TOKEN-SYMBOL (CURRENT-TOKEN)) + (|unAbbreviateKeyword| (CURRENT-SYMBOL)))))) + + +(DEFUN |PARSE-SpecialCommand| () + (OR (AND (MATCH-ADVANCE-STRING "show") + (BANG FIL_TEST + (OPTIONAL + (OR (MATCH-ADVANCE-STRING "?") + (|PARSE-Expression|)))) + (PUSH-REDUCTION '|PARSE-SpecialCommand| + (CONS '|show| (CONS (POP-STACK-1) NIL))) + (MUST (|PARSE-CommandTail|))) + (AND (MEMBER (CURRENT-SYMBOL) |$noParseCommands|) + (ACTION (FUNCALL (CURRENT-SYMBOL)))) + (AND (MEMBER (CURRENT-SYMBOL) |$tokenCommands|) + (|PARSE-TokenList|) (MUST (|PARSE-TokenCommandTail|))) + (AND (STAR REPEATOR (|PARSE-PrimaryOrQM|)) + (MUST (|PARSE-CommandTail|))))) + + +(DEFUN |PARSE-TokenList| () + (STAR REPEATOR + (AND (NOT (|isTokenDelimiter|)) + (PUSH-REDUCTION '|PARSE-TokenList| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN))))) + + +(DEFUN |PARSE-TokenCommandTail| () + (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-TokenOption|)))) + (|atEndOfLine|) + (PUSH-REDUCTION '|PARSE-TokenCommandTail| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) + (ACTION (|systemCommand| (POP-STACK-1))))) + + +(DEFUN |PARSE-TokenOption| () + (AND (MATCH-ADVANCE-STRING ")") (MUST (|PARSE-TokenList|)))) + + +(DEFUN |PARSE-CommandTail| () + (AND (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Option|)))) + (|atEndOfLine|) + (PUSH-REDUCTION '|PARSE-CommandTail| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL))) + (ACTION (|systemCommand| (POP-STACK-1))))) + + +(DEFUN |PARSE-PrimaryOrQM| () + (OR (AND (MATCH-ADVANCE-STRING "?") + (PUSH-REDUCTION '|PARSE-PrimaryOrQM| '?)) + (|PARSE-Primary|))) + + +(DEFUN |PARSE-Option| () + (AND (MATCH-ADVANCE-STRING ")") + (MUST (STAR REPEATOR (|PARSE-PrimaryOrQM|))))) + + +(DEFUN |PARSE-Statement| () + (AND (|PARSE-Expr| 0) + (OPTIONAL + (AND (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 0)))) + (PUSH-REDUCTION '|PARSE-Statement| + (CONS '|Series| + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-InfixWith| () + (AND (|PARSE-With|) + (PUSH-REDUCTION '|PARSE-InfixWith| + (CONS '|Join| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-With| () + (AND (MATCH-ADVANCE-STRING "with") (MUST (|PARSE-Category|)) + (PUSH-REDUCTION '|PARSE-With| + (CONS '|with| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Category| () + (PROG (G1) + (RETURN + (OR (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "then")) + (MUST (|PARSE-Category|)) + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "else") + (MUST (|PARSE-Category|))))) + (PUSH-REDUCTION '|PARSE-Category| + (CONS '|if| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "(") (MUST (|PARSE-Category|)) + (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ";") + (MUST (|PARSE-Category|)))))) + (MUST (MATCH-ADVANCE-STRING ")")) + (PUSH-REDUCTION '|PARSE-Category| + (CONS 'CATEGORY + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL))))) + (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE))) + (|PARSE-Application|) + (MUST (OR (AND (MATCH-ADVANCE-STRING ":") + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Category| + (CONS '|Signature| + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))) + (ACTION (|recordSignatureDocumentation| + (NTH-STACK 1) G1))) + (AND (PUSH-REDUCTION '|PARSE-Category| + (CONS '|Attribute| + (CONS (POP-STACK-1) NIL))) + (ACTION (|recordAttributeDocumentation| + (NTH-STACK 1) G1)))))))))) + + +(DEFUN |PARSE-Expression| () + (AND (|PARSE-Expr| + (|PARSE-rightBindingPowerOf| (MAKE-SYMBOL-OF PRIOR-TOKEN) + |ParseMode|)) + (PUSH-REDUCTION '|PARSE-Expression| (POP-STACK-1)))) + + +(DEFUN |PARSE-Import| () + (AND (MATCH-ADVANCE-STRING "import") (MUST (|PARSE-Expr| 1000)) + (BANG FIL_TEST + (OPTIONAL + (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ",") + (MUST (|PARSE-Expr| 1000)))))) + (PUSH-REDUCTION '|PARSE-Import| + (CONS '|import| + (CONS (POP-STACK-2) (APPEND (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Infix| () + (AND (PUSH-REDUCTION '|PARSE-Infix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Infix| + (CONS (POP-STACK-2) + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Prefix| () + (AND (PUSH-REDUCTION '|PARSE-Prefix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Prefix| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Suffix| () + (AND (PUSH-REDUCTION '|PARSE-Suffix| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (OPTIONAL (|PARSE-TokTail|)) + (PUSH-REDUCTION '|PARSE-Suffix| + (CONS (POP-STACK-1) (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-TokTail| () + (PROG (G1) + (RETURN + (AND (NULL $BOOT) (EQ (CURRENT-SYMBOL) '$) + (OR (ALPHA-CHAR-P (CURRENT-CHAR)) + (CHAR-EQ (CURRENT-CHAR) "$") + (CHAR-EQ (CURRENT-CHAR) "%") + (CHAR-EQ (CURRENT-CHAR) "(")) + (ACTION (SETQ G1 (COPY-TOKEN PRIOR-TOKEN))) + (|PARSE-Qualification|) (ACTION (SETQ PRIOR-TOKEN G1)))))) + + +(DEFUN |PARSE-Qualification| () + (AND (MATCH-ADVANCE-STRING "$") (MUST (|PARSE-Primary1|)) + (PUSH-REDUCTION '|PARSE-Qualification| + (|dollarTran| (POP-STACK-1) (POP-STACK-1))))) + + +(DEFUN |PARSE-SemiColon| () + (AND (MATCH-ADVANCE-STRING ";") + (MUST (OR (|PARSE-Expr| 82) + (PUSH-REDUCTION '|PARSE-SemiColon| '|/throwAway|))) + (PUSH-REDUCTION '|PARSE-SemiColon| + (CONS '|;| (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Return| () + (AND (MATCH-ADVANCE-STRING "return") (MUST (|PARSE-Expression|)) + (PUSH-REDUCTION '|PARSE-Return| + (CONS '|return| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Exit| () + (AND (MATCH-ADVANCE-STRING "exit") + (MUST (OR (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Exit| '|$NoValue|))) + (PUSH-REDUCTION '|PARSE-Exit| + (CONS '|exit| (CONS (POP-STACK-1) NIL))))) + + +(DEFUN |PARSE-Leave| () + (AND (MATCH-ADVANCE-STRING "leave") + (MUST (OR (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Leave| '|$NoValue|))) + (MUST (OR (AND (MATCH-ADVANCE-STRING "from") + (MUST (|PARSE-Label|)) + (PUSH-REDUCTION '|PARSE-Leave| + (CONS '|leaveFrom| + (CONS (POP-STACK-1) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Leave| + (CONS '|leave| (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-Seg| () + (AND (|PARSE-GliphTok| '|..|) + (BANG FIL_TEST (OPTIONAL (|PARSE-Expression|))) + (PUSH-REDUCTION '|PARSE-Seg| + (CONS 'SEGMENT + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Conditional| () + (AND (MATCH-ADVANCE-STRING "if") (MUST (|PARSE-Expression|)) + (MUST (MATCH-ADVANCE-STRING "then")) (MUST (|PARSE-Expression|)) + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "else") + (MUST (|PARSE-ElseClause|))))) + (PUSH-REDUCTION '|PARSE-Conditional| + (CONS '|if| + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-ElseClause| () + (OR (AND (EQ (CURRENT-SYMBOL) '|if|) (|PARSE-Conditional|)) + (|PARSE-Expression|))) + + +(DEFUN |PARSE-Loop| () + (OR (AND (STAR REPEATOR (|PARSE-Iterator|)) + (MUST (MATCH-ADVANCE-STRING "repeat")) + (MUST (|PARSE-Expr| 110)) + (PUSH-REDUCTION '|PARSE-Loop| + (CONS 'REPEAT + (APPEND (POP-STACK-2) (CONS (POP-STACK-1) NIL))))) + (AND (MATCH-ADVANCE-STRING "repeat") (MUST (|PARSE-Expr| 110)) + (PUSH-REDUCTION '|PARSE-Loop| + (CONS 'REPEAT (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Iterator| () + (OR (AND (MATCH-ADVANCE-STRING "for") (MUST (|PARSE-Primary|)) + (MUST (MATCH-ADVANCE-STRING "in")) + (MUST (|PARSE-Expression|)) + (MUST (OR (AND (MATCH-ADVANCE-STRING "by") + (MUST (|PARSE-Expr| 200)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'INBY + (CONS (POP-STACK-3) + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'IN + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL)))))) + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "|") + (MUST (|PARSE-Expr| 111)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS '|\|| (CONS (POP-STACK-1) NIL)))))) + (AND (MATCH-ADVANCE-STRING "while") (MUST (|PARSE-Expr| 190)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'WHILE (CONS (POP-STACK-1) NIL)))) + (AND (MATCH-ADVANCE-STRING "until") (MUST (|PARSE-Expr| 190)) + (PUSH-REDUCTION '|PARSE-Iterator| + (CONS 'UNTIL (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Expr| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (|PARSE-NudPart| RBP) + (OPTIONAL (STAR OPT_EXPR (|PARSE-LedPart| RBP))) + (PUSH-REDUCTION '|PARSE-Expr| (POP-STACK-1)))) + + +(DEFUN |PARSE-LabelExpr| () + (AND (|PARSE-Label|) (MUST (|PARSE-Expr| 120)) + (PUSH-REDUCTION '|PARSE-LabelExpr| + (CONS 'LABEL (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Label| () + (AND (MATCH-ADVANCE-STRING "<<") (MUST (|PARSE-Name|)) + (MUST (MATCH-ADVANCE-STRING ">>")))) + + +(DEFUN |PARSE-LedPart| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (|PARSE-Operation| '|Led| RBP) + (PUSH-REDUCTION '|PARSE-LedPart| (POP-STACK-1)))) + + +(DEFUN |PARSE-NudPart| (RBP) + (DECLARE (SPECIAL RBP)) + (AND (OR (|PARSE-Operation| '|Nud| RBP) (|PARSE-Reduction|) + (|PARSE-Form|)) + (PUSH-REDUCTION '|PARSE-NudPart| (POP-STACK-1)))) + + +(DEFUN |PARSE-Operation| (|ParseMode| RBP) + (DECLARE (SPECIAL |ParseMode| RBP)) + (AND (NOT (MATCH-CURRENT-TOKEN 'IDENTIFIER)) + (GETL (SETQ |tmptok| (CURRENT-SYMBOL)) |ParseMode|) + (LT RBP (|PARSE-leftBindingPowerOf| |tmptok| |ParseMode|)) + (ACTION (SETQ RBP + (|PARSE-rightBindingPowerOf| |tmptok| |ParseMode|))) + (|PARSE-getSemanticForm| |tmptok| |ParseMode| + (ELEMN (GETL |tmptok| |ParseMode|) 5 NIL)))) + + +(DEFUN |PARSE-leftBindingPowerOf| (X IND) + (DECLARE (SPECIAL X IND)) + (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 3 0) 0))) + + +(DEFUN |PARSE-rightBindingPowerOf| (X IND) + (DECLARE (SPECIAL X IND)) + (LET ((Y (GETL X IND))) (IF Y (ELEMN Y 4 105) 105))) + + +(DEFUN |PARSE-getSemanticForm| (X IND Y) + (DECLARE (SPECIAL X IND Y)) + (OR (AND Y (EVAL Y)) (AND (EQ IND '|Nud|) (|PARSE-Prefix|)) + (AND (EQ IND '|Led|) (|PARSE-Infix|)))) + + +(DEFUN |PARSE-Reduction| () + (AND (|PARSE-ReductionOp|) (MUST (|PARSE-Expr| 1000)) + (PUSH-REDUCTION '|PARSE-Reduction| + (CONS '|Reduce| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-ReductionOp| () + (AND (GETL (CURRENT-SYMBOL) '|Led|) + (MATCH-NEXT-TOKEN 'SPECIAL-CHAR (CODE-CHAR 47)) + (PUSH-REDUCTION '|PARSE-ReductionOp| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN)) (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-Form| () + (OR (AND (MATCH-ADVANCE-STRING "iterate") + (BANG FIL_TEST + (OPTIONAL + (AND (MATCH-ADVANCE-STRING "from") + (MUST (|PARSE-Label|)) + (PUSH-REDUCTION '|PARSE-Form| + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Form| + (CONS '|iterate| (APPEND (POP-STACK-1) NIL)))) + (AND (MATCH-ADVANCE-STRING "yield") (MUST (|PARSE-Application|)) + (PUSH-REDUCTION '|PARSE-Form| + (CONS '|yield| (CONS (POP-STACK-1) NIL)))) + (|PARSE-Application|))) + + +(DEFUN |PARSE-Application| () + (AND (|PARSE-Primary|) (OPTIONAL (STAR OPT_EXPR (|PARSE-Selector|))) + (OPTIONAL + (AND (|PARSE-Application|) + (PUSH-REDUCTION '|PARSE-Application| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL))))))) + + +(DEFUN |PARSE-Selector| () + (OR (AND NONBLANK (EQ (CURRENT-SYMBOL) '|.|) + (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") + (MUST (|PARSE-PrimaryNoFloat|)) + (MUST (OR (AND $BOOT + (PUSH-REDUCTION '|PARSE-Selector| + (CONS 'ELT + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Selector| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (AND (OR (|PARSE-Float|) + (AND (MATCH-ADVANCE-STRING ".") + (MUST (|PARSE-Primary|)))) + (MUST (OR (AND $BOOT + (PUSH-REDUCTION '|PARSE-Selector| + (CONS 'ELT + (CONS (POP-STACK-2) + (CONS (POP-STACK-1) NIL))))) + (PUSH-REDUCTION '|PARSE-Selector| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-PrimaryNoFloat| () + (AND (|PARSE-Primary1|) (OPTIONAL (|PARSE-TokTail|)))) + + +(DEFUN |PARSE-Primary| () + (OR (|PARSE-Float|) (|PARSE-PrimaryNoFloat|))) + + +(DEFUN |PARSE-Primary1| () + (OR (AND (|PARSE-VarForm|) + (OPTIONAL + (AND NONBLANK (EQ (CURRENT-SYMBOL) '|(|) + (MUST (|PARSE-Primary1|)) + (PUSH-REDUCTION '|PARSE-Primary1| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (|PARSE-Quad|) (|PARSE-String|) (|PARSE-IntegerTok|) + (|PARSE-FormalParameter|) + (AND (MATCH-STRING "'") + (MUST (OR (AND $BOOT (|PARSE-Data|)) + (AND (MATCH-ADVANCE-STRING "'") + (MUST (|PARSE-Expr| 999)) + (PUSH-REDUCTION '|PARSE-Primary1| + (CONS 'QUOTE (CONS (POP-STACK-1) NIL))))))) + (|PARSE-Sequence|) (|PARSE-Enclosure|))) + + +(DEFUN |PARSE-Float| () + (AND (|PARSE-FloatBase|) + (MUST (OR (AND NONBLANK (|PARSE-FloatExponent|)) + (PUSH-REDUCTION '|PARSE-Float| 0))) + (PUSH-REDUCTION '|PARSE-Float| + (MAKE-FLOAT (POP-STACK-4) (POP-STACK-2) (POP-STACK-2) + (POP-STACK-1))))) + + +(DEFUN |PARSE-FloatBase| () + (OR (AND (FIXP (CURRENT-SYMBOL)) (CHAR-EQ (CURRENT-CHAR) ".") + (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) + (MUST (|PARSE-FloatBasePart|))) + (AND (FIXP (CURRENT-SYMBOL)) + (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) + (|PARSE-IntegerTok|) (PUSH-REDUCTION '|PARSE-FloatBase| 0) + (PUSH-REDUCTION '|PARSE-FloatBase| 0)) + (AND (DIGITP (CURRENT-CHAR)) (EQ (CURRENT-SYMBOL) '|.|) + (PUSH-REDUCTION '|PARSE-FloatBase| 0) + (|PARSE-FloatBasePart|)))) + + +(DEFUN |PARSE-FloatBasePart| () + (AND (MATCH-ADVANCE-STRING ".") + (MUST (OR (AND (DIGITP (CURRENT-CHAR)) + (PUSH-REDUCTION '|PARSE-FloatBasePart| + (TOKEN-NONBLANK (CURRENT-TOKEN))) + (|PARSE-IntegerTok|)) + (AND (PUSH-REDUCTION '|PARSE-FloatBasePart| 0) + (PUSH-REDUCTION '|PARSE-FloatBasePart| 0)))))) + + +(DEFUN |PARSE-FloatExponent| () + (PROG (G1) + (RETURN + (OR (AND (MEMBER (CURRENT-SYMBOL) '(E |e|)) + (FIND (CURRENT-CHAR) "+-") (ACTION (ADVANCE-TOKEN)) + (MUST (OR (|PARSE-IntegerTok|) + (AND (MATCH-ADVANCE-STRING "+") + (MUST (|PARSE-IntegerTok|))) + (AND (MATCH-ADVANCE-STRING "-") + (MUST (|PARSE-IntegerTok|)) + (PUSH-REDUCTION '|PARSE-FloatExponent| + (MINUS (POP-STACK-1)))) + (PUSH-REDUCTION '|PARSE-FloatExponent| 0)))) + (AND (IDENTP (CURRENT-SYMBOL)) + (SETQ G1 (FLOATEXPID (CURRENT-SYMBOL))) + (ACTION (ADVANCE-TOKEN)) + (PUSH-REDUCTION '|PARSE-FloatExponent| G1)))))) + + +(DEFUN |PARSE-Enclosure| () + (OR (AND (MATCH-ADVANCE-STRING "(") + (MUST (OR (AND (|PARSE-Expr| 6) + (MUST (MATCH-ADVANCE-STRING ")"))) + (AND (MATCH-ADVANCE-STRING ")") + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|Tuple| NIL)))))) + (AND (MATCH-ADVANCE-STRING "{") + (MUST (OR (AND (|PARSE-Expr| 6) + (MUST (MATCH-ADVANCE-STRING "}")) + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|brace| + (CONS + (CONS '|construct| + (CONS (POP-STACK-1) NIL)) + NIL)))) + (AND (MATCH-ADVANCE-STRING "}") + (PUSH-REDUCTION '|PARSE-Enclosure| + (CONS '|brace| NIL)))))))) + + +(DEFUN |PARSE-IntegerTok| () (PARSE-NUMBER)) + + +(DEFUN |PARSE-FloatTok| () + (AND (PARSE-NUMBER) + (PUSH-REDUCTION '|PARSE-FloatTok| + (IF $BOOT (POP-STACK-1) (BFP- (POP-STACK-1)))))) + + +(DEFUN |PARSE-FormalParameter| () (|PARSE-FormalParameterTok|)) + + +(DEFUN |PARSE-FormalParameterTok| () (PARSE-ARGUMENT-DESIGNATOR)) + + +(DEFUN |PARSE-Quad| () + (OR (AND (MATCH-ADVANCE-STRING "$") + (PUSH-REDUCTION '|PARSE-Quad| '$)) + (AND $BOOT (|PARSE-GliphTok| '|.|) + (PUSH-REDUCTION '|PARSE-Quad| '|.|)))) + + +(DEFUN |PARSE-String| () (PARSE-SPADSTRING)) + + +(DEFUN |PARSE-VarForm| () + (AND (|PARSE-Name|) + (OPTIONAL + (AND (|PARSE-Scripts|) + (PUSH-REDUCTION '|PARSE-VarForm| + (CONS '|Scripts| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))))) + (PUSH-REDUCTION '|PARSE-VarForm| (POP-STACK-1)))) + + +(DEFUN |PARSE-Scripts| () + (AND NONBLANK (MATCH-ADVANCE-STRING "[") (MUST (|PARSE-ScriptItem|)) + (MUST (MATCH-ADVANCE-STRING "]")))) + + +(DEFUN |PARSE-ScriptItem| () + (OR (AND (|PARSE-Expr| 90) + (OPTIONAL + (AND (STAR REPEATOR + (AND (MATCH-ADVANCE-STRING ";") + (MUST (|PARSE-ScriptItem|)))) + (PUSH-REDUCTION '|PARSE-ScriptItem| + (CONS '|;| + (CONS (POP-STACK-2) + (APPEND (POP-STACK-1) NIL))))))) + (AND (MATCH-ADVANCE-STRING ";") (MUST (|PARSE-ScriptItem|)) + (PUSH-REDUCTION '|PARSE-ScriptItem| + (CONS '|PrefixSC| (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Name| () + (AND (PARSE-IDENTIFIER) (PUSH-REDUCTION '|PARSE-Name| (POP-STACK-1)))) + + +(DEFUN |PARSE-Data| () + (AND (ACTION (SETQ LABLASOC NIL)) (|PARSE-Sexpr|) + (PUSH-REDUCTION '|PARSE-Data| + (CONS 'QUOTE (CONS (TRANSLABEL (POP-STACK-1) LABLASOC) NIL))))) + + +(DEFUN |PARSE-Sexpr| () + (AND (ACTION (ADVANCE-TOKEN)) (|PARSE-Sexpr1|))) + + +(DEFUN |PARSE-Sexpr1| () + (OR (AND (|PARSE-AnyId|) + (OPTIONAL + (AND (|PARSE-NBGliphTok| '=) (MUST (|PARSE-Sexpr1|)) + (ACTION (SETQ LABLASOC + (CONS (CONS (POP-STACK-2) + (NTH-STACK 1)) + LABLASOC)))))) + (AND (MATCH-ADVANCE-STRING "'") (MUST (|PARSE-Sexpr1|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| + (CONS 'QUOTE (CONS (POP-STACK-1) NIL)))) + (|PARSE-IntegerTok|) + (AND (MATCH-ADVANCE-STRING "-") (MUST (|PARSE-IntegerTok|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| (MINUS (POP-STACK-1)))) + (|PARSE-String|) + (AND (MATCH-ADVANCE-STRING "<") + (BANG FIL_TEST (OPTIONAL (STAR REPEATOR (|PARSE-Sexpr1|)))) + (MUST (MATCH-ADVANCE-STRING ">")) + (PUSH-REDUCTION '|PARSE-Sexpr1| (LIST2VEC (POP-STACK-1)))) + (AND (MATCH-ADVANCE-STRING "(") + (BANG FIL_TEST + (OPTIONAL + (AND (STAR REPEATOR (|PARSE-Sexpr1|)) + (OPTIONAL + (AND (|PARSE-GliphTok| '|.|) + (MUST (|PARSE-Sexpr1|)) + (PUSH-REDUCTION '|PARSE-Sexpr1| + (NCONC (POP-STACK-2) (POP-STACK-1)))))))) + (MUST (MATCH-ADVANCE-STRING ")"))))) + + +(DEFUN |PARSE-NBGliphTok| (|tok|) + (DECLARE (SPECIAL |tok|)) + (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) NONBLANK + (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-GliphTok| (|tok|) + (DECLARE (SPECIAL |tok|)) + (AND (MATCH-CURRENT-TOKEN 'GLIPH |tok|) (ACTION (ADVANCE-TOKEN)))) + + +(DEFUN |PARSE-AnyId| () + (OR (PARSE-IDENTIFIER) + (OR (AND (MATCH-STRING "$") + (PUSH-REDUCTION '|PARSE-AnyId| (CURRENT-SYMBOL)) + (ACTION (ADVANCE-TOKEN))) + (PARSE-KEYWORD)))) + + +(DEFUN |PARSE-Sequence| () + (OR (AND (|PARSE-OpenBracket|) (MUST (|PARSE-Sequence1|)) + (MUST (MATCH-ADVANCE-STRING "]"))) + (AND (|PARSE-OpenBrace|) (MUST (|PARSE-Sequence1|)) + (MUST (MATCH-ADVANCE-STRING "}")) + (PUSH-REDUCTION '|PARSE-Sequence| + (CONS '|brace| (CONS (POP-STACK-1) NIL)))))) + + +(DEFUN |PARSE-Sequence1| () + (AND (OR (AND (|PARSE-Expression|) + (PUSH-REDUCTION '|PARSE-Sequence1| + (CONS (POP-STACK-2) (CONS (POP-STACK-1) NIL)))) + (PUSH-REDUCTION '|PARSE-Sequence1| (CONS (POP-STACK-1) NIL))) + (OPTIONAL + (AND (|PARSE-IteratorTail|) + (PUSH-REDUCTION '|PARSE-Sequence1| + (CONS 'COLLECT + (APPEND (POP-STACK-1) + (CONS (POP-STACK-1) NIL)))))))) + + +(DEFUN |PARSE-OpenBracket| () + (PROG (G1) + (RETURN + (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '[) + (MUST (OR (AND (EQCAR G1 '|elt|) + (PUSH-REDUCTION '|PARSE-OpenBracket| + (CONS '|elt| + (CONS (CADR G1) + (CONS '|construct| NIL))))) + (PUSH-REDUCTION '|PARSE-OpenBracket| '|construct|))) + (ACTION (ADVANCE-TOKEN)))))) + + +(DEFUN |PARSE-OpenBrace| () + (PROG (G1) + (RETURN + (AND (EQ (|getToken| (SETQ G1 (CURRENT-SYMBOL))) '{) + (MUST (OR (AND (EQCAR G1 '|elt|) + (PUSH-REDUCTION '|PARSE-OpenBrace| + (CONS '|elt| + (CONS (CADR G1) + (CONS '|brace| NIL))))) + (PUSH-REDUCTION '|PARSE-OpenBrace| '|construct|))) + (ACTION (ADVANCE-TOKEN)))))) + + +(DEFUN |PARSE-IteratorTail| () + (OR (AND (MATCH-ADVANCE-STRING "repeat") + (BANG FIL_TEST + (OPTIONAL (STAR REPEATOR (|PARSE-Iterator|))))) + (STAR REPEATOR (|PARSE-Iterator|)))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/format.boot b/src/interp/format.boot deleted file mode 100644 index fee60054..00000000 --- a/src/interp/format.boot +++ /dev/null @@ -1,780 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Functions for display formatting system objects - --- some of these are redundant and should be compacted -$formatSigAsTeX := 1 - ---% Formatting modemaps - -sayModemap m == - -- sayMSG formatModemap displayTranModemap m - sayMSG formatModemap old2NewModemaps displayTranModemap m - -sayModemapWithNumber(m,n) == - msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", - STRCONC(lbrkSch(),object2String n,rbrkSch()), - :formatModemap displayTranModemap m,"%u","%u"] - sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) - -displayOpModemaps(op,modemaps) == - TERPRI() - count:= #modemaps - phrase:= (count=1 => 'modemap;'modemaps) - sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] - for modemap in modemaps repeat sayModemap modemap - -displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == - -- The next 8 lines are a HACK to deal with the "partial" definition - -- JHD/RSS - if pred is ['partial,:pred'] then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],[pred',:y],:z] - else if pred = 'partial then - [b,:c]:=sig - sig:=[['Union,b,'"failed"],:c] - mm:=[[x,:sig],y,:z] - mm' := EQSUBSTLIST('(m n p q r s t i j k l), - MSORT listOfPredOfTypePatternIds pred,mm) - EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), - MSORT listOfPatternIds [sig,[pred,:y]],mm') - -listOfPredOfTypePatternIds p == - p is ['AND,:lp] or p is ['OR,:lp] => - UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) - p is [op,a,.] and op = 'ofType => - isPatternVar a => [a] - nil - nil - -removeIsDomains pred == - pred is ['isDomain,a,b] => true - pred is ['AND,:predl] => - MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) - pred - -canRemoveIsDomain? pred == - -- returns nil OR an alist for substitutions of domains ordered so that - -- after substituting for each pair in turn, no left-hand names remain - alist := - pred is ['isDomain,a,b] => [[a,:b],:alist] - pred is ['AND,:predl] => - [[a,:b] for pred in predl | pred is ['isDomain,a,b]] - findSubstitutionOrder? alist - -findSubstitutionOrder? alist == fn(alist,nil) where - -- returns NIL or an appropriate substituion order - fn(alist,res) == - null alist => NREVERSE res - choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => - fn(delete(choice,alist),[choice,:res]) - nil - -containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] - -removeIsDomainD pred == - pred is ['isDomain,'D,D] => - [D,nil] - pred is ['AND,:preds] => - D := nil - for p in preds while not D repeat - p is ['isDomain,'D,D1] => - D := D1 - npreds := delete(['isDomain,'D,D1],preds) - D => - 1 = #npreds => [D,first npreds] - [D,['AND,:npreds]] - nil - nil - -formatModemap modemap == - [[dc,target,:sl],pred,:.]:= modemap - if alist := canRemoveIsDomain? pred then - dc:= substInOrder(alist,dc) - pred:= substInOrder(alist,removeIsDomains pred) - target:= substInOrder(alist,target) - sl:= substInOrder(alist,sl) - else if removeIsDomainD pred is [D,npred] then - pred := SUBST(D,'D,npred) - target := SUBST(D,'D,target) - sl := SUBST(D,'D,sl) - predPart:= formatIf pred - targetPart:= prefix2String target - argTypeList:= - null sl => nil - concat(prefix2String first sl,fn(rest sl)) where - fn l == - null l => nil - concat(",",prefix2String first l,fn rest l) - argPart:= - #sl<2 => argTypeList - ['"_(",:argTypeList,'"_)"] - fromPart:= - if dc = 'D and D - then concat('%b,'"from",'%d,prefix2String D) - else concat('%b,'"from",'%d,prefix2String dc) - firstPart:= concat('" ",argPart,'" -> ",targetPart) - sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" - fromPart:= concat('" ",fromPart) - secondPart := - sayWidth fromPart + sayWidth predPart < 75 => - concat(fromPart,predPart) - concat(fromPart,'%l,predPart) - concat(firstPart,'%l,secondPart) - firstPart:= concat(firstPart,fromPart) - sayWidth firstPart + sayWidth predPart < 80 => - concat(firstPart,predPart) - concat(firstPart,'%l,predPart) - -substInOrder(alist,x) == - alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) - x - -reportOpSymbol op1 == - op := (STRINGP op1 => INTERN op1; op1) - modemaps := getAllModemapsFromDatabase(op,nil) - null modemaps => - ok := true - sayKeyedMsg("S2IF0010",[op1]) - if SIZE PNAME op1 < 3 then - x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) - null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => - ok := nil - sayKeyedMsg("S2IZ0061",[op1]) - ok => apropos [op1] - sayNewLine() - -- filter modemaps on whether they are exposed - mmsE := mmsU := NIL - for mm in modemaps repeat - isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE] - mmsU := [mm,:mmsU] - if mmsE then - sayMms(op,mmsE,'"exposed") where - sayMms(op,mms,label) == - m := # mms - sayMSG - m = 1 => - ['"There is one",:bright label,'"function called", - :bright op,'":"] - ['"There are ",m,:bright label,'"functions called", - :bright op,'":"] - for mm in mms for i in 1.. repeat - sayModemapWithNumber(mm,i) - if mmsU then - if mmsE then sayNewLine() - sayMms(op,mmsU,'"unexposed") - nil - -formatOpType (form:=[op,:argl]) == - null argl => unabbrev op - form2String [unabbrev op, :argl] - -formatOperationAlistEntry (entry:= [op,:modemaps]) == - -- alist has entries of the form: ((op sig) . pred) - -- opsig on this list => op is defined only when the predicate is true - ans:= nil - for [sig,.,:predtail] in modemaps repeat - pred := (predtail is [p,:.] => p; 'T) - -- operation is always defined - ans := - [concat(formatOpSignature(op,sig),formatIf pred),:ans] - ans - -formatOperation([[op,sig],.,[fn,.,n]],domain) == - opSigString := formatOpSignature(op,sig) - INTEGERP n and Undef = KAR domain.n => - if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 - concat(" --",opSigString) - opSigString - -formatOpSignature(op,sig) == - concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) - -formatOpConstant op == - concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") - -formatOpSymbol(op,sig) == - if op = 'Zero then op := "0" - else if op = 'One then op := "1" - null sig => op - quad := specialChar 'quad - n := #sig - (op = 'elt) and (n = 3) => - (CADR(sig) = '_$) => - STRINGP (sel := CADDR(sig)) => - [quad,".",sel] - [quad,".",quad] - op - STRINGP op or GET(op,"Led") or GET(op,"Nud") => - n = 3 => - if op = 'SEGMENT then op := '".." - op = 'in => [quad,'" ",op,'" ",quad] --- stop exquo from being displayed as infix (since it is not accepted --- as such by the interpreter) - op = 'exquo => op - [quad,op,quad] - n = 2 => - not GET(op,"Nud") => [quad,op] - [op,quad] - op - op - -formatAttribute x == - atom x => [" ",x] - x is [op,:argl] => - for x in argl repeat - argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) - argPart => concat(" ",op,"_(",rest argPart,"_)") - [" ",op] - -formatAttributeArg x == - STRINGP x and x ='"*" => "_"*_"" - atom x => formatOpSymbol (x,nil) - x is [":",op,["Mapping",:sig]] => - concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) - prefix2String0 x - -formatMapping sig == - "STRCONC"/concat("Mapping(",formatSignature sig,")") - -dollarPercentTran x == - -- Translate $ to %. We actually return %% so that the message - -- printer will display a single % - x is [y,:z] => - y1 := dollarPercentTran y - z1 := dollarPercentTran z - EQ(y, y1) and EQ(z, z1) => x - [y1, :z1] - x = "$" or x = '"$" => "%%" - x - -formatSignatureAsTeX sig == - $formatSigAsTeX: local := 2 - formatSignature0 sig - -formatSignature sig == - $formatSigAsTeX: local := 1 - formatSignature0 sig - -formatSignatureArgs sml == - $formatSigAsTeX: local := 1 - formatSignatureArgs0 sml - -formatSignature0 sig == - null sig => "() -> ()" - INTEGERP sig => '"hashcode" - [tm,:sml] := sig - sourcePart:= formatSignatureArgs0 sml - targetPart:= prefix2String0 tm - dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) - -formatSignatureArgs0(sml) == --- formats the arguments of a signature - null sml => ["_(_)"] - null rest sml => prefix2String0 first sml - argList:= prefix2String0 first sml - for m in rest sml repeat - argList:= concat(argList,concat(",",prefix2String0 m)) - concat("_(",concat(argList,"_)")) - ---% Conversions to string form - -expr2String x == - atom (u:= prefix2String0 x) => u - "STRCONC"/[atom2String y for y in u] - --- exports (this is a badly named bit of sillyness) -prefix2StringAsTeX form == - form2StringAsTeX form - -prefix2String form == - form2String form - --- local version -prefix2String0 form == - form2StringLocal form - --- SUBRP form => formWrapId BPINAME form --- atom form => --- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad --- STRINGP form => formWrapId form --- IDENTP form => --- constructor? form => app2StringWrap(formWrapId form, [form]) --- formWrapId form --- formWrapId STRINGIMAGE form - -form2StringWithWhere u == - $permitWhere : local := true - $whereList: local := nil - s:= form2String u - $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") - s - -form2StringWithPrens form == - null (argl := rest form) => [first form] - null rest argl => [first form,"(",first argl,")"] - form2String form - -formString u == - x := form2String u - atom x => STRINGIMAGE x - "STRCONC"/[STRINGIMAGE y for y in x] - -form2String u == - $formatSigAsTeX: local := 1 - form2StringLocal u - -form2StringAsTeX u == - $formatSigAsTeX: local := 2 - form2StringLocal u - -form2StringLocal u == ---+ - $NRTmonitorIfTrue : local := nil - $fortInts2Floats : local := nil - form2String1 u - -constructorName con == - $abbreviateTypes => abbreviate con - con - -form2String1 u == - ATOM u => - u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad - IDENTP u => - constructor? u => app2StringWrap(formWrapId u, [u]) - u - SUBRP u => formWrapId BPINAME u - STRINGP u => formWrapId u - WRITE_-TO_-STRING formWrapId u - u1 := u - op := CAR u - argl := CDR u - op='Join or op= 'mkCategory => formJoin1(op,argl) - $InteractiveMode and (u:= constructor? op) => - null argl => app2StringWrap(formWrapId constructorName op, u1) - op = "NTuple" => [ form2String1 first argl, "*"] - op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] - op = 'Record => record2String(argl) - null (conSig := getConstructorSignature op) => - application2String(constructorName op,[form2String1(a) for a in argl], u1) - ml := rest conSig - if not freeOfSharpVars ml then - ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList - for val in argl], ml) - argl:= formArguments2String(argl,ml) - -- extra null check to handle mutable domain hack. - null argl => constructorName op - application2String(constructorName op,argl, u1) - op = "Mapping" => ["(",:formatSignature argl,")"] - op = "Record" => record2String(argl) - op = 'Union => - application2String(op,[form2String1 x for x in argl], u1) - op = ":" => - null argl => [ '":" ] - null rest argl => [ '":", form2String1 first argl ] - formDecl2String(argl.0,argl.1) - op = "#" and PAIRP argl and LISTP CAR argl => - STRINGIMAGE SIZE CAR argl - op = 'Join => formJoin2String argl - op = "ATTRIBUTE" => form2String1 first argl - op='Zero => 0 - op='One => 1 - op = 'AGGLST => tuple2String argl - op = 'BRACKET => - argl' := form2String1 first argl - ["[",:(atom argl' => [argl']; argl'),"]"] - op = "SIGNATURE" => - [operation,sig] := argl - concat(operation,": ",formatSignature sig) - op = 'COLLECT => formCollect2String argl - op = 'construct => - concat(lbrkSch(), - tuple2String [form2String1 x for x in argl],rbrkSch()) - op = "SEGMENT" => - null argl => '".." - lo := form2String1 first argl - argl := rest argl - (null argl) or null (first argl) => [lo, '".."] - [lo, '"..", form2String1 first argl] - isBinaryInfix op => fortexp0 [op,:argl] - -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) - application2String(op,[form2String1 x for x in argl], u1) - -formWrapId id == - $formatSigAsTeX = 1 => id - $formatSigAsTeX = 2 => - sep := '"`" - FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) - error "Bad formatSigValue" - -formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where - fn(x,m) == - x=$EmptyMode or x=$quadSymbol => specialChar 'quad - STRINGP(x) or IDENTP(x) => x - x is [ ='_:,:.] => form2String1 x - isValidType(m) and PAIRP(m) and - (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => - (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => - form2String1 objValUnwrap x' - form2String1 x - form2String1 x - -formDecl2String(left,right) == - $declVar: local := left - whereBefore := $whereList - ls:= form2StringLocal left - rs:= form2StringLocal right - NE($whereList,whereBefore) and $permitWhere => ls - concat(form2StringLocal ls,'": ",rs) - -formJoin1(op,u) == - if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) - last is [id,.,:r] and id in '(mkCategory CATEGORY) => - $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") - $permitWhere = true => - opList:= formatJoinKey(r,id) - $whereList:= concat($whereList,"%l",$declVar,": ", - formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") - formJoin2 argl - opList:= formatJoinKey(r,id) - suffix := concat('%b,'"with",'%d,"%i",opList,"%u") - concat(formJoin2 argl,suffix) - formJoin2 u - -formatJoinKey(r,key) == - key = 'mkCategory => - r is [opPart,catPart,:.] => - opString := - opPart is [='LIST,:u] => - "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) - for [='QUOTE,[[op,sig],pred]] in u] - nil - catString := - catPart is [='LIST,:u] => - "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) - for [='QUOTE,[con,pred]] in u] - nil - concat(opString,catString) - '"?? unknown mkCategory format ??" - -- otherwise we have the CATEGORY form - "append"/[fn for x in r] where fn == - x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) - x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) - x - -formJoin2 argl == --- argl is a list of categories NOT containing a "with" - null argl => '"" - 1=#argl => form2StringLocal argl.0 - application2String('Join,[form2StringLocal x for x in argl], NIL) - -formJoin2String (u:=[:argl,last]) == - last is ["CATEGORY",.,:atsigList] => - postString:= concat("_(",formTuple2String atsigList,"_)") - #argl=1 => concat(first argl,'" with ",postString) - concat(application2String('Join,argl, NIL)," with ",postString) - application2String('Join,u, NIL) - -formCollect2String [:itl,body] == - ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] - -formIterator2String x == - x is ["STEP",y,s,.,:l] => - tail:= (l is [f] => form2StringLocal f; nil) - concat("for ",y," in ",s,'"..",tail) - x is ["tails",y] => concat("tails ",formatIterator y) - x is ["reverse",y] => concat("reverse ",formatIterator y) - x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) - x is ["until",p] => concat("until ",form2StringLocal p) - x is ["while",p] => concat("while ",form2StringLocal p) - systemErrorHere "formatIterator" - -tuple2String argl == - null argl => nil - string := first argl - if string in '("failed" "nil" "prime" "sqfr" "irred") - then string := STRCONC('"_"",string,'"_"") - else string := - ATOM string => object2String string - [f x for x in string] where - f x == - ATOM x => object2String x - -- [f CAR x,:f CDR x] - [f y for y in x] - for x in rest argl repeat - if x in '("failed" "nil" "prime" "sqfr" "irred") then - x := STRCONC('"_"",x,'"_"") - string:= concat(string,concat(",",f x)) - string - -script2String s == - null s => '"" -- just to be safe - if not PAIRP s then s := [s] - linearFormatForm(CAR s, CDR s) - -linearFormatName x == - atom x => x - linearFormat x - -linearFormat x == - atom x => x - x is [op,:argl] and atom op => - argPart:= - argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] - nil - [op,"(",:argPart,")"] - [linearFormat y for y in x] - -numOfSpadArguments id == - char("*") = (s:= PNAME id).0 => - +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] - keyedSystemError("S2IF0012",[id]) - -linearFormatForm(op,argl) == - s:= PNAME op - indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while - (DIGITP (d:= s.(maxIndex:= i)))] - cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) - fnArgs:= - indexList.0 > 0 => - concat('"(",formatArgList take(-indexList.0,argl),'")") - nil - if #indexList > 1 then - scriptArgs:= formatArgList take(indexList.1,argl) - argl := drop(indexList.1,argl) - for i in rest rest indexList repeat - subArglist:= take(i,argl) - argl:= drop(i,argl) - scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) - scriptArgs:= - scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) - nil - l := [(STRINGP f => f; STRINGIMAGE f) for f in - concat(cleanOp,scriptArgs,fnArgs)] - "STRCONC"/l - -formatArgList l == - null l => nil - acc:= linearFormat first l - for x in rest l repeat - acc:= concat(acc,",",linearFormat x) - acc - -formTuple2String argl == - null argl => nil - string:= form2StringLocal first argl - for x in rest argl repeat - string:= concat(string,concat(",",form2StringLocal x)) - string - -isInternalFunctionName(op) == - (not IDENTP(op)) or (op = "*") or (op = "**") => NIL - (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL - -- if there is a semicolon in the name then it is the name of - -- a compiled spad function - null (e := STRPOS('"_;",op',1,NIL)) => NIL - (char(" ") = (y := op'.1)) or (char("*") = y) => NIL - table := MAKETRTTABLE('"0123456789",NIL) - s := STRPOSL(table,op',1,true) - null(s) or s > e => NIL - SUBSTRING(op',s,e-s) - -application2String(op,argl, linkInfo) == - null argl => - (op' := isInternalFunctionName(op)) => op' - app2StringWrap(formWrapId op, linkInfo) - 1=#argl => - first argl is ["<",:.] => concat(op,first argl) - concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) ---op in '(UP SM) => --- newop:= (op = "UP" => "P";"M") --- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) ---op='RM =>concat("M",concat(lbrkSch(), --- argl.0,",",argl.1,rbrkSch(),argl.2)) ---op='MP =>concat("P",concat(argl.0,argl.1)) - op='SEGMENT => - null argl => '".." - (null rest argl) or (null first rest argl) => - concat(first argl, '"..") - concat(first argl, concat('"..", first rest argl)) - concat(app2StringWrap(formWrapId op, linkInfo) , - concat("_(",concat(tuple2String argl,"_)"))) - -app2StringConcat0(x,y) == - FORMAT(NIL, '"~a ~a", x, y) - -app2StringWrap(string, linkInfo) == - not linkInfo => string - $formatSigAsTeX = 1 => string - $formatSigAsTeX = 2 => - str2 := "app2StringConcat0"/form2Fence linkInfo - sep := '"`" - FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", - str2, string) - error "Bad value for $formatSigAsTeX" - -record2String x == - argPart := NIL - for [":",a,b] in x repeat argPart:= - concat(argPart,",",a,": ",form2StringLocal b) - null argPart => '"Record()" - concat("Record_(",rest argPart,"_)") - -plural(n,string) == - suffix:= - n = 1 => '"" - '"s" - [:bright n,string,suffix] - -formatIf pred == - not pred => nil - pred in '(T (QUOTE T)) => nil - concat('%b,'"if",'%d,pred2English pred) - -formatPredParts s == - s is ['QUOTE,s1] => formatPredParts s1 - s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] - s is ['devaluate,s1] => formatPredParts s1 - s is ['getDomainView,s1,.] => formatPredParts s1 - s is ['SUBST,a,b,c] => -- this is a signature - s1 := formatPredParts SUBST(formatPredParts a,b,c) - s1 isnt [fun,sig] => s1 - ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] - s - -pred2English x == - x is ['IF,cond,thenClause,elseClause] => - c := concat('"if ",pred2English cond) - t := concat('" then ",pred2English thenClause) - e := concat('" else ",pred2English elseClause) - concat(c,t,e) - x is ['AND,:l] => - tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['OR,:l] => - tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] - concat(pred2English first l,tail) - x is ['NOT,l] => - concat('"not ",pred2English l) - x is [op,a,b] and op in '(has ofCategory) => - concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) - x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => - concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, - prefix2String0 formatPredParts b) - x is [op,a,b] and op in '(ofType getDomainView) => - if b is ['QUOTE,b'] then b := b' - concat(pred2English a,'": ",form2String abbreviate b) - x is [op,a,b] and op in '(isDomain domainEqual) => - concat(pred2English a,'" = ",form2String abbreviate b) - x is [op,:.] and (translation := LASSOC(op,'( - (_< . " < ") (_<_= . " <= ") - (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => - concat(pred2English a,translation,pred2English b) - x is ['ATTRIBUTE,form] => - concat("attribute: ",form2String form) - form2String x - -object2String x == - STRINGP x => x - IDENTP x => PNAME x - NULL x => '"" - PAIRP x => STRCONC(object2String first x, object2String rest x) - WRITE_-TO_-STRING x - -object2Identifier x == - IDENTP x => x - STRINGP x => INTERN x - INTERN WRITE_-TO_-STRING x - -blankList x == "append"/[[BLANK,y] for y in x] ---------------------> NEW DEFINITION (see cformat.boot.pamphlet) -pkey keyStuff == - if not PAIRP keyStuff then keyStuff := [keyStuff] - allMsgs := ['" "] - while not null keyStuff repeat - dbN := NIL - argL := NIL - key := first keyStuff - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - while PAIRP next repeat - if CAR next = 'dbN then dbN := CADR next - else argL := next - keyStuff := IFCDR keyStuff - next := IFCAR keyStuff - oneMsg := returnStLFromKey(key,argL,dbN) - allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] - allMsgs - -string2Float s == - -- takes a string, calls the parser on it and returns a float object - p := ncParseFromString s - p isnt [["$elt", FloatDomain, "float"], x, y, z] => - systemError '"string2Float: did not get a float expression" - flt := getFunctionFromDomain("float", FloatDomain, - [$Integer, $Integer, $PositiveInteger]) - SPADCALL(x, y, z, flt) - - - -form2Fence form == - -- body of dbMkEvalable - [op, :.] := form - kind := GETDATABASE(op,'CONSTRUCTORKIND) - kind = 'category => form2Fence1 form - form2Fence1 mkEvalable form - -form2Fence1 x == - x is [op,:argl] => - op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] - ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] - IDENTP x => FORMAT(NIL, '"|~a|", x) --- [x] - ['" ", x] - -form2FenceQuote x == - NUMBERP x => [STRINGIMAGE x] - SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] - atom x => '"??" - ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2FenceQuoteTail x == - null x => ['")"] - atom x => ['" . ",:form2FenceQuote x,'")"] - ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] - -form2StringList u == - atom (r := form2String u) => [r] - r diff --git a/src/interp/format.boot.pamphlet b/src/interp/format.boot.pamphlet new file mode 100644 index 00000000..e4c83a31 --- /dev/null +++ b/src/interp/format.boot.pamphlet @@ -0,0 +1,802 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp format.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Functions for display formatting system objects + +-- some of these are redundant and should be compacted +$formatSigAsTeX := 1 + +--% Formatting modemaps + +sayModemap m == + -- sayMSG formatModemap displayTranModemap m + sayMSG formatModemap old2NewModemaps displayTranModemap m + +sayModemapWithNumber(m,n) == + msg := reverse cleanUpSegmentedMsg reverse ["%i","%i",'" ", + STRCONC(lbrkSch(),object2String n,rbrkSch()), + :formatModemap displayTranModemap m,"%u","%u"] + sayMSG flowSegmentedMsg(reverse msg,$LINELENGTH,3) + +displayOpModemaps(op,modemaps) == + TERPRI() + count:= #modemaps + phrase:= (count=1 => 'modemap;'modemaps) + sayMSG ['%b,count,'%d,phrase,'" for",'%b,op,'%d,'":"] + for modemap in modemaps repeat sayModemap modemap + +displayTranModemap (mm is [[x,:sig],[pred,:y],:z]) == + -- The next 8 lines are a HACK to deal with the "partial" definition + -- JHD/RSS + if pred is ['partial,:pred'] then + [b,:c]:=sig + sig:=[['Union,b,'"failed"],:c] + mm:=[[x,:sig],[pred',:y],:z] + else if pred = 'partial then + [b,:c]:=sig + sig:=[['Union,b,'"failed"],:c] + mm:=[[x,:sig],y,:z] + mm' := EQSUBSTLIST('(m n p q r s t i j k l), + MSORT listOfPredOfTypePatternIds pred,mm) + EQSUBSTLIST('(D D1 D2 D3 D4 D5 D6 D7 D8 D9 D10 D11 D12 D13 D14), + MSORT listOfPatternIds [sig,[pred,:y]],mm') + +listOfPredOfTypePatternIds p == + p is ['AND,:lp] or p is ['OR,:lp] => + UNIONQ([:listOfPredOfTypePatternIds p1 for p1 in lp],NIL) + p is [op,a,.] and op = 'ofType => + isPatternVar a => [a] + nil + nil + +removeIsDomains pred == + pred is ['isDomain,a,b] => true + pred is ['AND,:predl] => + MKPF([x for x in predl | x isnt ['isDomain,:.]],'AND) + pred + +canRemoveIsDomain? pred == + -- returns nil OR an alist for substitutions of domains ordered so that + -- after substituting for each pair in turn, no left-hand names remain + alist := + pred is ['isDomain,a,b] => [[a,:b],:alist] + pred is ['AND,:predl] => + [[a,:b] for pred in predl | pred is ['isDomain,a,b]] + findSubstitutionOrder? alist + +findSubstitutionOrder? alist == fn(alist,nil) where + -- returns NIL or an appropriate substituion order + fn(alist,res) == + null alist => NREVERSE res + choice := or/[x for (x:=[a,:b]) in alist | null containedRight(a,alist)] => + fn(delete(choice,alist),[choice,:res]) + nil + +containedRight(x,alist)== or/[CONTAINED(x,y) for [.,:y] in alist] + +removeIsDomainD pred == + pred is ['isDomain,'D,D] => + [D,nil] + pred is ['AND,:preds] => + D := nil + for p in preds while not D repeat + p is ['isDomain,'D,D1] => + D := D1 + npreds := delete(['isDomain,'D,D1],preds) + D => + 1 = #npreds => [D,first npreds] + [D,['AND,:npreds]] + nil + nil + +formatModemap modemap == + [[dc,target,:sl],pred,:.]:= modemap + if alist := canRemoveIsDomain? pred then + dc:= substInOrder(alist,dc) + pred:= substInOrder(alist,removeIsDomains pred) + target:= substInOrder(alist,target) + sl:= substInOrder(alist,sl) + else if removeIsDomainD pred is [D,npred] then + pred := SUBST(D,'D,npred) + target := SUBST(D,'D,target) + sl := SUBST(D,'D,sl) + predPart:= formatIf pred + targetPart:= prefix2String target + argTypeList:= + null sl => nil + concat(prefix2String first sl,fn(rest sl)) where + fn l == + null l => nil + concat(",",prefix2String first l,fn rest l) + argPart:= + #sl<2 => argTypeList + ['"_(",:argTypeList,'"_)"] + fromPart:= + if dc = 'D and D + then concat('%b,'"from",'%d,prefix2String D) + else concat('%b,'"from",'%d,prefix2String dc) + firstPart:= concat('" ",argPart,'" -> ",targetPart) + sayWidth firstPart + sayWidth fromPart > 74 => --allow 5 spaces for " [n]" + fromPart:= concat('" ",fromPart) + secondPart := + sayWidth fromPart + sayWidth predPart < 75 => + concat(fromPart,predPart) + concat(fromPart,'%l,predPart) + concat(firstPart,'%l,secondPart) + firstPart:= concat(firstPart,fromPart) + sayWidth firstPart + sayWidth predPart < 80 => + concat(firstPart,predPart) + concat(firstPart,'%l,predPart) + +substInOrder(alist,x) == + alist is [[a,:b],:y] => substInOrder(y,SUBST(b,a,x)) + x + +reportOpSymbol op1 == + op := (STRINGP op1 => INTERN op1; op1) + modemaps := getAllModemapsFromDatabase(op,nil) + null modemaps => + ok := true + sayKeyedMsg("S2IF0010",[op1]) + if SIZE PNAME op1 < 3 then + x := UPCASE queryUserKeyedMsg("S2IZ0060",[op1]) + null MEMQ(STRING2ID_-N(x,1),'(Y YES)) => + ok := nil + sayKeyedMsg("S2IZ0061",[op1]) + ok => apropos [op1] + sayNewLine() + -- filter modemaps on whether they are exposed + mmsE := mmsU := NIL + for mm in modemaps repeat + isFreeFunctionFromMm(mm) or isExposedConstructor getDomainFromMm(mm) => mmsE := [mm,:mmsE] + mmsU := [mm,:mmsU] + if mmsE then + sayMms(op,mmsE,'"exposed") where + sayMms(op,mms,label) == + m := # mms + sayMSG + m = 1 => + ['"There is one",:bright label,'"function called", + :bright op,'":"] + ['"There are ",m,:bright label,'"functions called", + :bright op,'":"] + for mm in mms for i in 1.. repeat + sayModemapWithNumber(mm,i) + if mmsU then + if mmsE then sayNewLine() + sayMms(op,mmsU,'"unexposed") + nil + +formatOpType (form:=[op,:argl]) == + null argl => unabbrev op + form2String [unabbrev op, :argl] + +formatOperationAlistEntry (entry:= [op,:modemaps]) == + -- alist has entries of the form: ((op sig) . pred) + -- opsig on this list => op is defined only when the predicate is true + ans:= nil + for [sig,.,:predtail] in modemaps repeat + pred := (predtail is [p,:.] => p; 'T) + -- operation is always defined + ans := + [concat(formatOpSignature(op,sig),formatIf pred),:ans] + ans + +formatOperation([[op,sig],.,[fn,.,n]],domain) == + opSigString := formatOpSignature(op,sig) + INTEGERP n and Undef = KAR domain.n => + if INTEGERP $commentedOps then $commentedOps := $commentedOps + 1 + concat(" --",opSigString) + opSigString + +formatOpSignature(op,sig) == + concat('%b,formatOpSymbol(op,sig),'%d,": ",formatSignature sig) + +formatOpConstant op == + concat('%b,formatOpSymbol(op,'($)),'%d,'": constant") + +formatOpSymbol(op,sig) == + if op = 'Zero then op := "0" + else if op = 'One then op := "1" + null sig => op + quad := specialChar 'quad + n := #sig + (op = 'elt) and (n = 3) => + (CADR(sig) = '_$) => + STRINGP (sel := CADDR(sig)) => + [quad,".",sel] + [quad,".",quad] + op + STRINGP op or GET(op,"Led") or GET(op,"Nud") => + n = 3 => + if op = 'SEGMENT then op := '".." + op = 'in => [quad,'" ",op,'" ",quad] +-- stop exquo from being displayed as infix (since it is not accepted +-- as such by the interpreter) + op = 'exquo => op + [quad,op,quad] + n = 2 => + not GET(op,"Nud") => [quad,op] + [op,quad] + op + op + +formatAttribute x == + atom x => [" ",x] + x is [op,:argl] => + for x in argl repeat + argPart:= NCONC(argPart,concat(",",formatAttributeArg x)) + argPart => concat(" ",op,"_(",rest argPart,"_)") + [" ",op] + +formatAttributeArg x == + STRINGP x and x ='"*" => "_"*_"" + atom x => formatOpSymbol (x,nil) + x is [":",op,["Mapping",:sig]] => + concat('%b,formatOpSymbol(op,sig),": ",'%d,formatMapping sig) + prefix2String0 x + +formatMapping sig == + "STRCONC"/concat("Mapping(",formatSignature sig,")") + +dollarPercentTran x == + -- Translate $ to %. We actually return %% so that the message + -- printer will display a single % + x is [y,:z] => + y1 := dollarPercentTran y + z1 := dollarPercentTran z + EQ(y, y1) and EQ(z, z1) => x + [y1, :z1] + x = "$" or x = '"$" => "%%" + x + +formatSignatureAsTeX sig == + $formatSigAsTeX: local := 2 + formatSignature0 sig + +formatSignature sig == + $formatSigAsTeX: local := 1 + formatSignature0 sig + +formatSignatureArgs sml == + $formatSigAsTeX: local := 1 + formatSignatureArgs0 sml + +formatSignature0 sig == + null sig => "() -> ()" + INTEGERP sig => '"hashcode" + [tm,:sml] := sig + sourcePart:= formatSignatureArgs0 sml + targetPart:= prefix2String0 tm + dollarPercentTran concat(sourcePart,concat(" -> ",targetPart)) + +formatSignatureArgs0(sml) == +-- formats the arguments of a signature + null sml => ["_(_)"] + null rest sml => prefix2String0 first sml + argList:= prefix2String0 first sml + for m in rest sml repeat + argList:= concat(argList,concat(",",prefix2String0 m)) + concat("_(",concat(argList,"_)")) + +--% Conversions to string form + +expr2String x == + atom (u:= prefix2String0 x) => u + "STRCONC"/[atom2String y for y in u] + +-- exports (this is a badly named bit of sillyness) +prefix2StringAsTeX form == + form2StringAsTeX form + +prefix2String form == + form2String form + +-- local version +prefix2String0 form == + form2StringLocal form + +-- SUBRP form => formWrapId BPINAME form +-- atom form => +-- form=$EmptyMode or form=$quadSymbol => formWrapId specialChar 'quad +-- STRINGP form => formWrapId form +-- IDENTP form => +-- constructor? form => app2StringWrap(formWrapId form, [form]) +-- formWrapId form +-- formWrapId STRINGIMAGE form + +form2StringWithWhere u == + $permitWhere : local := true + $whereList: local := nil + s:= form2String u + $whereList => concat(s,'%b,'"where",'%d,"%i",$whereList,"%u") + s + +form2StringWithPrens form == + null (argl := rest form) => [first form] + null rest argl => [first form,"(",first argl,")"] + form2String form + +formString u == + x := form2String u + atom x => STRINGIMAGE x + "STRCONC"/[STRINGIMAGE y for y in x] + +form2String u == + $formatSigAsTeX: local := 1 + form2StringLocal u + +form2StringAsTeX u == + $formatSigAsTeX: local := 2 + form2StringLocal u + +form2StringLocal u == +--+ + $NRTmonitorIfTrue : local := nil + $fortInts2Floats : local := nil + form2String1 u + +constructorName con == + $abbreviateTypes => abbreviate con + con + +form2String1 u == + ATOM u => + u=$EmptyMode or u=$quadSymbol => formWrapId specialChar 'quad + IDENTP u => + constructor? u => app2StringWrap(formWrapId u, [u]) + u + SUBRP u => formWrapId BPINAME u + STRINGP u => formWrapId u + WRITE_-TO_-STRING formWrapId u + u1 := u + op := CAR u + argl := CDR u + op='Join or op= 'mkCategory => formJoin1(op,argl) + $InteractiveMode and (u:= constructor? op) => + null argl => app2StringWrap(formWrapId constructorName op, u1) + op = "NTuple" => [ form2String1 first argl, "*"] + op = "Map" => ["(",:formatSignature0 [argl.1,argl.0],")"] + op = 'Record => record2String(argl) + null (conSig := getConstructorSignature op) => + application2String(constructorName op,[form2String1(a) for a in argl], u1) + ml := rest conSig + if not freeOfSharpVars ml then + ml:=SUBLIS([[pvar,:val] for pvar in $FormalMapVariableList + for val in argl], ml) + argl:= formArguments2String(argl,ml) + -- extra null check to handle mutable domain hack. + null argl => constructorName op + application2String(constructorName op,argl, u1) + op = "Mapping" => ["(",:formatSignature argl,")"] + op = "Record" => record2String(argl) + op = 'Union => + application2String(op,[form2String1 x for x in argl], u1) + op = ":" => + null argl => [ '":" ] + null rest argl => [ '":", form2String1 first argl ] + formDecl2String(argl.0,argl.1) + op = "#" and PAIRP argl and LISTP CAR argl => + STRINGIMAGE SIZE CAR argl + op = 'Join => formJoin2String argl + op = "ATTRIBUTE" => form2String1 first argl + op='Zero => 0 + op='One => 1 + op = 'AGGLST => tuple2String argl + op = 'BRACKET => + argl' := form2String1 first argl + ["[",:(atom argl' => [argl']; argl'),"]"] + op = "SIGNATURE" => + [operation,sig] := argl + concat(operation,": ",formatSignature sig) + op = 'COLLECT => formCollect2String argl + op = 'construct => + concat(lbrkSch(), + tuple2String [form2String1 x for x in argl],rbrkSch()) + op = "SEGMENT" => + null argl => '".." + lo := form2String1 first argl + argl := rest argl + (null argl) or null (first argl) => [lo, '".."] + [lo, '"..", form2String1 first argl] + isBinaryInfix op => fortexp0 [op,:argl] + -- COMPILED_-FUNCTION_-P(op) => form2String1 coerceMap2E(u1,NIL) + application2String(op,[form2String1 x for x in argl], u1) + +formWrapId id == + $formatSigAsTeX = 1 => id + $formatSigAsTeX = 2 => + sep := '"`" + FORMAT(NIL,'"\verb~a~a~a",sep, id, sep) + error "Bad formatSigValue" + +formArguments2String(argl,ml) == [fn(x,m) for x in argl for m in ml] where + fn(x,m) == + x=$EmptyMode or x=$quadSymbol => specialChar 'quad + STRINGP(x) or IDENTP(x) => x + x is [ ='_:,:.] => form2String1 x + isValidType(m) and PAIRP(m) and + (GETDATABASE(first(m),'CONSTRUCTORKIND) = 'domain) => + (x' := coerceInteractive(objNewWrap(x,m),$OutputForm)) => + form2String1 objValUnwrap x' + form2String1 x + form2String1 x + +formDecl2String(left,right) == + $declVar: local := left + whereBefore := $whereList + ls:= form2StringLocal left + rs:= form2StringLocal right + NE($whereList,whereBefore) and $permitWhere => ls + concat(form2StringLocal ls,'": ",rs) + +formJoin1(op,u) == + if op = 'Join then [:argl,last] := u else (argl := nil; last := [op,:u]) + last is [id,.,:r] and id in '(mkCategory CATEGORY) => + $abbreviateJoin = true => concat(formJoin2 argl,'%b,'"with",'%d,'"...") + $permitWhere = true => + opList:= formatJoinKey(r,id) + $whereList:= concat($whereList,"%l",$declVar,": ", + formJoin2 argl,'%b,'"with",'%d,"%i",opList,"%u") + formJoin2 argl + opList:= formatJoinKey(r,id) + suffix := concat('%b,'"with",'%d,"%i",opList,"%u") + concat(formJoin2 argl,suffix) + formJoin2 u + +formatJoinKey(r,key) == + key = 'mkCategory => + r is [opPart,catPart,:.] => + opString := + opPart is [='LIST,:u] => + "append"/[concat("%l",formatOpSignature(op,sig),formatIf pred) + for [='QUOTE,[[op,sig],pred]] in u] + nil + catString := + catPart is [='LIST,:u] => + "append"/[concat("%l",'" ",form2StringLocal con,formatIf pred) + for [='QUOTE,[con,pred]] in u] + nil + concat(opString,catString) + '"?? unknown mkCategory format ??" + -- otherwise we have the CATEGORY form + "append"/[fn for x in r] where fn == + x is ['SIGNATURE,op,sig] => concat("%l",formatOpSignature(op,sig)) + x is ['ATTRIBUTE,a] => concat("%l",formatAttribute a) + x + +formJoin2 argl == +-- argl is a list of categories NOT containing a "with" + null argl => '"" + 1=#argl => form2StringLocal argl.0 + application2String('Join,[form2StringLocal x for x in argl], NIL) + +formJoin2String (u:=[:argl,last]) == + last is ["CATEGORY",.,:atsigList] => + postString:= concat("_(",formTuple2String atsigList,"_)") + #argl=1 => concat(first argl,'" with ",postString) + concat(application2String('Join,argl, NIL)," with ",postString) + application2String('Join,u, NIL) + +formCollect2String [:itl,body] == + ["_(",body,:"append"/[formIterator2String x for x in itl],"_)"] + +formIterator2String x == + x is ["STEP",y,s,.,:l] => + tail:= (l is [f] => form2StringLocal f; nil) + concat("for ",y," in ",s,'"..",tail) + x is ["tails",y] => concat("tails ",formatIterator y) + x is ["reverse",y] => concat("reverse ",formatIterator y) + x is ["|",y,p] => concat(formatIterator y," | ",form2StringLocal p) + x is ["until",p] => concat("until ",form2StringLocal p) + x is ["while",p] => concat("while ",form2StringLocal p) + systemErrorHere "formatIterator" + +tuple2String argl == + null argl => nil + string := first argl + if string in '("failed" "nil" "prime" "sqfr" "irred") + then string := STRCONC('"_"",string,'"_"") + else string := + ATOM string => object2String string + [f x for x in string] where + f x == + ATOM x => object2String x + -- [f CAR x,:f CDR x] + [f y for y in x] + for x in rest argl repeat + if x in '("failed" "nil" "prime" "sqfr" "irred") then + x := STRCONC('"_"",x,'"_"") + string:= concat(string,concat(",",f x)) + string + +script2String s == + null s => '"" -- just to be safe + if not PAIRP s then s := [s] + linearFormatForm(CAR s, CDR s) + +linearFormatName x == + atom x => x + linearFormat x + +linearFormat x == + atom x => x + x is [op,:argl] and atom op => + argPart:= + argl is [a,:l] => [a,:"append"/[[",",x] for x in l]] + nil + [op,"(",:argPart,")"] + [linearFormat y for y in x] + +numOfSpadArguments id == + char("*") = (s:= PNAME id).0 => + +/[n for i in 1.. while INTEGERP (n:=PARSE_-INTEGER PNAME s.i)] + keyedSystemError("S2IF0012",[id]) + +linearFormatForm(op,argl) == + s:= PNAME op + indexList:= [PARSE_-INTEGER PNAME d for i in 1.. while + (DIGITP (d:= s.(maxIndex:= i)))] + cleanOp:= INTERN ("STRCONC"/[PNAME s.i for i in maxIndex..MAXINDEX s]) + fnArgs:= + indexList.0 > 0 => + concat('"(",formatArgList take(-indexList.0,argl),'")") + nil + if #indexList > 1 then + scriptArgs:= formatArgList take(indexList.1,argl) + argl := drop(indexList.1,argl) + for i in rest rest indexList repeat + subArglist:= take(i,argl) + argl:= drop(i,argl) + scriptArgs:= concat(scriptArgs,";",formatArgList subArglist) + scriptArgs:= + scriptArgs => concat(specialChar 'lbrk,scriptArgs, specialChar 'rbrk) + nil + l := [(STRINGP f => f; STRINGIMAGE f) for f in + concat(cleanOp,scriptArgs,fnArgs)] + "STRCONC"/l + +formatArgList l == + null l => nil + acc:= linearFormat first l + for x in rest l repeat + acc:= concat(acc,",",linearFormat x) + acc + +formTuple2String argl == + null argl => nil + string:= form2StringLocal first argl + for x in rest argl repeat + string:= concat(string,concat(",",form2StringLocal x)) + string + +isInternalFunctionName(op) == + (not IDENTP(op)) or (op = "*") or (op = "**") => NIL + (1 = SIZE(op':= PNAME op)) or (char("*") ^= op'.0) => NIL + -- if there is a semicolon in the name then it is the name of + -- a compiled spad function + null (e := STRPOS('"_;",op',1,NIL)) => NIL + (char(" ") = (y := op'.1)) or (char("*") = y) => NIL + table := MAKETRTTABLE('"0123456789",NIL) + s := STRPOSL(table,op',1,true) + null(s) or s > e => NIL + SUBSTRING(op',s,e-s) + +application2String(op,argl, linkInfo) == + null argl => + (op' := isInternalFunctionName(op)) => op' + app2StringWrap(formWrapId op, linkInfo) + 1=#argl => + first argl is ["<",:.] => concat(op,first argl) + concat(app2StringWrap(formWrapId op, linkInfo)," ",first argl) +--op in '(UP SM) => +-- newop:= (op = "UP" => "P";"M") +-- concat(newop,concat(lbrkSch(),argl.0,rbrkSch(),argl.1)) +--op='RM =>concat("M",concat(lbrkSch(), +-- argl.0,",",argl.1,rbrkSch(),argl.2)) +--op='MP =>concat("P",concat(argl.0,argl.1)) + op='SEGMENT => + null argl => '".." + (null rest argl) or (null first rest argl) => + concat(first argl, '"..") + concat(first argl, concat('"..", first rest argl)) + concat(app2StringWrap(formWrapId op, linkInfo) , + concat("_(",concat(tuple2String argl,"_)"))) + +app2StringConcat0(x,y) == + FORMAT(NIL, '"~a ~a", x, y) + +app2StringWrap(string, linkInfo) == + not linkInfo => string + $formatSigAsTeX = 1 => string + $formatSigAsTeX = 2 => + str2 := "app2StringConcat0"/form2Fence linkInfo + sep := '"`" + FORMAT(NIL, '"\lispLink{\verb!(|conPage| '~a)!}{~a}", + str2, string) + error "Bad value for $formatSigAsTeX" + +record2String x == + argPart := NIL + for [":",a,b] in x repeat argPart:= + concat(argPart,",",a,": ",form2StringLocal b) + null argPart => '"Record()" + concat("Record_(",rest argPart,"_)") + +plural(n,string) == + suffix:= + n = 1 => '"" + '"s" + [:bright n,string,suffix] + +formatIf pred == + not pred => nil + pred in '(T (QUOTE T)) => nil + concat('%b,'"if",'%d,pred2English pred) + +formatPredParts s == + s is ['QUOTE,s1] => formatPredParts s1 + s is ['LIST,:s1] => [formatPredParts s2 for s2 in s1] + s is ['devaluate,s1] => formatPredParts s1 + s is ['getDomainView,s1,.] => formatPredParts s1 + s is ['SUBST,a,b,c] => -- this is a signature + s1 := formatPredParts SUBST(formatPredParts a,b,c) + s1 isnt [fun,sig] => s1 + ['SIGNATURE,fun,[formatPredParts(r) for r in sig]] + s + +pred2English x == + x is ['IF,cond,thenClause,elseClause] => + c := concat('"if ",pred2English cond) + t := concat('" then ",pred2English thenClause) + e := concat('" else ",pred2English elseClause) + concat(c,t,e) + x is ['AND,:l] => + tail:="append"/[concat(bright '"and",pred2English x) for x in rest l] + concat(pred2English first l,tail) + x is ['OR,:l] => + tail:= "append"/[concat(bright '"or",pred2English x) for x in rest l] + concat(pred2English first l,tail) + x is ['NOT,l] => + concat('"not ",pred2English l) + x is [op,a,b] and op in '(has ofCategory) => + concat(pred2English a,'%b,'"has",'%d,form2String abbreviate b) + x is [op,a,b] and op in '(HasSignature HasAttribute HasCategory) => + concat(prefix2String0 formatPredParts a,'%b,'"has",'%d, + prefix2String0 formatPredParts b) + x is [op,a,b] and op in '(ofType getDomainView) => + if b is ['QUOTE,b'] then b := b' + concat(pred2English a,'": ",form2String abbreviate b) + x is [op,a,b] and op in '(isDomain domainEqual) => + concat(pred2English a,'" = ",form2String abbreviate b) + x is [op,:.] and (translation := LASSOC(op,'( + (_< . " < ") (_<_= . " <= ") + (_> . " > ") (_>_= . " >= ") (_= . " = ") (_^_= . " _^_= ")))) => + concat(pred2English a,translation,pred2English b) + x is ['ATTRIBUTE,form] => + concat("attribute: ",form2String form) + form2String x + +object2String x == + STRINGP x => x + IDENTP x => PNAME x + NULL x => '"" + PAIRP x => STRCONC(object2String first x, object2String rest x) + WRITE_-TO_-STRING x + +object2Identifier x == + IDENTP x => x + STRINGP x => INTERN x + INTERN WRITE_-TO_-STRING x + +blankList x == "append"/[[BLANK,y] for y in x] +--------------------> NEW DEFINITION (see cformat.boot.pamphlet) +pkey keyStuff == + if not PAIRP keyStuff then keyStuff := [keyStuff] + allMsgs := ['" "] + while not null keyStuff repeat + dbN := NIL + argL := NIL + key := first keyStuff + keyStuff := IFCDR keyStuff + next := IFCAR keyStuff + while PAIRP next repeat + if CAR next = 'dbN then dbN := CADR next + else argL := next + keyStuff := IFCDR keyStuff + next := IFCAR keyStuff + oneMsg := returnStLFromKey(key,argL,dbN) + allMsgs := ['" ", :NCONC (oneMsg,allMsgs)] + allMsgs + +string2Float s == + -- takes a string, calls the parser on it and returns a float object + p := ncParseFromString s + p isnt [["$elt", FloatDomain, "float"], x, y, z] => + systemError '"string2Float: did not get a float expression" + flt := getFunctionFromDomain("float", FloatDomain, + [$Integer, $Integer, $PositiveInteger]) + SPADCALL(x, y, z, flt) + + + +form2Fence form == + -- body of dbMkEvalable + [op, :.] := form + kind := GETDATABASE(op,'CONSTRUCTORKIND) + kind = 'category => form2Fence1 form + form2Fence1 mkEvalable form + +form2Fence1 x == + x is [op,:argl] => + op = 'QUOTE => ['"(QUOTE ",:form2FenceQuote first argl,'")"] + ['"(", FORMAT(NIL, '"|~a|", op),:"append"/[form2Fence1 y for y in argl],'")"] + IDENTP x => FORMAT(NIL, '"|~a|", x) +-- [x] + ['" ", x] + +form2FenceQuote x == + NUMBERP x => [STRINGIMAGE x] + SYMBOLP x => [FORMAT(NIL, '"|~a|", x)] + atom x => '"??" + ['"(",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +form2FenceQuoteTail x == + null x => ['")"] + atom x => ['" . ",:form2FenceQuote x,'")"] + ['" ",:form2FenceQuote first x,:form2FenceQuoteTail rest x] + +form2StringList u == + atom (r := form2String u) => [r] + r +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/fortcall.boot b/src/interp/fortcall.boot deleted file mode 100644 index 72d79948..00000000 --- a/src/interp/fortcall.boot +++ /dev/null @@ -1,798 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -makeFort(name,args,decls,results,returnType,aspInfo) == - -- Create an executable Fortran file to call a given library function, - -- and a stub Axiom function to process its arguments. - -- the following is a list of objects for which values need not be - -- passed by the user. - dummies := [SECOND(u) for u in args | EQUAL(car u,0)] - args := [untangle2(u) for u in args] -- lose spad Union representation - where untangle2 u == - atom (v := rest(u)) => v - first(v) - userArgs := [u for u in args | not member(u,dummies)] -- Temporary - decls := [untangle(u) for u in decls] -- lose spad Union representation - where untangle u == - [if atom(rest(v)) then rest(v) else _ - [if atom(w) then w else rest(w) for w in rest(v)] for v in u] - makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) - -makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) == - asps := [first(u) for u in aspInfo] - -- Now reorder the arguments so that all the scalars come first, so - -- that when we come to deal with arrays we know all the dimensions. - scalarArgs := [u for u in args | atom getFortranType(u,decls)] - arrayArgs := [u for u in args | not member(u,scalarArgs)] - orderedArgs := [:scalarArgs,:arrayArgs] - file := if $fortranDirectory then - STRCONC($fortranDirectory,"/",STRINGIMAGE name) - else - STRINGIMAGE name - makeFortranFun(name,orderedArgs,args,dummies,decls,results,file, - $fortranDirectory,returnType,asps) - makeSpadFun(name,userArgs,orderedArgs,dummies,decls,results,returnType,asps, - aspInfo,file) - name - -makeFortranFun(name,args,fortranArgs,dummies,decls,results,file,dir, - returnType,asps) == - -- Create a C file to call the library function, and compile it. - fp := MAKE_-OUTSTREAM(STRCONC(file,".c")) - writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) - if null dir then dir := '"." - asps => SYSTEM STRCONC("cc -c ",file,".c ; mv ",file,".o ",dir) - SYSTEM STRCONC("cc ",file,".c -o ",file,".spadexe ",$fortranLibraries) - -writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) == - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#include ",fp) - WRITE_-LINE('"#ifndef NULL",fp) - WRITE_-LINE('"#define NULL 0",fp) - WRITE_-LINE('"#endif NULL",fp) - WRITE_-LINE('"#define MAX__ARRAY(x) (x ? x : 20000)",fp) - WRITE_-LINE('"#define CHECK(x) if (!x) {fprintf(stderr,_"xdr failed_"); exit(1);}",fp) - WRITE_-LINE('"void main()",fp) - WRITE_-LINE('"{",fp) - WRITE_-LINE('" XDR xdrs;",fp) - WRITE_-LINE('" {",fp) - if $addUnderscoreToFortranNames then - routineName := STRCONC(name,STRING(95)) - else - routineName := name - -- If it is a function then give it somewhere to stick its result: - if returnType then - returnName := INTERN STRCONC(name,"__result") - wl(['" ",getCType returnType,'" ",returnName,'",",routineName,'"();"],fp) - -- print out type declarations for the Fortran parameters, and build an - -- ordered list of pairs [ , ] - argList := nil - for a in args repeat - argList := [[a, getCType getFortranType(a,decls)], :argList] - printDec(SECOND first argList,a,asps,fp) - argList := nreverse argList; - -- read in the data - WRITE_-LINE('" xdrstdio__create(&xdrs, stdin, XDR__DECODE);",fp) - for a in argList repeat - if LISTP SECOND a then writeMalloc(first a,first SECOND a,rest SECOND a,fp) - not MEMQ(first a,[:dummies,:asps]) => writeXDR(a,'"&xdrs",fp) - -- now call the Library routine. FORTRAN names may have an underscore - -- appended. - if returnType then - wt(['" ",returnName,'"="],fp) - else - wt(['" "],fp) - wt([routineName,'"("],fp) - if first fortranArgs then - printCName(first fortranArgs,isPointer?(first fortranArgs,decls),asps,fp) - for a in rest fortranArgs repeat - PRINC('",",fp) - printCName(a,isPointer?(a,decls),asps,fp) - writeStringLengths(fortranArgs,decls,fp) - WRITE_-LINE('");",fp) - -- now export the results. - WRITE_-LINE('" xdrstdio__create(&xdrs, stdout, XDR__ENCODE);",fp) - if returnType then - writeXDR([returnName,getCType returnType],'"&xdrs",fp) - for r in results repeat - writeXDR([r,getCType getFortranType(r,decls)],'"&xdrs",fp) - WRITE_-LINE('" exit(0);",fp) - WRITE_-LINE('" }",fp) - WRITE_-LINE('"}",fp) - -writeStringLengths(fortranArgs,decls,fp) == - for a in fortranArgs repeat - if isString?(a,decls) then wt(['",&",a,'"__length"],fp) - -isString?(u,decls) == - EQUAL(ty := getFortranType(u,decls),"character") or - LISTP(ty) and EQUAL(first ty,"character") - -isPointer?(u,decls) == - ty := getFortranType(u,decls) - LISTP(ty) or ty in ["character","complex","double complex"] - -printCName(u,ispointer,asps,fp) == - member(u,asps) => - PRINC(u,fp) - if $addUnderscoreToFortranNames then PRINC(STRING(95),fp) - if not ispointer then PRINC('"&",fp) - PRINC(u,fp) - -getFortranType(u,decls) == - -- find u in decls, return the given (Fortran) type. - result := nil - for d in decls repeat for dec in rest d repeat - atom(dec) and dec=u => - return( result := first d ) - LISTP(dec) and first(dec)=u => - return( result := [first d,:rest dec] ) - result => result - error ['"Undeclared Fortran parameter: ",u] - -getCType t == - -- Return the equivalent C type. - LISTP(t) => - --[if first(t)="character" then '"char" else getCType first t,:rest t] - first(t)="character" => ['"char",:rest t] - first(t)="complex" => ['"float",2,:rest t] - first(t)="double complex" => ['"double",2,:rest t] - [getCType first t,:rest t] - t="double" => '"double" - t="double precision" => '"double" - t="integer" => '"int" - t="real" => '"float" - t="logical" => '"int" - t="character" => ['"char",1] - t="complex" => ['"float",2] --'"Complex" -- we use our own typedef - t="double complex" => ['"double",2] --'"DComplex" -- we use our own typedef - error ['"Unrecognised Fortran type: ",t] - -XDRFun t == - LISTP(ty := SECOND t) => - if first(ty)='"char" then '"wrapstring" else '"array" - ty - -printDec(type,dec,asps,fp) == - wt(['" ",if LISTP(type) then first(type) else type,'" "],fp) - member(dec,asps) => - if $addUnderscoreToFortranNames then - wl([dec,STRING(95),'"();"],fp) - else - wl([dec,'"();"],fp) - LISTP(type) => - wl(['"*",dec,'" = NULL;"],fp) - wl(['" u__int ",dec, '"__length = 0;"],fp) - type = '"char" => - wl(['"*",dec,'" = NULL;"],fp) - wl([dec, '";"],fp) - -writeXDR(v,str,fp) == - -- Generate the calls to the filters which will read from the temp - -- file. The CHECK macro ensures that the translation worked. - underscore := STRING CHAR("__:",0) -- to avoid a compiler bug which won't - -- parse " ... __" properly. - wt(['" CHECK(xdr",underscore, XDRFun(v), '"(", str, '",&", first(v)],fp) - if (LISTP (ty :=SECOND v)) and not EQUAL(first ty,'"char") then - wt(['",&",first(v),'"__length,MAX__ARRAY(",first(v),'"__length),"],fp) - wt(['"sizeof(",first(ty),'"),xdr",underscore,first ty],fp) - wl(['"));"],fp) - -prefix2Infix(l) == - atom(l) => [l] - #l=2 => [first l,"(",:prefix2Infix SECOND l,")"] - #l=3 => ["(",:prefix2Infix SECOND l,first l,:prefix2Infix THIRD l,")"] - error '"Function in array dimensions with more than two arguments" - -writeMalloc(name,type,dims,fp) == - -- Write out a malloc for array arguments - -- Need the size as well - wl(['" ",name,'"__length=",prefix2Infix first dims,:[:["*",:prefix2Infix u] - for u in rest dims],'";"], fp) - type = '"char" => - wl(['" ",name,'"=(",type," *)malloc((1+",name, - '"__length)*sizeof(",type,'"));"],fp) - wl(['" ",name,'"=(",type," *)malloc(",name, - '"__length*sizeof(",type,'"));"],fp) - -wl (l,fp) == - for u in l repeat PRINC(u,fp) - TERPRI(fp) - -wt (l,fp) == - for u in l repeat PRINC(u,fp) - --- spadRecordType(v,decs) == --- -- Build a lisp representation of the declaration of a spad record. --- -- This will be the returned type of the spad function which calls the --- -- Fortran code. --- ["Record",:[spadRecordType1(u,decs) for u in v]] --- --- spadRecordType1(u,decls) == --- -- Create a list of the form '( |:| u ) --- [":",u,spadTypeTTT getFortranType(u,decls)] - -spadTypeTTT u == - -- Return the spad domain equivalent to the given Fortran type. - -- Changed by MCD 8/4/94 to reflect correct format for domains in - -- current system. - LISTP u => - first(u)="character" => ["String"] - first(u)="logical" and #u=2 => ["List",["Boolean"]] - first(u)="logical" => ["List",["List",["Boolean"]]] - #u=2 => ["Matrix",spadTypeTTT first u] - #u=3 => ["Matrix",spadTypeTTT first u] - #u=4 => ["ThreeDimensionalMatrix",spadTypeTTT first u] - error '"Can only handle one-, two- and three-dimensional matrices" - u = "double" => ["DoubleFloat"] - u = "double precision" => ["DoubleFloat"] - u = "real" => ["DoubleFloat"] - u = "integer" => ["Integer"] - u = "logical" => ["Boolean"] - u = "character" => ["String"] - u = "complex" => ["Complex",["DoubleFloat"]] - u = "double complex" => ["Complex",["DoubleFloat"]] - error ['"Unrecognised Fortran type: ",u] - -mkQuote l == - [addQuote(u)for u in l] where - addQuote u == - atom u => ['QUOTE,u] - ["construct",:[addQuote(v) for v in u]] - -makeLispList(l) == - outputList := [] - for u in l repeat - outputList := [:outputList, _ - if atom(u) then ['QUOTE,u] else [["$elt","Lisp","construct"],_ - :makeLispList(u)]] - outputList - -makeSpadFun(name,userArgs,args,dummies,decls,results,returnType,asps,aspInfo, - file) == - -- Create an interpreter function for the user to call. - - fType := ["List", ["Record" , [":","key","Symbol"], [":","entry","Any"]]] - - -- To make sure the spad interpreter isn't confused: - if returnType then - returnName := INTERN STRCONC(name,"Result") - decls := [[returnType,returnName], :decls] - results := [returnName, :results] - argNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in userArgs] - aType := [axiomType(a,decls,asps,aspInfo) for a in userArgs] - aspTypes := [SECOND NTH(POSITION(u,userArgs),aType) for u in asps] - nilLst := MAKE_-LIST(#args+1) - decPar := [["$elt","Lisp","construct"],:makeLispList decls] - fargNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in args | - not (MEMQ(u,dummies) or MEMQ(u,asps)) ] - for u in asps repeat - fargNames := delete(INTERN STRCONC(STRINGIMAGE(u),'"__arg"),fargNames) - resPar := ["construct",["@",["construct",:fargNames],_ - ["List",["Any"]]]] - call := [["$elt","Lisp","invokeFortran"],STRCONC(file,".spadexe"),_ - [["$elt","Lisp","construct"],:mkQuote args],_ - [["$elt","Lisp","construct"],:mkQuote union(asps,dummies)], decPar,_ - [["$elt","Lisp","construct"],:mkQuote results],resPar] - if asps then - -- Make a unique(ish) id for asp files - aspId := STRCONC(getEnv('"SPADNUM"), GENTEMP('"NAG")) - body := ["SEQ",:makeAspGenerators(asps,aspTypes,aspId),_ - makeCompilation(asps,file,aspId),_ - ["pretend",call,fType] ] - else - body := ["pretend",call,fType] - interpret ["DEF",[name,:argNames],["Result",:aType],nilLst,_ - [["$elt","Result","construct"],body]] - -stripNil u == - [CAR(u), ["construct",:CADR(u)], if CADDR(u) then "true" else "false"] - -makeUnion aspType == - -- The argument is the type of the asp to be generated. We would like to - -- allow the user to be able to provide a fileName as an alternative - -- argument, so this builds the Union of aspType and FileName. - ["Union",[":","fp",aspType],[":","fn","FileName"]] - -axiomType(a,decls,asps,aspInfo) == - a in asps => - entry := first [u for u in aspInfo | first(u) = a] - ftc := ["$elt","FortranType","construct"] - rc := ["$elt", _ - ["Record",[":","key","Symbol"],[":","entry","FortranType"]], _ - "construct"] - makeUnion ["FortranProgram",_ - a,_ - CADR(entry),_ - ["construct",:mkQuote CADDR entry], _ - [ ["$elt", "SymbolTable","symbolTable"],_ - ["construct",_ - :[[rc,first(v),[ftc,:stripNil rest(v)]] for v in CADDDR entry]]_ - ] ] - spadTypeTTT(getFortranType(a,decls)) - -makeAspGenerators(asps,types,aspId) == --- The code generated here will manipulate the Fortran output stack and write --- the asps out as Fortran. - [:makeAspGenerators1(u,v,aspId) for u in asps for v in types] - -makeAspGenerators1(asp,type,aspId) == - [[["$elt","FOP","pushFortranOutputStack"] ,_ - ["filename",'"",STRCONC(STRINGIMAGE asp,aspId),'"f"]] , _ - makeOutputAsFortran INTERN STRCONC(STRINGIMAGE(asp),'"__arg"), _ - [["$elt","FOP","popFortranOutputStack"]] _ - ] - -makeOutputAsFortran arg == - ["IF",["case",arg,"fn"],["outputAsFortran",[arg,"fn"]],_ - ["outputAsFortran",[arg,"fp"]] ] - -makeCompilation(asps,file,aspId) == - [["$elt","Lisp","compileAndLink"],_ - ["construct",:[STRCONC(STRINGIMAGE a,aspId,'".f") for a in asps]], _ - $fortranCompilerName,_ - STRCONC(file,'".o"),_ - STRCONC(file,'".spadexe"),_ - $fortranLibraries] - - -compileAndLink(fortFileList,fortCompiler,cFile,outFile,linkerArgs) == - SYSTEM STRCONC (fortCompiler, addSpaces fortFileList,_ - cFile, " -o ",outFile," ",linkerArgs) - -addSpaces(stringList) == - l := " " - for s in stringList repeat l := STRCONC(l,s," ") - l - -complexRows z == --- Take a list of lists of complexes (i.e. pairs of floats) and --- make them look like a Fortran vector! - [:[:pair2list(u.i) for u in z] for i in 0..#(z.0)-1] - -pair2list u == [car u,cdr u] -vec2Lists1 u == [ELT(u,i) for i in 0..#u-1] -vec2Lists u == [vec2Lists1 ELT(u,i) for i in 0..#u-1] - -spad2lisp(u) == - -- Turn complexes into arrays of floats - first first(u)="Complex" => - makeVector([makeVector([CADR u,CDDR u],'DOUBLE_-FLOAT)],NIL) - -- Turn arrays of complexes into arrays of floats so that tarnsposing - -- them puts them in the correct fortran order - first first(u)="Matrix" and first SECOND first(u) = "Complex" => - makeVector([makeVector(complexRows vec2Lists rest u,'DOUBLE_-FLOAT)],NIL) - rest(u) - -invokeFortran(objFile,args,dummies,decls,results,actual) == - actual := [spad2lisp(u) for u in first actual] - returnedValues := spadify( _ - fortCall(objFile,prepareData(args,dummies,actual,decls),_ - prepareResults(results,args,dummies,actual,decls)),_ - results,decls,inFirstNotSecond(args,dummies),actual) - --- -- If there are one or two elements in returnedValues we must return a --- -- cons cell, otherwise a vector. This is to match the internal --- -- representation of an Axiom Record. --- #returnedValues = 1 => returnedValues --- #returnedValues = 2 => CONS(first returnedValues,SECOND returnedValues) --- makeVector(returnedValues,nil) - -int2Bool u == - -- Return something which looks like an axiom boolean - u=1 => "TRUE" - NIL - -makeResultRecord(name,type,value) == - -- Take an object returned by the NAG routine and make it into an AXIOM - -- object of type Record(key:Symbol,entry:Any) for use by Result. - CONS(name,CONS(spadTypeTTT type,value)) - -spadify(l,results,decls,names,actual) == - -- The elements of list l are the output forms returned from the Fortran - -- code: integers, floats and vectors. Return spad forms of these, of - -- type Record(key:Symbol,entry:Any) (for use with the Result domain). - SETQ(RESULTS,l) - spadForms := nil - for i in 0..(#l -1) repeat - fort := NTH(i,l) - name := NTH(i,results) - ty := getFortranType(name,decls) - -- Result is a string - STRINGP fort => - spadForms := [makeResultRecord(name,ty,fort), :spadForms] - -- Result is a Complex Scalar - ty in ["double complex" , "complex"] => - spadForms := [makeResultRecord(name,ty, _ - CONS(ELT(fort,0),ELT(fort,1)) ),:spadForms] - -- Result is a Complex vector or array - LISTP(ty) and first(ty) in ["double complex" , "complex"] => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - if #dims=1 then - els := [makeVector([CONS(ELT(fort,2*i),ELT(fort,2*i+1)) _ - for i in 0..(first(dims)-1)],nil)] - else if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - offset := 2*(c*first(dims)+r) - innerEls := [CONS(ELT(fort,offset),ELT(fort,offset+1)),:innerEls] - els := [makeVector(NREVERSE innerEls,nil),:els] - else - error ['"Can't cope with complex output dimensions higher than 2"] - spadForms := [makeResultRecord(name,ty,makeVector(NREVERSE els,nil)), - :spadForms] - -- Result is a Boolean vector or array - LISTP(ty) and first(ty)="logical" and #ty=2 => - dim := getVal(first rest ty,names,actual) - spadForms := [makeResultRecord(name,ty,_ - [int2Bool ELT(fort,i) for i in 0..dim-1]), :spadForms] - LISTP(ty) and first(ty)="logical" => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - innerEls := [int2Bool ELT(fort,c*first(dims)+r),:innerEls] - els := [NREVERSE innerEls,:els] - else - error ['"Can't cope with logical output dimensions higher than 2"] - spadForms := [makeResultRecord(name,ty,NREVERSE els), :spadForms] - -- Result is a vector or array - VECTORP fort => - dims := [getVal(u,names,actual) for u in rest ty] - els := nil - -- Check to see whether we are dealing with a dummy (0-dimensional) array. - if MEMQ(0,dims) then - els := [[]] - else if #dims=1 then - els := [makeVector([ELT(fort,i) for i in 0..(first(dims)-1)],nil)] - else if #dims=2 then - for r in 0..(first(dims) - 1) repeat - innerEls := nil - for c in 0..(SECOND(dims) - 1) repeat - innerEls := [ELT(fort,c*first(dims)+r),:innerEls] - els := [makeVector(NREVERSE innerEls,nil),:els] - else if #dims=3 then - iDim := first(dims) - jDim := SECOND dims - kDim := THIRD dims - for r in 0..(iDim - 1) repeat - middleEls := nil - for c in 0..(jDim - 1) repeat - innerEls := nil - for p in 0..(kDim - 1) repeat - offset := p*jDim + c*kDim + r - innerEls := [ELT(fort,offset),:innerEls] - middleEls := [makeVector(NREVERSE innerEls,nil),:middleEls] - els := [makeVector(NREVERSE middleEls,nil),:els] - else - error ['"Can't cope with output dimensions higher than 3"] - if not MEMQ(0,dims) then els := makeVector(NREVERSE els,nil) - spadForms := [makeResultRecord(name,ty,els), :spadForms] - -- Result is a Boolean Scalar - atom fort and ty="logical" => - spadForms := [makeResultRecord(name,ty,int2Bool fort), :spadForms] - -- Result is a Scalar - atom fort => - spadForms := [makeResultRecord(name,ty,fort),:spadForms] - error ['"Unrecognised output format: ",fort] - NREVERSE spadForms - -lispType u == - -- Return the lisp type equivalent to the given Fortran type. - LISTP u => lispType first u - u = "real" => "SHORT-FLOAT" - u = "double" => "DOUBLE-FLOAT" - u = "double precision" => "DOUBLE-FLOAT" - u = "integer" => "FIXNUM" - u = "logical" => "BOOLEAN" - u = "character" => "CHARACTER" - u = "complex" => "SHORT-FLOAT" - u = "double complex" => "DOUBLE-FLOAT" - error ['"Unrecognised Fortran type: ",u] - -getVal(u,names,values) == - -- if u is the i'th element of names, return the i'th element of values, - -- otherwise if it is an arithmetic expression evaluate it. - NUMBERP(u) => u - LISTP(u) => eval [first(u), :[getVal(v,names,values) for v in rest u]] - (place := POSITION(u,names)) => NTH(place,values) - error ['"No value found for parameter: ",u] - - -prepareData(args,dummies,values,decls) == --- TTT: we don't --- writeData handles all the mess - [args,dummies,values,decls] - - -checkForBoolean u == - u = "BOOLEAN" => "FIXNUM" - u - -prepareResults(results,args,dummies,values,decls) == - -- Create the floating point zeros (boot doesn't like 0.0d0, 0.0D0 etc) - shortZero : fluid := COERCE(0.0,'SHORT_-FLOAT) - longZero : fluid := COERCE(0.0,'DOUBLE_-FLOAT) - data := nil - for u in results repeat - type := getFortranType(u,decls) - data := [defaultValue(type,inFirstNotSecond(args,dummies),values),:data] - where defaultValue(type,argNames,actual) == - LISTP(type) and first(type)="character" => MAKE_-STRING(1) - LISTP(type) and first(type) in ["complex","double complex"] => - makeVector( makeList( - 2*APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ - if first(type)="complex" then shortZero else longZero),_ - if first(type)="complex" then "SHORT-FLOAT" else "DOUBLE-FLOAT" ) - LISTP type => makeVector(_ - makeList( - APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ - defaultValue(first type,argNames,actual)),_ - checkForBoolean lispType first(type) ) - type = "integer" => 0 - type = "real" => shortZero - type = "double" => longZero - type = "double precision" => longZero - type = "logical" => 0 - type = "character" => MAKE_-STRING(1) - type = "complex" => makeVector([shortZero,shortZero],'SHORT_-FLOAT) - type = "double complex" => makeVector([longZero,longZero],'LONG_-FLOAT) - error ['"Unrecognised Fortran type: ",type] - NREVERSE data - --- TTT this is dead code now --- transposeVector(u,type) == --- -- Take a vector of vectors and return a single vector which is in column --- -- order (i.e. swap from C to Fortran order). --- els := nil --- rows := CAR ARRAY_-DIMENSIONS(u)-1 --- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 --- -- Could be a 3D Matrix --- if VECTORP ELT(ELT(u,0),0) then --- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 --- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(ELT(u,i),j),k),:els] --- else --- for j in 0..cols repeat for i in 0..rows repeat --- els := [ELT(ELT(u,i),j),:els] --- makeVector(NREVERSE els,type) - - -writeData(tmpFile,indata) == - -- Write the elements of the list data to a temporary file. Return the - -- name of that file. - -- - str := MAKE_-OUTSTREAM(tmpFile) - xstr := xdrOpen(str,true) - [args,dummies,values,decls] := indata - for v in values repeat - -- the two Boolean values - v = "T" => - xdrWrite(xstr,1) - NULL v => - xdrWrite(xstr,0) - -- characters - STRINGP v => - xdrWrite(xstr,v) - -- some array - VECTORP v => - rows := CAR ARRAY_-DIMENSIONS(v) - -- is it 2d or more (most likely) ? - VECTORP ELT(v,0) => - cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) - -- is it 3d ? - VECTORP ELT(ELT(v,0),0) => - planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) - -- write 3d array - xdrWrite(xstr,rows*cols*planes) - for k in 0..planes-1 repeat - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat - xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) - -- write 2d array - xdrWrite(xstr,rows*cols) - for j in 0..cols-1 repeat - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) - -- write 1d array - xdrWrite(xstr,rows) - for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) - -- this is used for lists of booleans apparently in f01 - LISTP v => - xdrWrite(xstr,LENGTH v) - for el in v repeat - if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) - -- integers - INTEGERP v => - xdrWrite(xstr,v) - -- floats - FLOATP v => - xdrWrite(xstr,v) - SHUT(str) - tmpFile - -readData(tmpFile,results) == - -- read in the results from tmpFile. The list results is a list of - -- dummy objects of the correct type which will receive the data. - str := MAKE_-INSTREAM(tmpFile) - xstr := xdrOpen(str,false) - results := [xdrRead1(xstr,r) for r in results] where - xdrRead1(x,dummy) == - VECTORP(dummy) and ZEROP(LENGTH dummy) => dummy - xdrRead(x,dummy) - SHUT(str) - results - -generateDataName()==STRCONC($fortranTmpDir,getEnv('"HOST"), - getEnv('"SPADNUM"), GENTEMP('"NAG"),'"data") -generateResultsName()==STRCONC($fortranTmpDir,getEnv('"HOST"), - getEnv('"SPADNUM"), GENTEMP('"NAG"),'"results") - - -fortCall(objFile,data,results) == - tmpFile1 := writeData(generateDataName(),data) - tmpFile2 := generateResultsName() - SYSTEM STRCONC(objFile," < ",tmpFile1," > ",tmpFile2) - results := readData(tmpFile2,results) - -- SYSTEM STRCONC("rm -f ",tmpFile1," ",tmpFile2) - PROBE_-FILE(tmpFile1) and DELETE_-FILE(tmpFile1) - PROBE_-FILE(tmpFile2) and DELETE_-FILE(tmpFile2) - results - -invokeNagman(objFiles,nfile,args,dummies,decls,results,actual) == - actual := [spad2lisp(u) for u in first actual] - result := spadify(protectedNagCall(objFiles,nfile, _ - prepareData(args,dummies,actual,decls),_ - prepareResults(results,args,dummies,actual,decls)),_ - results,decls,inFirstNotSecond(args,dummies),actual) - -- Tidy up asps - -- if objFiles then SYSTEM STRCONC("rm -f ",addSpaces objFiles) - for fn in objFiles repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) - result - - -nagCall(objFiles,nfile,data,results,tmpFiled,tmpFiler) == - nagMessagesString := - $nagMessages => '"on" - '"off" - writeData(tmpFiled,data) - toSend:=STRCONC($nagHost," ",nfile," ",tmpFiler," ",tmpFiled," ",_ - STRINGIMAGE($fortPersistence)," ", nagMessagesString," ",addSpaces objFiles) - sockSendString(8,toSend) - if sockGetInt(8)=1 then - results := readData(tmpFiler,results) - else - error ['"An error was detected while reading data: ", _ - '"perhaps an incorrect array index was given ?"] - results - -protectedNagCall(objFiles,nfile,data,results) == - errors :=true - val:=NIL - td:=generateDataName() - tr:=generateResultsName() - UNWIND_-PROTECT( (val:=nagCall(objFiles,nfile,data,results,td,tr) ;errors :=NIL), - errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) - val - - -cleanUpAfterNagman(f1,f2,listf)== - PROBE_-FILE(f1) and DELETE_-FILE(f1) - PROBE_-FILE(f2) and DELETE_-FILE(f2) - for fn in listf repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) - -sendNagmanErrorSignal()== --- excite nagman's signal handler! - sockSendSignal(8,15) - - --- Globals --- $fortranDirectory := nil --- $fortranLibraries := '"-L/usr/local/lib/f90 -lf90 -L/usr/local/lib -lnag -lm" --- $fortranTmpDir := '"/tmp/" --- $addUnderscoreToFortranNames := true --- $fortranCompilerName := '"f90" - -inFirstNotSecond(f,s)== - [i for i in f | not i in s] - --- Code for use in the Windows version of the AXIOM/NAG interface. - -multiToUnivariate f == - -- Take an AnonymousFunction, replace the bound variables by references to - -- elements of a vector, and compile it. - (first f) ^= "+->" => error "in multiToUnivariate: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - body := COPY_-TREE CADDR f - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - body := NSUBST(["elt",newVariable,index+1],vars.(index),body) - -- We want a Vector DoubleFloat -> DoubleFloat - target := [["DoubleFloat"],["Vector",["DoubleFloat"]]] - rest interpret ["ADEF",[newVariable],target,[[],[]],body] - -functionAndJacobian f == - -- Take a mapping into n functions of n variables, produce code which will - -- evaluate function and jacobian values. - (first f) ^= "+->" => error "in functionAndJacobian: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - #(vars) ^= #(CDADDR f) => - error "number of variables should equal number of functions" - funBodies := COPY_-TREE CDADDR f - jacBodies := [:[DF(f,v) for v in vars] for f in funBodies] where - DF(fn,var) == - ["@",["convert",["differentiate",fn,var]],"InputForm"] - jacBodies := CDDR interpret [["$elt",["List",["InputForm"]],"construct"],:jacBodies] - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) - jacBodies := NSUBST(["elt",newVariable,index+1],vars.(index),jacBodies) - target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]],["Integer"]] - rest interpret - ["ADEF",[newVariable,"flag"],target,[[],[],[]],_ - ["IF", ["=","flag",1],_ - ["vector",["construct",:funBodies]],_ - ["vector",["construct",:jacBodies]]]] - - -vectorOfFunctions f == - -- Take a mapping into n functions of m variables, produce code which will - -- evaluate function values. - (first f) ^= "+->" => error "in vectorOfFunctions: not an AnonymousFunction" - if PAIRP CADR f then - vars := CDADR f -- throw away 'Tuple at start of variable list - else - vars := [CADR f] - funBodies := COPY_-TREE CDADDR f - newVariable := GENSYM() - for index in 0..#vars-1 repeat - -- Remember that AXIOM lists, vectors etc are indexed from 1 - funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) - target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]]] - rest interpret ["ADEF",[newVariable],target,[[],[]],["vector",["construct",:funBodies]]] - - - - - diff --git a/src/interp/fortcall.boot.pamphlet b/src/interp/fortcall.boot.pamphlet new file mode 100644 index 00000000..9513e313 --- /dev/null +++ b/src/interp/fortcall.boot.pamphlet @@ -0,0 +1,820 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp fortcall.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +makeFort(name,args,decls,results,returnType,aspInfo) == + -- Create an executable Fortran file to call a given library function, + -- and a stub Axiom function to process its arguments. + -- the following is a list of objects for which values need not be + -- passed by the user. + dummies := [SECOND(u) for u in args | EQUAL(car u,0)] + args := [untangle2(u) for u in args] -- lose spad Union representation + where untangle2 u == + atom (v := rest(u)) => v + first(v) + userArgs := [u for u in args | not member(u,dummies)] -- Temporary + decls := [untangle(u) for u in decls] -- lose spad Union representation + where untangle u == + [if atom(rest(v)) then rest(v) else _ + [if atom(w) then w else rest(w) for w in rest(v)] for v in u] + makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) + +makeFort1(name,args,userArgs,dummies,decls,results,returnType,aspInfo) == + asps := [first(u) for u in aspInfo] + -- Now reorder the arguments so that all the scalars come first, so + -- that when we come to deal with arrays we know all the dimensions. + scalarArgs := [u for u in args | atom getFortranType(u,decls)] + arrayArgs := [u for u in args | not member(u,scalarArgs)] + orderedArgs := [:scalarArgs,:arrayArgs] + file := if $fortranDirectory then + STRCONC($fortranDirectory,"/",STRINGIMAGE name) + else + STRINGIMAGE name + makeFortranFun(name,orderedArgs,args,dummies,decls,results,file, + $fortranDirectory,returnType,asps) + makeSpadFun(name,userArgs,orderedArgs,dummies,decls,results,returnType,asps, + aspInfo,file) + name + +makeFortranFun(name,args,fortranArgs,dummies,decls,results,file,dir, + returnType,asps) == + -- Create a C file to call the library function, and compile it. + fp := MAKE_-OUTSTREAM(STRCONC(file,".c")) + writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) + if null dir then dir := '"." + asps => SYSTEM STRCONC("cc -c ",file,".c ; mv ",file,".o ",dir) + SYSTEM STRCONC("cc ",file,".c -o ",file,".spadexe ",$fortranLibraries) + +writeCFile(name,args,fortranArgs,dummies,decls,results,returnType,asps,fp) == + WRITE_-LINE('"#include ",fp) + WRITE_-LINE('"#include ",fp) + WRITE_-LINE('"#include ",fp) + WRITE_-LINE('"#ifndef NULL",fp) + WRITE_-LINE('"#define NULL 0",fp) + WRITE_-LINE('"#endif NULL",fp) + WRITE_-LINE('"#define MAX__ARRAY(x) (x ? x : 20000)",fp) + WRITE_-LINE('"#define CHECK(x) if (!x) {fprintf(stderr,_"xdr failed_"); exit(1);}",fp) + WRITE_-LINE('"void main()",fp) + WRITE_-LINE('"{",fp) + WRITE_-LINE('" XDR xdrs;",fp) + WRITE_-LINE('" {",fp) + if $addUnderscoreToFortranNames then + routineName := STRCONC(name,STRING(95)) + else + routineName := name + -- If it is a function then give it somewhere to stick its result: + if returnType then + returnName := INTERN STRCONC(name,"__result") + wl(['" ",getCType returnType,'" ",returnName,'",",routineName,'"();"],fp) + -- print out type declarations for the Fortran parameters, and build an + -- ordered list of pairs [ , ] + argList := nil + for a in args repeat + argList := [[a, getCType getFortranType(a,decls)], :argList] + printDec(SECOND first argList,a,asps,fp) + argList := nreverse argList; + -- read in the data + WRITE_-LINE('" xdrstdio__create(&xdrs, stdin, XDR__DECODE);",fp) + for a in argList repeat + if LISTP SECOND a then writeMalloc(first a,first SECOND a,rest SECOND a,fp) + not MEMQ(first a,[:dummies,:asps]) => writeXDR(a,'"&xdrs",fp) + -- now call the Library routine. FORTRAN names may have an underscore + -- appended. + if returnType then + wt(['" ",returnName,'"="],fp) + else + wt(['" "],fp) + wt([routineName,'"("],fp) + if first fortranArgs then + printCName(first fortranArgs,isPointer?(first fortranArgs,decls),asps,fp) + for a in rest fortranArgs repeat + PRINC('",",fp) + printCName(a,isPointer?(a,decls),asps,fp) + writeStringLengths(fortranArgs,decls,fp) + WRITE_-LINE('");",fp) + -- now export the results. + WRITE_-LINE('" xdrstdio__create(&xdrs, stdout, XDR__ENCODE);",fp) + if returnType then + writeXDR([returnName,getCType returnType],'"&xdrs",fp) + for r in results repeat + writeXDR([r,getCType getFortranType(r,decls)],'"&xdrs",fp) + WRITE_-LINE('" exit(0);",fp) + WRITE_-LINE('" }",fp) + WRITE_-LINE('"}",fp) + +writeStringLengths(fortranArgs,decls,fp) == + for a in fortranArgs repeat + if isString?(a,decls) then wt(['",&",a,'"__length"],fp) + +isString?(u,decls) == + EQUAL(ty := getFortranType(u,decls),"character") or + LISTP(ty) and EQUAL(first ty,"character") + +isPointer?(u,decls) == + ty := getFortranType(u,decls) + LISTP(ty) or ty in ["character","complex","double complex"] + +printCName(u,ispointer,asps,fp) == + member(u,asps) => + PRINC(u,fp) + if $addUnderscoreToFortranNames then PRINC(STRING(95),fp) + if not ispointer then PRINC('"&",fp) + PRINC(u,fp) + +getFortranType(u,decls) == + -- find u in decls, return the given (Fortran) type. + result := nil + for d in decls repeat for dec in rest d repeat + atom(dec) and dec=u => + return( result := first d ) + LISTP(dec) and first(dec)=u => + return( result := [first d,:rest dec] ) + result => result + error ['"Undeclared Fortran parameter: ",u] + +getCType t == + -- Return the equivalent C type. + LISTP(t) => + --[if first(t)="character" then '"char" else getCType first t,:rest t] + first(t)="character" => ['"char",:rest t] + first(t)="complex" => ['"float",2,:rest t] + first(t)="double complex" => ['"double",2,:rest t] + [getCType first t,:rest t] + t="double" => '"double" + t="double precision" => '"double" + t="integer" => '"int" + t="real" => '"float" + t="logical" => '"int" + t="character" => ['"char",1] + t="complex" => ['"float",2] --'"Complex" -- we use our own typedef + t="double complex" => ['"double",2] --'"DComplex" -- we use our own typedef + error ['"Unrecognised Fortran type: ",t] + +XDRFun t == + LISTP(ty := SECOND t) => + if first(ty)='"char" then '"wrapstring" else '"array" + ty + +printDec(type,dec,asps,fp) == + wt(['" ",if LISTP(type) then first(type) else type,'" "],fp) + member(dec,asps) => + if $addUnderscoreToFortranNames then + wl([dec,STRING(95),'"();"],fp) + else + wl([dec,'"();"],fp) + LISTP(type) => + wl(['"*",dec,'" = NULL;"],fp) + wl(['" u__int ",dec, '"__length = 0;"],fp) + type = '"char" => + wl(['"*",dec,'" = NULL;"],fp) + wl([dec, '";"],fp) + +writeXDR(v,str,fp) == + -- Generate the calls to the filters which will read from the temp + -- file. The CHECK macro ensures that the translation worked. + underscore := STRING CHAR("__:",0) -- to avoid a compiler bug which won't + -- parse " ... __" properly. + wt(['" CHECK(xdr",underscore, XDRFun(v), '"(", str, '",&", first(v)],fp) + if (LISTP (ty :=SECOND v)) and not EQUAL(first ty,'"char") then + wt(['",&",first(v),'"__length,MAX__ARRAY(",first(v),'"__length),"],fp) + wt(['"sizeof(",first(ty),'"),xdr",underscore,first ty],fp) + wl(['"));"],fp) + +prefix2Infix(l) == + atom(l) => [l] + #l=2 => [first l,"(",:prefix2Infix SECOND l,")"] + #l=3 => ["(",:prefix2Infix SECOND l,first l,:prefix2Infix THIRD l,")"] + error '"Function in array dimensions with more than two arguments" + +writeMalloc(name,type,dims,fp) == + -- Write out a malloc for array arguments + -- Need the size as well + wl(['" ",name,'"__length=",prefix2Infix first dims,:[:["*",:prefix2Infix u] + for u in rest dims],'";"], fp) + type = '"char" => + wl(['" ",name,'"=(",type," *)malloc((1+",name, + '"__length)*sizeof(",type,'"));"],fp) + wl(['" ",name,'"=(",type," *)malloc(",name, + '"__length*sizeof(",type,'"));"],fp) + +wl (l,fp) == + for u in l repeat PRINC(u,fp) + TERPRI(fp) + +wt (l,fp) == + for u in l repeat PRINC(u,fp) + +-- spadRecordType(v,decs) == +-- -- Build a lisp representation of the declaration of a spad record. +-- -- This will be the returned type of the spad function which calls the +-- -- Fortran code. +-- ["Record",:[spadRecordType1(u,decs) for u in v]] +-- +-- spadRecordType1(u,decls) == +-- -- Create a list of the form '( |:| u ) +-- [":",u,spadTypeTTT getFortranType(u,decls)] + +spadTypeTTT u == + -- Return the spad domain equivalent to the given Fortran type. + -- Changed by MCD 8/4/94 to reflect correct format for domains in + -- current system. + LISTP u => + first(u)="character" => ["String"] + first(u)="logical" and #u=2 => ["List",["Boolean"]] + first(u)="logical" => ["List",["List",["Boolean"]]] + #u=2 => ["Matrix",spadTypeTTT first u] + #u=3 => ["Matrix",spadTypeTTT first u] + #u=4 => ["ThreeDimensionalMatrix",spadTypeTTT first u] + error '"Can only handle one-, two- and three-dimensional matrices" + u = "double" => ["DoubleFloat"] + u = "double precision" => ["DoubleFloat"] + u = "real" => ["DoubleFloat"] + u = "integer" => ["Integer"] + u = "logical" => ["Boolean"] + u = "character" => ["String"] + u = "complex" => ["Complex",["DoubleFloat"]] + u = "double complex" => ["Complex",["DoubleFloat"]] + error ['"Unrecognised Fortran type: ",u] + +mkQuote l == + [addQuote(u)for u in l] where + addQuote u == + atom u => ['QUOTE,u] + ["construct",:[addQuote(v) for v in u]] + +makeLispList(l) == + outputList := [] + for u in l repeat + outputList := [:outputList, _ + if atom(u) then ['QUOTE,u] else [["$elt","Lisp","construct"],_ + :makeLispList(u)]] + outputList + +makeSpadFun(name,userArgs,args,dummies,decls,results,returnType,asps,aspInfo, + file) == + -- Create an interpreter function for the user to call. + + fType := ["List", ["Record" , [":","key","Symbol"], [":","entry","Any"]]] + + -- To make sure the spad interpreter isn't confused: + if returnType then + returnName := INTERN STRCONC(name,"Result") + decls := [[returnType,returnName], :decls] + results := [returnName, :results] + argNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in userArgs] + aType := [axiomType(a,decls,asps,aspInfo) for a in userArgs] + aspTypes := [SECOND NTH(POSITION(u,userArgs),aType) for u in asps] + nilLst := MAKE_-LIST(#args+1) + decPar := [["$elt","Lisp","construct"],:makeLispList decls] + fargNames := [INTERN STRCONC(STRINGIMAGE(u),'"__arg") for u in args | + not (MEMQ(u,dummies) or MEMQ(u,asps)) ] + for u in asps repeat + fargNames := delete(INTERN STRCONC(STRINGIMAGE(u),'"__arg"),fargNames) + resPar := ["construct",["@",["construct",:fargNames],_ + ["List",["Any"]]]] + call := [["$elt","Lisp","invokeFortran"],STRCONC(file,".spadexe"),_ + [["$elt","Lisp","construct"],:mkQuote args],_ + [["$elt","Lisp","construct"],:mkQuote union(asps,dummies)], decPar,_ + [["$elt","Lisp","construct"],:mkQuote results],resPar] + if asps then + -- Make a unique(ish) id for asp files + aspId := STRCONC(getEnv('"SPADNUM"), GENTEMP('"NAG")) + body := ["SEQ",:makeAspGenerators(asps,aspTypes,aspId),_ + makeCompilation(asps,file,aspId),_ + ["pretend",call,fType] ] + else + body := ["pretend",call,fType] + interpret ["DEF",[name,:argNames],["Result",:aType],nilLst,_ + [["$elt","Result","construct"],body]] + +stripNil u == + [CAR(u), ["construct",:CADR(u)], if CADDR(u) then "true" else "false"] + +makeUnion aspType == + -- The argument is the type of the asp to be generated. We would like to + -- allow the user to be able to provide a fileName as an alternative + -- argument, so this builds the Union of aspType and FileName. + ["Union",[":","fp",aspType],[":","fn","FileName"]] + +axiomType(a,decls,asps,aspInfo) == + a in asps => + entry := first [u for u in aspInfo | first(u) = a] + ftc := ["$elt","FortranType","construct"] + rc := ["$elt", _ + ["Record",[":","key","Symbol"],[":","entry","FortranType"]], _ + "construct"] + makeUnion ["FortranProgram",_ + a,_ + CADR(entry),_ + ["construct",:mkQuote CADDR entry], _ + [ ["$elt", "SymbolTable","symbolTable"],_ + ["construct",_ + :[[rc,first(v),[ftc,:stripNil rest(v)]] for v in CADDDR entry]]_ + ] ] + spadTypeTTT(getFortranType(a,decls)) + +makeAspGenerators(asps,types,aspId) == +-- The code generated here will manipulate the Fortran output stack and write +-- the asps out as Fortran. + [:makeAspGenerators1(u,v,aspId) for u in asps for v in types] + +makeAspGenerators1(asp,type,aspId) == + [[["$elt","FOP","pushFortranOutputStack"] ,_ + ["filename",'"",STRCONC(STRINGIMAGE asp,aspId),'"f"]] , _ + makeOutputAsFortran INTERN STRCONC(STRINGIMAGE(asp),'"__arg"), _ + [["$elt","FOP","popFortranOutputStack"]] _ + ] + +makeOutputAsFortran arg == + ["IF",["case",arg,"fn"],["outputAsFortran",[arg,"fn"]],_ + ["outputAsFortran",[arg,"fp"]] ] + +makeCompilation(asps,file,aspId) == + [["$elt","Lisp","compileAndLink"],_ + ["construct",:[STRCONC(STRINGIMAGE a,aspId,'".f") for a in asps]], _ + $fortranCompilerName,_ + STRCONC(file,'".o"),_ + STRCONC(file,'".spadexe"),_ + $fortranLibraries] + + +compileAndLink(fortFileList,fortCompiler,cFile,outFile,linkerArgs) == + SYSTEM STRCONC (fortCompiler, addSpaces fortFileList,_ + cFile, " -o ",outFile," ",linkerArgs) + +addSpaces(stringList) == + l := " " + for s in stringList repeat l := STRCONC(l,s," ") + l + +complexRows z == +-- Take a list of lists of complexes (i.e. pairs of floats) and +-- make them look like a Fortran vector! + [:[:pair2list(u.i) for u in z] for i in 0..#(z.0)-1] + +pair2list u == [car u,cdr u] +vec2Lists1 u == [ELT(u,i) for i in 0..#u-1] +vec2Lists u == [vec2Lists1 ELT(u,i) for i in 0..#u-1] + +spad2lisp(u) == + -- Turn complexes into arrays of floats + first first(u)="Complex" => + makeVector([makeVector([CADR u,CDDR u],'DOUBLE_-FLOAT)],NIL) + -- Turn arrays of complexes into arrays of floats so that tarnsposing + -- them puts them in the correct fortran order + first first(u)="Matrix" and first SECOND first(u) = "Complex" => + makeVector([makeVector(complexRows vec2Lists rest u,'DOUBLE_-FLOAT)],NIL) + rest(u) + +invokeFortran(objFile,args,dummies,decls,results,actual) == + actual := [spad2lisp(u) for u in first actual] + returnedValues := spadify( _ + fortCall(objFile,prepareData(args,dummies,actual,decls),_ + prepareResults(results,args,dummies,actual,decls)),_ + results,decls,inFirstNotSecond(args,dummies),actual) + +-- -- If there are one or two elements in returnedValues we must return a +-- -- cons cell, otherwise a vector. This is to match the internal +-- -- representation of an Axiom Record. +-- #returnedValues = 1 => returnedValues +-- #returnedValues = 2 => CONS(first returnedValues,SECOND returnedValues) +-- makeVector(returnedValues,nil) + +int2Bool u == + -- Return something which looks like an axiom boolean + u=1 => "TRUE" + NIL + +makeResultRecord(name,type,value) == + -- Take an object returned by the NAG routine and make it into an AXIOM + -- object of type Record(key:Symbol,entry:Any) for use by Result. + CONS(name,CONS(spadTypeTTT type,value)) + +spadify(l,results,decls,names,actual) == + -- The elements of list l are the output forms returned from the Fortran + -- code: integers, floats and vectors. Return spad forms of these, of + -- type Record(key:Symbol,entry:Any) (for use with the Result domain). + SETQ(RESULTS,l) + spadForms := nil + for i in 0..(#l -1) repeat + fort := NTH(i,l) + name := NTH(i,results) + ty := getFortranType(name,decls) + -- Result is a string + STRINGP fort => + spadForms := [makeResultRecord(name,ty,fort), :spadForms] + -- Result is a Complex Scalar + ty in ["double complex" , "complex"] => + spadForms := [makeResultRecord(name,ty, _ + CONS(ELT(fort,0),ELT(fort,1)) ),:spadForms] + -- Result is a Complex vector or array + LISTP(ty) and first(ty) in ["double complex" , "complex"] => + dims := [getVal(u,names,actual) for u in rest ty] + els := nil + if #dims=1 then + els := [makeVector([CONS(ELT(fort,2*i),ELT(fort,2*i+1)) _ + for i in 0..(first(dims)-1)],nil)] + else if #dims=2 then + for r in 0..(first(dims) - 1) repeat + innerEls := nil + for c in 0..(SECOND(dims) - 1) repeat + offset := 2*(c*first(dims)+r) + innerEls := [CONS(ELT(fort,offset),ELT(fort,offset+1)),:innerEls] + els := [makeVector(NREVERSE innerEls,nil),:els] + else + error ['"Can't cope with complex output dimensions higher than 2"] + spadForms := [makeResultRecord(name,ty,makeVector(NREVERSE els,nil)), + :spadForms] + -- Result is a Boolean vector or array + LISTP(ty) and first(ty)="logical" and #ty=2 => + dim := getVal(first rest ty,names,actual) + spadForms := [makeResultRecord(name,ty,_ + [int2Bool ELT(fort,i) for i in 0..dim-1]), :spadForms] + LISTP(ty) and first(ty)="logical" => + dims := [getVal(u,names,actual) for u in rest ty] + els := nil + if #dims=2 then + for r in 0..(first(dims) - 1) repeat + innerEls := nil + for c in 0..(SECOND(dims) - 1) repeat + innerEls := [int2Bool ELT(fort,c*first(dims)+r),:innerEls] + els := [NREVERSE innerEls,:els] + else + error ['"Can't cope with logical output dimensions higher than 2"] + spadForms := [makeResultRecord(name,ty,NREVERSE els), :spadForms] + -- Result is a vector or array + VECTORP fort => + dims := [getVal(u,names,actual) for u in rest ty] + els := nil + -- Check to see whether we are dealing with a dummy (0-dimensional) array. + if MEMQ(0,dims) then + els := [[]] + else if #dims=1 then + els := [makeVector([ELT(fort,i) for i in 0..(first(dims)-1)],nil)] + else if #dims=2 then + for r in 0..(first(dims) - 1) repeat + innerEls := nil + for c in 0..(SECOND(dims) - 1) repeat + innerEls := [ELT(fort,c*first(dims)+r),:innerEls] + els := [makeVector(NREVERSE innerEls,nil),:els] + else if #dims=3 then + iDim := first(dims) + jDim := SECOND dims + kDim := THIRD dims + for r in 0..(iDim - 1) repeat + middleEls := nil + for c in 0..(jDim - 1) repeat + innerEls := nil + for p in 0..(kDim - 1) repeat + offset := p*jDim + c*kDim + r + innerEls := [ELT(fort,offset),:innerEls] + middleEls := [makeVector(NREVERSE innerEls,nil),:middleEls] + els := [makeVector(NREVERSE middleEls,nil),:els] + else + error ['"Can't cope with output dimensions higher than 3"] + if not MEMQ(0,dims) then els := makeVector(NREVERSE els,nil) + spadForms := [makeResultRecord(name,ty,els), :spadForms] + -- Result is a Boolean Scalar + atom fort and ty="logical" => + spadForms := [makeResultRecord(name,ty,int2Bool fort), :spadForms] + -- Result is a Scalar + atom fort => + spadForms := [makeResultRecord(name,ty,fort),:spadForms] + error ['"Unrecognised output format: ",fort] + NREVERSE spadForms + +lispType u == + -- Return the lisp type equivalent to the given Fortran type. + LISTP u => lispType first u + u = "real" => "SHORT-FLOAT" + u = "double" => "DOUBLE-FLOAT" + u = "double precision" => "DOUBLE-FLOAT" + u = "integer" => "FIXNUM" + u = "logical" => "BOOLEAN" + u = "character" => "CHARACTER" + u = "complex" => "SHORT-FLOAT" + u = "double complex" => "DOUBLE-FLOAT" + error ['"Unrecognised Fortran type: ",u] + +getVal(u,names,values) == + -- if u is the i'th element of names, return the i'th element of values, + -- otherwise if it is an arithmetic expression evaluate it. + NUMBERP(u) => u + LISTP(u) => eval [first(u), :[getVal(v,names,values) for v in rest u]] + (place := POSITION(u,names)) => NTH(place,values) + error ['"No value found for parameter: ",u] + + +prepareData(args,dummies,values,decls) == +-- TTT: we don't +-- writeData handles all the mess + [args,dummies,values,decls] + + +checkForBoolean u == + u = "BOOLEAN" => "FIXNUM" + u + +prepareResults(results,args,dummies,values,decls) == + -- Create the floating point zeros (boot doesn't like 0.0d0, 0.0D0 etc) + shortZero : fluid := COERCE(0.0,'SHORT_-FLOAT) + longZero : fluid := COERCE(0.0,'DOUBLE_-FLOAT) + data := nil + for u in results repeat + type := getFortranType(u,decls) + data := [defaultValue(type,inFirstNotSecond(args,dummies),values),:data] + where defaultValue(type,argNames,actual) == + LISTP(type) and first(type)="character" => MAKE_-STRING(1) + LISTP(type) and first(type) in ["complex","double complex"] => + makeVector( makeList( + 2*APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ + if first(type)="complex" then shortZero else longZero),_ + if first(type)="complex" then "SHORT-FLOAT" else "DOUBLE-FLOAT" ) + LISTP type => makeVector(_ + makeList( + APPLY('_*,[getVal(tt,argNames,actual) for tt in rest(type)]),_ + defaultValue(first type,argNames,actual)),_ + checkForBoolean lispType first(type) ) + type = "integer" => 0 + type = "real" => shortZero + type = "double" => longZero + type = "double precision" => longZero + type = "logical" => 0 + type = "character" => MAKE_-STRING(1) + type = "complex" => makeVector([shortZero,shortZero],'SHORT_-FLOAT) + type = "double complex" => makeVector([longZero,longZero],'LONG_-FLOAT) + error ['"Unrecognised Fortran type: ",type] + NREVERSE data + +-- TTT this is dead code now +-- transposeVector(u,type) == +-- -- Take a vector of vectors and return a single vector which is in column +-- -- order (i.e. swap from C to Fortran order). +-- els := nil +-- rows := CAR ARRAY_-DIMENSIONS(u)-1 +-- cols := CAR ARRAY_-DIMENSIONS(ELT(u,0))-1 +-- -- Could be a 3D Matrix +-- if VECTORP ELT(ELT(u,0),0) then +-- planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(u,0),0))-1 +-- for k in 0..planes repeat for j in 0..cols repeat for i in 0..rows repeat +-- els := [ELT(ELT(ELT(u,i),j),k),:els] +-- else +-- for j in 0..cols repeat for i in 0..rows repeat +-- els := [ELT(ELT(u,i),j),:els] +-- makeVector(NREVERSE els,type) + + +writeData(tmpFile,indata) == + -- Write the elements of the list data to a temporary file. Return the + -- name of that file. + -- + str := MAKE_-OUTSTREAM(tmpFile) + xstr := xdrOpen(str,true) + [args,dummies,values,decls] := indata + for v in values repeat + -- the two Boolean values + v = "T" => + xdrWrite(xstr,1) + NULL v => + xdrWrite(xstr,0) + -- characters + STRINGP v => + xdrWrite(xstr,v) + -- some array + VECTORP v => + rows := CAR ARRAY_-DIMENSIONS(v) + -- is it 2d or more (most likely) ? + VECTORP ELT(v,0) => + cols := CAR ARRAY_-DIMENSIONS(ELT(v,0)) + -- is it 3d ? + VECTORP ELT(ELT(v,0),0) => + planes := CAR ARRAY_-DIMENSIONS(ELT(ELT(v,0),0)) + -- write 3d array + xdrWrite(xstr,rows*cols*planes) + for k in 0..planes-1 repeat + for j in 0..cols-1 repeat + for i in 0..rows-1 repeat + xdrWrite(xstr,ELT(ELT(ELT(v,i),j),k)) + -- write 2d array + xdrWrite(xstr,rows*cols) + for j in 0..cols-1 repeat + for i in 0..rows-1 repeat xdrWrite(xstr,ELT(ELT(v,i),j)) + -- write 1d array + xdrWrite(xstr,rows) + for i in 0..rows-1 repeat xdrWrite(xstr,ELT(v,i)) + -- this is used for lists of booleans apparently in f01 + LISTP v => + xdrWrite(xstr,LENGTH v) + for el in v repeat + if el then xdrWrite(xstr,1) else xdrWrite(xstr,0) + -- integers + INTEGERP v => + xdrWrite(xstr,v) + -- floats + FLOATP v => + xdrWrite(xstr,v) + SHUT(str) + tmpFile + +readData(tmpFile,results) == + -- read in the results from tmpFile. The list results is a list of + -- dummy objects of the correct type which will receive the data. + str := MAKE_-INSTREAM(tmpFile) + xstr := xdrOpen(str,false) + results := [xdrRead1(xstr,r) for r in results] where + xdrRead1(x,dummy) == + VECTORP(dummy) and ZEROP(LENGTH dummy) => dummy + xdrRead(x,dummy) + SHUT(str) + results + +generateDataName()==STRCONC($fortranTmpDir,getEnv('"HOST"), + getEnv('"SPADNUM"), GENTEMP('"NAG"),'"data") +generateResultsName()==STRCONC($fortranTmpDir,getEnv('"HOST"), + getEnv('"SPADNUM"), GENTEMP('"NAG"),'"results") + + +fortCall(objFile,data,results) == + tmpFile1 := writeData(generateDataName(),data) + tmpFile2 := generateResultsName() + SYSTEM STRCONC(objFile," < ",tmpFile1," > ",tmpFile2) + results := readData(tmpFile2,results) + -- SYSTEM STRCONC("rm -f ",tmpFile1," ",tmpFile2) + PROBE_-FILE(tmpFile1) and DELETE_-FILE(tmpFile1) + PROBE_-FILE(tmpFile2) and DELETE_-FILE(tmpFile2) + results + +invokeNagman(objFiles,nfile,args,dummies,decls,results,actual) == + actual := [spad2lisp(u) for u in first actual] + result := spadify(protectedNagCall(objFiles,nfile, _ + prepareData(args,dummies,actual,decls),_ + prepareResults(results,args,dummies,actual,decls)),_ + results,decls,inFirstNotSecond(args,dummies),actual) + -- Tidy up asps + -- if objFiles then SYSTEM STRCONC("rm -f ",addSpaces objFiles) + for fn in objFiles repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) + result + + +nagCall(objFiles,nfile,data,results,tmpFiled,tmpFiler) == + nagMessagesString := + $nagMessages => '"on" + '"off" + writeData(tmpFiled,data) + toSend:=STRCONC($nagHost," ",nfile," ",tmpFiler," ",tmpFiled," ",_ + STRINGIMAGE($fortPersistence)," ", nagMessagesString," ",addSpaces objFiles) + sockSendString(8,toSend) + if sockGetInt(8)=1 then + results := readData(tmpFiler,results) + else + error ['"An error was detected while reading data: ", _ + '"perhaps an incorrect array index was given ?"] + results + +protectedNagCall(objFiles,nfile,data,results) == + errors :=true + val:=NIL + td:=generateDataName() + tr:=generateResultsName() + UNWIND_-PROTECT( (val:=nagCall(objFiles,nfile,data,results,td,tr) ;errors :=NIL), + errors =>( resetStackLimits(); sendNagmanErrorSignal();cleanUpAfterNagman(td,tr,objFiles))) + val + + +cleanUpAfterNagman(f1,f2,listf)== + PROBE_-FILE(f1) and DELETE_-FILE(f1) + PROBE_-FILE(f2) and DELETE_-FILE(f2) + for fn in listf repeat PROBE_-FILE(fn) and DELETE_-FILE(fn) + +sendNagmanErrorSignal()== +-- excite nagman's signal handler! + sockSendSignal(8,15) + + +-- Globals +-- $fortranDirectory := nil +-- $fortranLibraries := '"-L/usr/local/lib/f90 -lf90 -L/usr/local/lib -lnag -lm" +-- $fortranTmpDir := '"/tmp/" +-- $addUnderscoreToFortranNames := true +-- $fortranCompilerName := '"f90" + +inFirstNotSecond(f,s)== + [i for i in f | not i in s] + +-- Code for use in the Windows version of the AXIOM/NAG interface. + +multiToUnivariate f == + -- Take an AnonymousFunction, replace the bound variables by references to + -- elements of a vector, and compile it. + (first f) ^= "+->" => error "in multiToUnivariate: not an AnonymousFunction" + if PAIRP CADR f then + vars := CDADR f -- throw away 'Tuple at start of variable list + else + vars := [CADR f] + body := COPY_-TREE CADDR f + newVariable := GENSYM() + for index in 0..#vars-1 repeat + -- Remember that AXIOM lists, vectors etc are indexed from 1 + body := NSUBST(["elt",newVariable,index+1],vars.(index),body) + -- We want a Vector DoubleFloat -> DoubleFloat + target := [["DoubleFloat"],["Vector",["DoubleFloat"]]] + rest interpret ["ADEF",[newVariable],target,[[],[]],body] + +functionAndJacobian f == + -- Take a mapping into n functions of n variables, produce code which will + -- evaluate function and jacobian values. + (first f) ^= "+->" => error "in functionAndJacobian: not an AnonymousFunction" + if PAIRP CADR f then + vars := CDADR f -- throw away 'Tuple at start of variable list + else + vars := [CADR f] + #(vars) ^= #(CDADDR f) => + error "number of variables should equal number of functions" + funBodies := COPY_-TREE CDADDR f + jacBodies := [:[DF(f,v) for v in vars] for f in funBodies] where + DF(fn,var) == + ["@",["convert",["differentiate",fn,var]],"InputForm"] + jacBodies := CDDR interpret [["$elt",["List",["InputForm"]],"construct"],:jacBodies] + newVariable := GENSYM() + for index in 0..#vars-1 repeat + -- Remember that AXIOM lists, vectors etc are indexed from 1 + funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) + jacBodies := NSUBST(["elt",newVariable,index+1],vars.(index),jacBodies) + target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]],["Integer"]] + rest interpret + ["ADEF",[newVariable,"flag"],target,[[],[],[]],_ + ["IF", ["=","flag",1],_ + ["vector",["construct",:funBodies]],_ + ["vector",["construct",:jacBodies]]]] + + +vectorOfFunctions f == + -- Take a mapping into n functions of m variables, produce code which will + -- evaluate function values. + (first f) ^= "+->" => error "in vectorOfFunctions: not an AnonymousFunction" + if PAIRP CADR f then + vars := CDADR f -- throw away 'Tuple at start of variable list + else + vars := [CADR f] + funBodies := COPY_-TREE CDADDR f + newVariable := GENSYM() + for index in 0..#vars-1 repeat + -- Remember that AXIOM lists, vectors etc are indexed from 1 + funBodies := NSUBST(["elt",newVariable,index+1],vars.(index),funBodies) + target := [["Vector",["DoubleFloat"]],["Vector",["DoubleFloat"]]] + rest interpret ["ADEF",[newVariable],target,[[],[]],["vector",["construct",:funBodies]]] + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/functor.boot b/src/interp/functor.boot deleted file mode 100644 index 0513d9f0..00000000 --- a/src/interp/functor.boot +++ /dev/null @@ -1,983 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Domain printing -keyItem a == - isDomain a => CDAR a.4 - a - --The item that domain checks on - ---Global strategy here is to maintain a list of substitutions --- ( %in Sublis), of vectors and the names that they have, --- which may be either local names ('View1') or global names ('Where1') --- The global names are remembered on $Sublis from one --- invocation of DomainPrint1 to the next - -DomainPrint(D,brief) == - -- If brief is non-NIL, %then only a summary is printed - $WhereList: local - $Sublis: local - $WhereCounter: local - $WhereCounter:= 1 - env:= - not BOUNDP '$e => $EmptyEnvironment - $e='$e => $EmptyEnvironment - $e --in case we are called from top level - isCategory D => CategoryPrint(D,env) - $Sublis:= [[keyItem D,:'original]] - SAY '"-----------------------------------------------------------------------" - DomainPrint1(D,NIL,env) - while ($WhereList) repeat - s:= $WhereList - $WhereList:= nil - for u in s repeat - TERPRI() - SAY ['"Where ",first u,'" is:"] - DomainPrint1(rest u,brief,env) - SAY '"-----------------------------------------------------------------------" - -DomainPrint1(D,brief,$e) == - REFVECP D and not isDomain D => PacPrint D - if REFVECP D then D:= D.4 - --if we were passed a vector, go to the domain - Sublis:= - [: - [[rest u,:INTERNL STRCONC('"View",STRINGIMAGE i)] - for u in D for i in 1..],:$Sublis] - for u in D for i in 1.. repeat - brief and i>1 => nil - uu:= COPY_-SEQ rest u - uu.4:= '"This domain" - if not brief then - SAY ['"View number ",i,'" corresponding to categories:"] - PRETTYPRINT first u - if i=1 and REFVECP uu.5 then - vv:= COPY_-SEQ uu.5 - uu.5:= vv - for j in 0..MAXINDEX vv repeat - if REFVECP vv.j then - l:= ASSQ(keyItem vv.j,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem vv.j,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:vv.j],:$WhereList] - vv.j:= name - if i>1 then - uu.1:= uu.2:= uu.5:= '"As in first view" - for i in 6..MAXINDEX uu repeat - uu.i:= DomainPrintSubst(uu.i,Sublis) - if REFVECP uu.i then - name:=DPname() - Sublis:= [[keyItem uu.i,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:uu.i],:$WhereList] - uu.i:= name - if uu.i is [.,:v] and REFVECP v then - name:=DPname() - Sublis:= [[keyItem v,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:v],:$WhereList] - uu.i:= [first uu.i,:name] - if brief then PRETTYPRINT uu.0 else PRETTYPRINT uu - -DPname() == - name:= INTERNL STRCONC('"Where",STRINGIMAGE $WhereCounter) - $WhereCounter:= $WhereCounter+1 - name - -PacPrint v == - vv:= COPY_-SEQ v - for j in 0..MAXINDEX vv repeat - if REFVECP vv.j then - l:= ASSQ(keyItem vv.j,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem vv.j,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:vv.j],:$WhereList] - vv.j:= name - if PAIRP vv.j and REFVECP(u:=CDR vv.j) then - l:= ASSQ(keyItem u,Sublis) - if l - then name:= rest l - else - name:=DPname() - Sublis:= [[keyItem u,:name],:Sublis] - $Sublis:= [first Sublis,:$Sublis] - $WhereList:= [[name,:u],:$WhereList] - RPLACD(vv.j,name) - PRETTYPRINT vv - -DomainPrintSubst(item,Sublis) == - item is [a,:b] => - c1:= DomainPrintSubst(a,Sublis) - c2:= DomainPrintSubst(b,Sublis) - EQ(c1,a) and EQ(c2,b) => item - [c1,:c2] - l:= ASSQ(item,Sublis) - l => rest l - l:= ASSQ(keyItem item,Sublis) - l => rest l - item - ---% Utilities - -mkDevaluate a == - null a => nil - a is ['QUOTE,a'] => (a' => a; nil) - a='$ => MKQ '$ - a is ['LIST] => nil - a is ['LIST,:.] => a - ['devaluate,a] - -getDomainView(domain,catform) == - u:= HasCategory(domain,catform) => u - c:= eval catform - u:= HasCategory(domain,c.0) => u - -- note: this is necessary because of domain == another domain, e.g. - -- Ps are defined to be SUPs with specific arguments so that if one - -- asks if a P is a Module over itself, here one has catform= (Module - -- (P I)) yet domain is a SUP. By oding this evaluation, c.0=SUP as - -- well and test works --- RDJ 10/31/83 - throwKeyedMsg("S2IF0009",[devaluate domain, catform]) - -getPrincipalView domain == - pview:= domain - for [.,:view] in domain.4 repeat if #view>#pview then pview:= view - pview - -CategoriesFromGDC x == - atom x => nil - x is ['LIST,a,:b] and a is ['QUOTE,a'] => - union(LIST LIST a',"union"/[CategoriesFromGDC u for u in b]) - x is ['QUOTE,a] and a is [b] => [a] - -compCategories u == - ATOM u => u - not ATOM first u => - error ['"compCategories: need an atom in operator position", first u] - first u = "Record" => - -- There is no modemap property for these guys so do it by hand. - [first u, :[[":", a.1, compCategories1(a.2,'(SetCategory))] for a in rest u]] - first u = "Union" or first u = "Mapping" => - -- There is no modemap property for these guys so do it by hand. - [first u, :[compCategories1(a,'(SetCategory)) for a in rest u]] - u is ['SubDomain,D,.] => compCategories D - v:=get(first u,'modemap,$e) - ATOM v => - error ['"compCategories: could not get proper modemap for operator",first u] - if rest v then - sayBrightly ['"compCategories: ", '%b, '"Warning", '%d, - '"ignoring unexpected stuff at end of modemap"] - pp rest v - -- the next line "fixes" a bad modemap which sometimes appears .... - -- - if rest v and NULL CAAAR v then v:=CDR v - v:= CDDAAR v - v:=resolvePatternVars(v, rest u) -- replaces #n forms - -- select the modemap part of the first entry, and skip result etc. - u:=[first u,:[compCategories1(a,b) for a in rest u for b in v]] - u - -compCategories1(u,v) == --- v is the mode of u - ATOM u => u - isCategoryForm(v,$e) => compCategories u - [c,:.] := comp(macroExpand(u,$e),v,$e) => c - error 'compCategories1 - -NewbFVectorCopy(u,domName) == - v:= GETREFV SIZE u - for i in 0..5 repeat v.i:= u.i - for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] - v - -mkVector u == - u => ['VECTOR,:u] - nil - -optFunctorBody x == - atom x => x - x is ['QUOTE,:l] => x - x is ['DomainSubstitutionMacro,parms,body] => - optFunctorBody DomainSubstitutionFunction(parms,body) - x is ['LIST,:l] => - null l => nil - l:= [optFunctorBody u for u in l] - and/[optFunctorBodyQuotable u for u in l] => - ['QUOTE,[optFunctorBodyRequote u for u in l]] - l=rest x => x --CONS-saving hack - ['LIST,:l] - x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l] - x is ['COND,:l] => ---+ - l:= - [CondClause u for u in l | u and first u] where - CondClause [pred,:conseq] == - [optFunctorBody pred,:optFunctorPROGN conseq] - l:= EFFACE('((QUOTE T)),l) - --delete any trailing ("T) - null l => nil - CAAR l='(QUOTE T) => - (null CDAR l => nil; null CDDAR l => CADAR l; ["PROGN",:CDAR l]) - null rest l and null CDAR l => - --there is no meat to this COND - pred:= CAAR l - atom pred => nil - first pred="HasCategory" => nil - ['COND,:l] - ['COND,:l] - [optFunctorBody u for u in x] - -optFunctorBodyQuotable u == - null u => true - NUMBERP u => true - atom u => nil - u is ['QUOTE,:.] => true - nil - -optFunctorBodyRequote u == - atom u => u - u is ['QUOTE,v] => v - systemErrorHere '"optFunctorBodyRequote" - -optFunctorPROGN l == - l is [x,:l'] => - worthlessCode x => optFunctorPROGN l' - l':= optFunctorBody l' - l'=[nil] => [optFunctorBody x] - [optFunctorBody x,:l'] - l - -worthlessCode x == - x is ['COND,:l] and (and/[x is [.,y] and worthlessCode y for x in l]) => true - x is ['PROGN,:l] => (null (l':= optFunctorPROGN l) => true; false) - x is ['LIST] => true - null x => true - false - -cons5(p,l) == - l and (CAAR l = CAR p) => [p,: rest l] - LENGTH l < 5 => [p,:l] - RPLACD(QCDDDDR l,nil) - [p,:l] - --- TrimEnvironment e == --- [TrimLocalEnvironment u for u in e] where --- TrimLocalEnvironment e == --- [TrimContour u for u in e] where --- TrimContour e == --- [u for u in e | Interesting u] where Interesting u == nil --- --clearly a temporary definition - -setVector0(catNames,definition) == - --returns code to set element 0 of the vector - --to the definition of the category - definition:= mkDomainConstructor definition --- If we call addMutableArg this early, then recurise calls to this domain --- (e.g. while testing predicates) will generate new domains => trouble ---definition:= addMutableArg mkDomainConstructor definition - for u in catNames repeat - definition:= [($QuickCode => 'QSETREFV; 'SETELT),u,0,definition] - definition - ---presence of GENSYM in arg-list differentiates mutable-domains --- addMutableArg nameFormer == --- $mutableDomain => --- nameFormer is ['LIST,:.] => [:nameFormer, '(GENSYM)] --- ['APPEND,nameFormer,'(LIST (GENSYM))] --- nameFormer - ---getname D == --- isDomain D or isCategory D => D.0 --- D - -setVector12 args == - --The purpose of this function is to replace place holders - --e.g. argument names or gensyms, by real values - null args => nil - args1:=args2:=args - for u in $extraParms repeat - --A typical element of $extraParms, which is set in - --DomainSubstitutionFunction, would be (gensym) cons - --(category parameter), e.g. DirectProduct(length vl,NNI) - --as in DistributedMultivariatePolynomial - args1:=[CAR u,:args1] - args2:=[CDR u,:args2] - freeof($domainShell.1,args1) and - freeof($domainShell.2,args1) and - freeof($domainShell.4,args1) => nil where freeof(a,b) == - ATOM a => NULL MEMQ(a,b) - freeof(CAR a,b) => freeof(CDR a,b) - false - [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] - -SetDomainSlots124(vec,names,vals) == - l:= PAIR(names,vals) - vec.1:= sublisProp(l,vec.1) - vec.2:= sublisProp(l,vec.2) - l:= [[a,:devaluate b] for a in names for b in vals] - vec.4:= SUBLIS(l,vec.4) - vec.1:= SUBLIS(l,vec.1) - -sublisProp(subst,props) == - null props => nil - [cp,:props']:= props - (a' := inspect(cp,subst)) where - inspect(cp is [a,cond,:l],subst) == - cond=true => cp - --keep original CONS - cond is ['or,:x] => - (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil) - cond is ['has,nam,b] and (val:= ASSQ(nam,subst)) => - ev:= - b is ['ATTRIBUTE,c] => HasAttribute(rest val,c) - b is ['SIGNATURE,c] => HasSignature(rest val,c) - isDomainForm(b,$CategoryFrame) => b=rest val - HasCategory(rest val,b) - ev => [a,true,:l] - nil - cp - not a' => sublisProp(subst,props') - props' := sublisProp(subst,props') - EQ(a',cp) and EQ(props',rest props) => props - [a',:props'] - -setVector3(name,instantiator) == - --generates code to set element 3 of 'name' from 'instantiator' - --element 3 is data structure representing category - --returns a single LISP statement - instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) - [($QuickCode => 'QSETREFV; 'SETELT),name,3,mkDomainConstructor instantiator] - -mkDomainFormer x == - if x is ['DomainSubstitutionMacro,parms,body] then - x:=DomainSubstitutionFunction(parms,body) - x:=SUBLIS($extraParms,x) - --The next line ensures that only one copy of this structure will - --appear in the BPI being generated, thus saving (some) space - x is ['Join,:.] => ['eval,['QUOTE,x]] - x - -mkDomainConstructor x == - atom x => mkDevaluate x - x is ['Join] => nil - x is ['LIST] => nil - x is ['CATEGORY,:.] => MKQ x - x is ['mkCategory,:.] => MKQ x - x is ['_:,selector,dom] => - ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] - x is ['Record,:argl] => - ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] - x is ['Join,:argl] => - ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] - x is ['call,:argl] => ['MKQ, optCall x] - --The previous line added JHD/BMT 20/3/84 - --Necessary for proper compilation of DPOLY SPAD - x is [op] => MKQ x - x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] - -setVector4(catNames,catsig,conditions) == - if $HackSlot4 then - for ['LET,name,cond,:.] in $getDomainCode repeat - $HackSlot4:=SUBST(name,cond,$HackSlot4) - code:= ---+ - ['SETELT,'$,4,'TrueDomain] - code:=['(LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] - code:= - [: - [setVector4Onecat(u,v,w) - for u in catNames for v in catsig for w in conditions],:code] - ['(LET TrueDomain NIL),:code] - -setVector4Onecat(name,instantiator,info) == - --generates code to create one item in the - --Alist representing a domain - --returns a single LISP expression - instantiator is ['DomainSubstitutionMacro,.,body] => - setVector4Onecat(name,body,info) - data:= - --CAR name.4 contains all the names except itself - --hence we need to add this on, by the above CONS - ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], - name] - data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] - TruthP info => data - ['COND,[TryGDC PrepareConditional info,data],: - Supplementaries(instantiator,name)] where - Supplementaries(instantiator,name) == - slist:= - [u for u in $supplementaries | AncestorP(first u,[instantiator])] - null slist => nil - $supplementaries:= S_-($supplementaries,slist) - PRETTYPRINT [instantiator,'" should solve"] - PRETTYPRINT slist - slist:= - [form(u,name) for u in slist] where - form([cat,:cond],name) == - u:= ['QUOTE,[cat,:first (eval cat).4]] - ['COND,[TryGDC cond,['SETQ,'TrueDomain,['CONS,['CONS,u,name], - 'TrueDomain]]]] - LENGTH slist=1 => [CADAR slist] - --return a list, since it is CONSed - slist:= ['PROGN,:slist] - [['(QUOTE T),slist]] - -setVector4part3(catNames,catvecList) == - --the names are those that will be applied to the various vectors - generated:= nil - for u in catvecList for uname in catNames repeat - for v in CADDR u.4 repeat - if w:= ASSOC(first v,generated) - then RPLACD(w,[[rest v,:uname],:rest w]) - else generated:= [[first v,[rest v,:uname]],:generated] - codeList := nil - for [w,:u] in generated repeat - code := compCategories w - for v in u repeat - code:= [($QuickCode => 'QSETREFV; 'SETELT),rest v,first v,code] - if CONTAINED('$,w) then $epilogue := [code,:$epilogue] - else codeList := [code,:codeList] - codeList - -PrepareConditional u == u - -setVector5(catNames,locals) == - generated:= nil - for u in locals for uname in catNames repeat - if w:= ASSOC(u,generated) - then RPLACD(w,[uname,:rest w]) - else generated:= [[u,uname],:generated] - [(w:= mkVectorWithDeferral(first u,first rest u); - for v in rest u repeat - w:= [($QuickCode => 'QSETREFV; 'SETELT),v,5,w]; - w) - for u in generated] - -mkVectorWithDeferral(objects,tag) == --- Basically a mkVector, but spots things that aren't safe to instantiate --- and places them at the end of $ConstantAssignments, so that they get --- called AFTER the constants of $ have been set up. JHD 26.July.89 - ['VECTOR,: - [if CONTAINED('$,u) then -- It's not safe to instantiate this now - $ConstantAssignments:=[:$ConstantAssignments, - [($QuickCode=>'QSETREFV;'SETELT), - [($QuickCode=>'QREFELT;'ELT), tag, 5], - count, - u]] - [] - else u - for u in objects for count in 0..]] - -DescendCodeAdd(base,flag) == - atom base => DescendCodeVarAdd(base,flag) - not (modemap:=get(opOf base,'modemap,$CategoryFrame)) => - if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes] - then formalArgs:= take(#formalArgModes,$FormalMapVariableList) - --argument substitution if parameterized? - - else keyedSystemError("S2OR0001",[opOf base]) - DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) - for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat - (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=> - return ans - ans - -DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == - slist:= pairList(formalArgs,rest $addFormLhs) - --base = comp $addFormLhs-- bound in compAdd - e:= $e - newModes:= SUBLIS(slist,formalArgModes) - or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] => - return nil - --I should check that the actual arguments are of the right type - for u in formalArgs for m in newModes repeat - [.,.,e]:= compMakeDeclaration(['_:,u,m],m,e) - --we can not substitute in the formal arguments before we comp - --for that may change the shape of the object, but we must before - --we match signatures - cat:= (compMakeCategoryObject(target,e)).expr - instantiatedBase:= GENVAR() - n:=MAXINDEX cat - code:= - [u - for i in 6..n | not atom cat.i and not atom (sig:= first cat.i) - and - (u:= - SetFunctionSlots(SUBLIS(slist,sig),['ELT,instantiatedBase,i],flag, - 'adding))^=nil] - --The code from here to the end is designed to replace repeated LOAD/STORE - --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable - copyvec:=GETREFV (1+n) - for u in code repeat - if update(u,copyvec,[]) then code:=delete(u,code) - where update(code,copyvec,sofar) == - ATOM code =>nil - MEMQ(QCAR code,'(ELT QREFELT)) => - copyvec.(CADDR code):=union(copyvec.(CADDR code), sofar) - true - code is [x,name,number,u'] and MEMQ(x,'(SETELT QSETREFV)) => - update(u',copyvec,[[name,:number],:sofar]) - for i in 6..n repeat - for u in copyvec.i repeat - [name,:count]:=u - j:=i+1 - while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1 - --Maximum length of an MVC is 64 words - j:=j-1 - j > i+2 => - for k in i..j repeat copyvec.k:=delete([name,:count+k-i],copyvec.k) - code:=[['REPLACE, name, instantiatedBase, - INTERN('"START1",'"KEYWORD"), count, - INTERN('"START2",'"KEYWORD"), i, - INTERN('"END2",'"KEYWORD"), j+1],:code] - copyvec.i => - v:=[($QuickCode => 'QREFELT;'ELT),instantiatedBase,i] - for u in copyvec.i repeat - [name,:count]:=u - v:=[($QuickCode => 'QSETREFV;'SETELT),name,count,v] - code:=[v,:code] - [['LET,instantiatedBase,base],:code] - -DescendCode(code,flag,viewAssoc,EnvToPass) == - -- flag = true if we are walking down code always executed; - -- otherwise set to conditions in which - code=nil => nil - code='noBranch => nil - isMacro(code,$e) => nil --RDJ: added 3/16/83 - code is ['add,base,:codelist] => - codelist:= - [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil] - -- must do this first, to get this overriding Add code - ['PROGN,:DescendCodeAdd(base,flag),:codelist] - code is ['PROGN,:codelist] => - ['PROGN,: - --Two REVERSEs leave original order, but ensure last guy wins - NREVERSE [v for u in REVERSE codelist | - (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] - code is ['COND,:condlist] => - c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == - null u2 => nil - f:= - TruthP u2 => flag; - TruthP flag => - flag := ['NOT,u2] - u2 - flag := ['AND,flag,['NOT,u2]]; - ['AND,flag,u2] - [DescendCode(v, f, - if first u is ['HasCategory,dom,cat] - then [[dom,:cat],:viewAssoc] - else viewAssoc,EnvToPass) for v in rest u] - TruthP CAAR c => ['PROGN,:CDAR c] - while (c and (LAST c is [c1] or LAST c is [c1,[]]) and - (c1 = '(QUOTE T) or c1 is ['HasAttribute,:.])) repeat - --strip out some worthless junk at the end - c:=NREVERSE CDR NREVERSE c - null c => '(LIST) - ['COND,:c] - code is ['LET,name,body,:.] => - --only keep the names that are useful - if body is [a,:.] and isFunctor a - then $packagesUsed:=[body,:$packagesUsed] - u:=member(name,$locals) => - CONTAINED('$,body) and isDomainForm(body,$e) => - --instantiate domains which depend on $ after constants are set - code:=[($QuickCode => 'QSETREFV; 'SETELT),[($QuickCode => 'QREFELT; 'ELT),'$,5],#$locals-#u,code] - $epilogue:= - TruthP flag => [code,:$epilogue] - [['COND,[ProcessCond(flag,viewAssoc),code]],:$epilogue] - nil - code - code -- doItIf deletes entries from $locals so can't optimize this - code is ['CodeDefine,sig,implem] => - --Generated by doIt in COMPILER BOOT - dom:= EnvToPass - dom:= - u:= LASSOC(dom,viewAssoc) => ['getDomainView,dom,u] - dom - body:= ['CONS,implem,dom] - u:= SetFunctionSlots(sig,body,flag,'original) - ConstantCreator u => - if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]] - $ConstantAssignments:= [u,:$ConstantAssignments] - nil - u - code is ['_:,:.] => (RPLACA(code,'LIST); RPLACD(code,NIL)) - --Yes, I know that's a hack, but how else do you kill a line? - code is ['LIST,:.] => nil - code is ['devaluate,:.] => nil - code is ['MDEF,:.] => nil - code is ['call,:.] => code - code is ['SETELT,:.] => code -- can be generated by doItIf - code is ['QSETREFV,:.] => code -- can be generated by doItIf - stackWarning ['"unknown Functor code ",code] - code - -ConstantCreator u == - null u => nil - u is [q,.,.,u'] and (q='SETELT or q='QSETREFV) => ConstantCreator u' - u is ['CONS,:.] => nil - true - -ProcessCond(cond,viewassoc) == - ncond := SUBLIS($pairlis,cond) - INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond - cond ---+ -TryGDC cond == - --sees if a condition can be optimised by the use of - --information in $getDomainCode - atom cond => cond - cond is ['HasCategory,:l] => - solved:= nil - for u in $getDomainCode | not solved repeat - if u is ['LET,name, =cond] then solved:= name - solved => solved - cond - cond - -SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" ---+ - catNames := ['$] - for u in $catvecList for v in catNames repeat - null body => return NIL - for catImplem in LookUpSigSlots(sig,u.1) repeat - if catImplem is [q,.,index] and (q='ELT or q='CONST) - then - if q is 'CONST and body is ['CONS,a,b] then - body := ['CONS,'IDENTITY,['FUNCALL,a,b]] - body:= [($QuickCode => 'QSETREFV; 'SETELT),v,index,body] - if REFVECP $SetFunctions and TruthP flag then u.index:= true - --used by CheckVector to determine which ops are missing - if v='$ then -- i.e. we are looking at the principal view - not REFVECP $SetFunctions => nil - --packages don't set it - $MissingFunctionInfo.index:= flag - TruthP $SetFunctions.index => (body:= nil; return nil) - -- the function was already assigned - $SetFunctions.index:= - TruthP flag => true - not $SetFunctions.index=>flag --JHD didn't set $SF on this branch - ["or",$SetFunctions.index,flag] - else - if catImplem is ['Subsumed,:truename] - --a special marker generated by SigListUnion - then - if mode='original - then if truename is [fn,:.] and MEMQ(fn,'(Zero One)) - then nil --hack by RDJ 8/90 - else body:= SetFunctionSlots(truename,body,nil,mode) - else nil - else - if not (catImplem is ['PAC,:.]) then - keyedSystemError("S2OR0002",[catImplem]) - body is ['SETELT,:.] => body - body is ['QSETREFV,:.] => body - nil - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -LookUpSigSlots(sig,siglist) == ---+ must kill any implementations below of the form (ELT $ NIL) - siglist := $lisplibOperationAlist - REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) - and KADDR implem] - -SigSlotsMatch(sig,pattern,implem) == - sig=pattern => true - not (LENGTH CADR sig=LENGTH CADR pattern) => nil - --CADR sig is the actual signature part - not (first sig=first pattern) => nil - pat' :=SUBSTQ($definition,'$,CADR pattern) - sig' :=SUBSTQ($definition,'$,CADR sig) - sig'=pat' => true - --If we don't have this next test, then we'll recurse in SetFunctionSlots - implem is ['Subsumed,:.] => nil - SourceLevelSubsume(sig',pat') => true - nil - -CheckVector(vec,name,catvecListMaker) == - code:= nil - condAlist := - [[a,:first b] for [.,a,:b] in $getDomainCode] - -- used as substitution alist below - for i in 6..MAXINDEX vec repeat - v:= vec.i - v=true => nil - null v => nil - --a domain, which setVector4part3 will fill in - atom v => systemErrorHere '"CheckVector" - atom first v => - --It's a secondary view of a domain, which we - --must generate code to fill in - for x in $catNames for y in catvecListMaker repeat - if y=v then code:= - [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] - if name='$ then - ASSOC(first v,$CheckVectorList) => nil - $CheckVectorList:= - [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] --- member(first v,$CheckVectorList) => nil --- $CheckVectorList:= [first v,:$CheckVectorList] - code - -makeMissingFunctionEntry(alist,i) == - tran SUBLIS(alist,$MissingFunctionInfo.i) where - tran x == - x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b] - x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] - x - ---% Under what conditions may views exist? - -InvestigateConditions catvecListMaker == - -- given a principal view and a list of secondary views, - -- discover under what conditions the secondary view are - -- always present. - $Conditions: local:= nil - $principal: local - [$principal,:secondaries]:= catvecListMaker - --We are not interested in the principal view - --The next block allows for the possibility that $principal may - --have conditional secondary views ---+ - null secondaries => '(T) - --return for packages which generally have no secondary views - if $principal is [op,:.] then - [principal',:.]:=compMakeCategoryObject($principal,$e) - --Rather like eval, but quotes parameters first - for u in CADR principal'.4 repeat - if not TruthP(cond:=CADR u) then - new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,CAR u], 'noBranch]] - $principal is ['Join,:l] => - not member(new,l) => - $principal:=['Join,:l,new] - $principal:=['Join,$principal,new] - principal' := - pessimise $principal where - pessimise a == - atom a => a - a is ['SIGNATURE,:.] => a - a is ['IF,cond,:.] => - if not member(cond,$Conditions) then $Conditions:= [cond,:$Conditions] - nil - [pessimise first a,:pessimise rest a] - null $Conditions => [true,:[true for u in secondaries]] - PrincipalSecondaries:= getViewsConditions principal' - MinimalPrimary:= CAR first PrincipalSecondaries - MaximalPrimary:= CAAR $domainShell.4 - necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] - and/[member(u,necessarySecondaries) for u in secondaries] => - [true,:[true for u in secondaries]] - $HackSlot4:= - MinimalPrimary=MaximalPrimary => nil - MaximalPrimaries:=[MaximalPrimary,:CAR (CatEval MaximalPrimary).4] - MinimalPrimaries:=[MinimalPrimary,:CAR (CatEval MinimalPrimary).4] - MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) - [[x] for x in MaximalPrimaries] - ($Conditions:= Conds($principal,nil)) where - Conds(code,previous) == - --each call takes a list of conditions, and returns a list - --of refinements of that list - atom code => [previous] - code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous) - code is ['IF,a,b,c] => union(Conds(b,[a,:previous]),Conds(c,previous)) - code is ['PROGN,:l] => "union"/[Conds(u,previous) for u in l] - code is ['CATEGORY,:l] => "union"/[Conds(u,previous) for u in l] - code is ['Join,:l] => "union"/[Conds(u,previous) for u in l] - [previous] - $Conditions:= EFFACE(nil,[EFFACE(nil,u) for u in $Conditions]) - partList:= - [getViewsConditions partPessimise($principal,cond) for cond in $Conditions] - masterSecondaries:= secondaries - for u in partList repeat - for [v,:.] in u repeat - if not member(v,secondaries) then secondaries:= [v,:secondaries] - --PRETTYPRINT $Conditions - --PRETTYPRINT masterSecondaries - --PRETTYPRINT secondaries - (list:= [mkNilT member(u,necessarySecondaries) for u in secondaries]) where - mkNilT u == - u => true - nil - for u in $Conditions for newS in partList repeat - --newS is a list of secondaries and conditions (over and above - --u) for which they apply - u:= - LENGTH u=1 => first u - ['AND,:u] - for [v,:.] in newS repeat - for v' in [v,:CAR (CatEval v).4] repeat - if (w:=ASSOC(v',$HackSlot4)) then - RPLAC(rest w,if rest w then mkOr(u,rest w) else u) - (list:= update(list,u,secondaries,newS)) where - update(list,cond,secondaries,newS) == - (list2:= - [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where - flist(sec,newS,old,cond) == - old=true => old - for [newS2,:morecond] in newS repeat - old:= - not AncestorP(sec,[newS2]) => old - cond2:= mkAnd(cond,morecond) - null old => cond2 - mkOr(cond2,old) - old - list2 - list:= [[sec,:ICformat u] for u in list for sec in secondaries] - pv:= getPossibleViews $principal --- $HackSlot4 is used in SetVector4 to ensure that conditional --- extensions of the principal view are handles correctly --- here we build the code necessary to remove spurious extensions - ($HackSlot4:= [reshape u for u in $HackSlot4]) where - reshape u == - ['COND,[TryGDC ICformat rest u], - ['(QUOTE T),['RPLACA,'(CAR TrueDomain), - ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] - $supplementaries:= - [u - for u in list | not member(first u,masterSecondaries) - and not (true=rest u) and not member(first u,pv)] - [true,:[LASSOC(ms,list) for ms in masterSecondaries]] - -ICformat u == - atom u => u - u is ['has,:.] => compHasFormat u - u is ['AND,:l] or u is ['and,:l] => - l:= REMDUP [ICformat v for [v,:l'] in tails l | not member(v,l')] - -- we could have duplicates after, even if not before - LENGTH l=1 => first l - l1:= first l - for u in rest l repeat - l1:=mkAnd(u,l1) - l1 - u is ['OR,:l] => - (l:= ORreduce l) where - ORreduce l == - for u in l | u is ['AND,:.] or u is ['and,:.] repeat - --check that B causes (and A B) to go - for v in l | not (v=u) repeat - if member(v,u) or (and/[member(w,u) for w in v]) then l:= - delete(u,l) - --v subsumes u - --Note that we are ignoring AND as a component. - --Convince yourself that this code still works - l - LENGTH l=1 => ICformat first l - l:= ORreduce REMDUP [ICformat u for u in l] - --causes multiple ANDs to be squashed, etc. - -- and duplicates that have been built up by tidying - (l:= Hasreduce l) where - Hasreduce l == - for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, - cond] repeat - --check that v causes descendants to go - for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, - cond2]] repeat if DescendantP(cond,cond2) then l:= delete(u,l) - --v subsumes u - for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat - for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, - cond] repeat - --check that v causes descendants to go - for v in l | v is ['HasCategory, =name,['QUOTE, - cond2]] repeat if DescendantP(cond,cond2) then l:= delete(u,l) - --v subsumes u - l - LENGTH l=1 => first l - ['OR,:l] - systemErrorHere '"ICformat" - -partPessimise(a,trueconds) == - atom a => a - a is ['SIGNATURE,:.] => a - a is ['IF,cond,:.] => (member(cond,trueconds) => a; nil) - [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] - -getPossibleViews u == - --returns a list of all the categories that can be views of this one - [vec,:.]:= compMakeCategoryObject(u,$e) or - systemErrorHere '"getPossibleViews" - views:= [first u for u in CADR vec.4] - null vec.0 => [CAAR vec.4,:views] --* - [vec.0,:views] --* - --the two lines marked ensure that the principal view comes first - --if you don't want it, CDR it off - -getViewsConditions u == - - --returns a list of all the categories that can be views of this one - --paired with the condition under which they are such views - [vec,:.]:= compMakeCategoryObject(u,$e) or - systemErrorHere '"getViewsConditions" - views:= [[first u,:CADR u] for u in CADR vec.4] - null vec.0 => ---+ - null CAR vec.4 => views - [[CAAR vec.4,:true],:views] --* - [[vec.0,:true],:views] --* - --the two lines marked ensure that the principal view comes first - --if you don't want it, CDR it off - -DescendCodeVarAdd(base,flag) == - princview := CAR $catvecList - [SetFunctionSlots(sig,SUBST('ELT,'CONST,implem),flag,'adding) repeat - for i in 6..MAXINDEX princview | - princview.i is [sig:=[op,types],:.] and - LASSOC([base,:SUBST(base,'$,types)],get(op,'modemap,$e)) is - [[pred,implem]]] - -resolvePatternVars(p,args) == - p := SUBLISLIS(args, $TriangleVariableList, p) - SUBLISLIS(args, $FormalMapVariableList, p) - ---resolvePatternVars(p,args) == --- atom p => --- isSharpVarWithNum p => args.(position(p,$FormalMapVariableList)) --- p --- [resolvePatternVars(CAR p,args),:resolvePatternVars(CDR p,args)] - --- Mysterious JENKS definition follows: ---DescendCodeVarAdd(base,flag) == --- baseops := [(u:=LASSOC([base,:SUBST(base,'$,types)], --- get(op,'modemap,$e))) and [sig,:u] --- for (sig := [op,types]) in $CheckVectorList] --- $CheckVectorList := [sig for sig in $CheckVectorList --- for op in baseops | null op] --- [SetFunctionSlots(sig,implem,flag,'adding) --- for u in baseops | u is [sig,[pred,implem]]] - diff --git a/src/interp/functor.boot.pamphlet b/src/interp/functor.boot.pamphlet new file mode 100644 index 00000000..7e952a88 --- /dev/null +++ b/src/interp/functor.boot.pamphlet @@ -0,0 +1,1009 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp functor.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Domain printing +keyItem a == + isDomain a => CDAR a.4 + a + --The item that domain checks on + +--Global strategy here is to maintain a list of substitutions +-- ( %in Sublis), of vectors and the names that they have, +-- which may be either local names ('View1') or global names ('Where1') +-- The global names are remembered on $Sublis from one +-- invocation of DomainPrint1 to the next + +DomainPrint(D,brief) == + -- If brief is non-NIL, %then only a summary is printed + $WhereList: local + $Sublis: local + $WhereCounter: local + $WhereCounter:= 1 + env:= + not BOUNDP '$e => $EmptyEnvironment + $e='$e => $EmptyEnvironment + $e --in case we are called from top level + isCategory D => CategoryPrint(D,env) + $Sublis:= [[keyItem D,:'original]] + SAY '"-----------------------------------------------------------------------" + DomainPrint1(D,NIL,env) + while ($WhereList) repeat + s:= $WhereList + $WhereList:= nil + for u in s repeat + TERPRI() + SAY ['"Where ",first u,'" is:"] + DomainPrint1(rest u,brief,env) + SAY '"-----------------------------------------------------------------------" + +DomainPrint1(D,brief,$e) == + REFVECP D and not isDomain D => PacPrint D + if REFVECP D then D:= D.4 + --if we were passed a vector, go to the domain + Sublis:= + [: + [[rest u,:INTERNL STRCONC('"View",STRINGIMAGE i)] + for u in D for i in 1..],:$Sublis] + for u in D for i in 1.. repeat + brief and i>1 => nil + uu:= COPY_-SEQ rest u + uu.4:= '"This domain" + if not brief then + SAY ['"View number ",i,'" corresponding to categories:"] + PRETTYPRINT first u + if i=1 and REFVECP uu.5 then + vv:= COPY_-SEQ uu.5 + uu.5:= vv + for j in 0..MAXINDEX vv repeat + if REFVECP vv.j then + l:= ASSQ(keyItem vv.j,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem vv.j,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:vv.j],:$WhereList] + vv.j:= name + if i>1 then + uu.1:= uu.2:= uu.5:= '"As in first view" + for i in 6..MAXINDEX uu repeat + uu.i:= DomainPrintSubst(uu.i,Sublis) + if REFVECP uu.i then + name:=DPname() + Sublis:= [[keyItem uu.i,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:uu.i],:$WhereList] + uu.i:= name + if uu.i is [.,:v] and REFVECP v then + name:=DPname() + Sublis:= [[keyItem v,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:v],:$WhereList] + uu.i:= [first uu.i,:name] + if brief then PRETTYPRINT uu.0 else PRETTYPRINT uu + +DPname() == + name:= INTERNL STRCONC('"Where",STRINGIMAGE $WhereCounter) + $WhereCounter:= $WhereCounter+1 + name + +PacPrint v == + vv:= COPY_-SEQ v + for j in 0..MAXINDEX vv repeat + if REFVECP vv.j then + l:= ASSQ(keyItem vv.j,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem vv.j,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:vv.j],:$WhereList] + vv.j:= name + if PAIRP vv.j and REFVECP(u:=CDR vv.j) then + l:= ASSQ(keyItem u,Sublis) + if l + then name:= rest l + else + name:=DPname() + Sublis:= [[keyItem u,:name],:Sublis] + $Sublis:= [first Sublis,:$Sublis] + $WhereList:= [[name,:u],:$WhereList] + RPLACD(vv.j,name) + PRETTYPRINT vv + +DomainPrintSubst(item,Sublis) == + item is [a,:b] => + c1:= DomainPrintSubst(a,Sublis) + c2:= DomainPrintSubst(b,Sublis) + EQ(c1,a) and EQ(c2,b) => item + [c1,:c2] + l:= ASSQ(item,Sublis) + l => rest l + l:= ASSQ(keyItem item,Sublis) + l => rest l + item + +--% Utilities + +mkDevaluate a == + null a => nil + a is ['QUOTE,a'] => (a' => a; nil) + a='$ => MKQ '$ + a is ['LIST] => nil + a is ['LIST,:.] => a + ['devaluate,a] + +getDomainView(domain,catform) == + u:= HasCategory(domain,catform) => u + c:= eval catform + u:= HasCategory(domain,c.0) => u + -- note: this is necessary because of domain == another domain, e.g. + -- Ps are defined to be SUPs with specific arguments so that if one + -- asks if a P is a Module over itself, here one has catform= (Module + -- (P I)) yet domain is a SUP. By oding this evaluation, c.0=SUP as + -- well and test works --- RDJ 10/31/83 + throwKeyedMsg("S2IF0009",[devaluate domain, catform]) + +getPrincipalView domain == + pview:= domain + for [.,:view] in domain.4 repeat if #view>#pview then pview:= view + pview + +CategoriesFromGDC x == + atom x => nil + x is ['LIST,a,:b] and a is ['QUOTE,a'] => + union(LIST LIST a',"union"/[CategoriesFromGDC u for u in b]) + x is ['QUOTE,a] and a is [b] => [a] + +compCategories u == + ATOM u => u + not ATOM first u => + error ['"compCategories: need an atom in operator position", first u] + first u = "Record" => + -- There is no modemap property for these guys so do it by hand. + [first u, :[[":", a.1, compCategories1(a.2,'(SetCategory))] for a in rest u]] + first u = "Union" or first u = "Mapping" => + -- There is no modemap property for these guys so do it by hand. + [first u, :[compCategories1(a,'(SetCategory)) for a in rest u]] + u is ['SubDomain,D,.] => compCategories D + v:=get(first u,'modemap,$e) + ATOM v => + error ['"compCategories: could not get proper modemap for operator",first u] + if rest v then + sayBrightly ['"compCategories: ", '%b, '"Warning", '%d, + '"ignoring unexpected stuff at end of modemap"] + pp rest v + -- the next line "fixes" a bad modemap which sometimes appears .... + -- + if rest v and NULL CAAAR v then v:=CDR v + v:= CDDAAR v + v:=resolvePatternVars(v, rest u) -- replaces #n forms + -- select the modemap part of the first entry, and skip result etc. + u:=[first u,:[compCategories1(a,b) for a in rest u for b in v]] + u + +compCategories1(u,v) == +-- v is the mode of u + ATOM u => u + isCategoryForm(v,$e) => compCategories u + [c,:.] := comp(macroExpand(u,$e),v,$e) => c + error 'compCategories1 + +NewbFVectorCopy(u,domName) == + v:= GETREFV SIZE u + for i in 0..5 repeat v.i:= u.i + for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] + v + +mkVector u == + u => ['VECTOR,:u] + nil + +optFunctorBody x == + atom x => x + x is ['QUOTE,:l] => x + x is ['DomainSubstitutionMacro,parms,body] => + optFunctorBody DomainSubstitutionFunction(parms,body) + x is ['LIST,:l] => + null l => nil + l:= [optFunctorBody u for u in l] + and/[optFunctorBodyQuotable u for u in l] => + ['QUOTE,[optFunctorBodyRequote u for u in l]] + l=rest x => x --CONS-saving hack + ['LIST,:l] + x is ['PROGN,:l] => ['PROGN,:optFunctorPROGN l] + x is ['COND,:l] => +--+ + l:= + [CondClause u for u in l | u and first u] where + CondClause [pred,:conseq] == + [optFunctorBody pred,:optFunctorPROGN conseq] + l:= EFFACE('((QUOTE T)),l) + --delete any trailing ("T) + null l => nil + CAAR l='(QUOTE T) => + (null CDAR l => nil; null CDDAR l => CADAR l; ["PROGN",:CDAR l]) + null rest l and null CDAR l => + --there is no meat to this COND + pred:= CAAR l + atom pred => nil + first pred="HasCategory" => nil + ['COND,:l] + ['COND,:l] + [optFunctorBody u for u in x] + +optFunctorBodyQuotable u == + null u => true + NUMBERP u => true + atom u => nil + u is ['QUOTE,:.] => true + nil + +optFunctorBodyRequote u == + atom u => u + u is ['QUOTE,v] => v + systemErrorHere '"optFunctorBodyRequote" + +optFunctorPROGN l == + l is [x,:l'] => + worthlessCode x => optFunctorPROGN l' + l':= optFunctorBody l' + l'=[nil] => [optFunctorBody x] + [optFunctorBody x,:l'] + l + +worthlessCode x == + x is ['COND,:l] and (and/[x is [.,y] and worthlessCode y for x in l]) => true + x is ['PROGN,:l] => (null (l':= optFunctorPROGN l) => true; false) + x is ['LIST] => true + null x => true + false + +cons5(p,l) == + l and (CAAR l = CAR p) => [p,: rest l] + LENGTH l < 5 => [p,:l] + RPLACD(QCDDDDR l,nil) + [p,:l] + +-- TrimEnvironment e == +-- [TrimLocalEnvironment u for u in e] where +-- TrimLocalEnvironment e == +-- [TrimContour u for u in e] where +-- TrimContour e == +-- [u for u in e | Interesting u] where Interesting u == nil +-- --clearly a temporary definition + +setVector0(catNames,definition) == + --returns code to set element 0 of the vector + --to the definition of the category + definition:= mkDomainConstructor definition +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +--definition:= addMutableArg mkDomainConstructor definition + for u in catNames repeat + definition:= [($QuickCode => 'QSETREFV; 'SETELT),u,0,definition] + definition + +--presence of GENSYM in arg-list differentiates mutable-domains +-- addMutableArg nameFormer == +-- $mutableDomain => +-- nameFormer is ['LIST,:.] => [:nameFormer, '(GENSYM)] +-- ['APPEND,nameFormer,'(LIST (GENSYM))] +-- nameFormer + +--getname D == +-- isDomain D or isCategory D => D.0 +-- D + +setVector12 args == + --The purpose of this function is to replace place holders + --e.g. argument names or gensyms, by real values + null args => nil + args1:=args2:=args + for u in $extraParms repeat + --A typical element of $extraParms, which is set in + --DomainSubstitutionFunction, would be (gensym) cons + --(category parameter), e.g. DirectProduct(length vl,NNI) + --as in DistributedMultivariatePolynomial + args1:=[CAR u,:args1] + args2:=[CDR u,:args2] + freeof($domainShell.1,args1) and + freeof($domainShell.2,args1) and + freeof($domainShell.4,args1) => nil where freeof(a,b) == + ATOM a => NULL MEMQ(a,b) + freeof(CAR a,b) => freeof(CDR a,b) + false + [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] + +SetDomainSlots124(vec,names,vals) == + l:= PAIR(names,vals) + vec.1:= sublisProp(l,vec.1) + vec.2:= sublisProp(l,vec.2) + l:= [[a,:devaluate b] for a in names for b in vals] + vec.4:= SUBLIS(l,vec.4) + vec.1:= SUBLIS(l,vec.1) + +sublisProp(subst,props) == + null props => nil + [cp,:props']:= props + (a' := inspect(cp,subst)) where + inspect(cp is [a,cond,:l],subst) == + cond=true => cp + --keep original CONS + cond is ['or,:x] => + (or/[inspect(u,subst) for u in x] => [a,true,:l]; nil) + cond is ['has,nam,b] and (val:= ASSQ(nam,subst)) => + ev:= + b is ['ATTRIBUTE,c] => HasAttribute(rest val,c) + b is ['SIGNATURE,c] => HasSignature(rest val,c) + isDomainForm(b,$CategoryFrame) => b=rest val + HasCategory(rest val,b) + ev => [a,true,:l] + nil + cp + not a' => sublisProp(subst,props') + props' := sublisProp(subst,props') + EQ(a',cp) and EQ(props',rest props) => props + [a',:props'] + +setVector3(name,instantiator) == + --generates code to set element 3 of 'name' from 'instantiator' + --element 3 is data structure representing category + --returns a single LISP statement + instantiator is ['DomainSubstitutionMacro,.,body] => setVector3(name,body) + [($QuickCode => 'QSETREFV; 'SETELT),name,3,mkDomainConstructor instantiator] + +mkDomainFormer x == + if x is ['DomainSubstitutionMacro,parms,body] then + x:=DomainSubstitutionFunction(parms,body) + x:=SUBLIS($extraParms,x) + --The next line ensures that only one copy of this structure will + --appear in the BPI being generated, thus saving (some) space + x is ['Join,:.] => ['eval,['QUOTE,x]] + x + +mkDomainConstructor x == + atom x => mkDevaluate x + x is ['Join] => nil + x is ['LIST] => nil + x is ['CATEGORY,:.] => MKQ x + x is ['mkCategory,:.] => MKQ x + x is ['_:,selector,dom] => + ['LIST,MKQ '_:,MKQ selector,mkDomainConstructor dom] + x is ['Record,:argl] => + ['LIST,MKQ 'Record,:[mkDomainConstructor y for y in argl]] + x is ['Join,:argl] => + ['LIST,MKQ 'Join,:[mkDomainConstructor y for y in argl]] + x is ['call,:argl] => ['MKQ, optCall x] + --The previous line added JHD/BMT 20/3/84 + --Necessary for proper compilation of DPOLY SPAD + x is [op] => MKQ x + x is [op,:argl] => ['LIST,MKQ op,:[mkDomainConstructor a for a in argl]] + +setVector4(catNames,catsig,conditions) == + if $HackSlot4 then + for ['LET,name,cond,:.] in $getDomainCode repeat + $HackSlot4:=SUBST(name,cond,$HackSlot4) + code:= +--+ + ['SETELT,'$,4,'TrueDomain] + code:=['(LET TrueDomain (NREVERSE TrueDomain)),:$HackSlot4,code] + code:= + [: + [setVector4Onecat(u,v,w) + for u in catNames for v in catsig for w in conditions],:code] + ['(LET TrueDomain NIL),:code] + +setVector4Onecat(name,instantiator,info) == + --generates code to create one item in the + --Alist representing a domain + --returns a single LISP expression + instantiator is ['DomainSubstitutionMacro,.,body] => + setVector4Onecat(name,body,info) + data:= + --CAR name.4 contains all the names except itself + --hence we need to add this on, by the above CONS + ['CONS,['CONS,mkDomainConstructor instantiator,['CAR,['ELT,name,4]]], + name] + data:= ['SETQ,'TrueDomain,['CONS,data,'TrueDomain]] + TruthP info => data + ['COND,[TryGDC PrepareConditional info,data],: + Supplementaries(instantiator,name)] where + Supplementaries(instantiator,name) == + slist:= + [u for u in $supplementaries | AncestorP(first u,[instantiator])] + null slist => nil + $supplementaries:= S_-($supplementaries,slist) + PRETTYPRINT [instantiator,'" should solve"] + PRETTYPRINT slist + slist:= + [form(u,name) for u in slist] where + form([cat,:cond],name) == + u:= ['QUOTE,[cat,:first (eval cat).4]] + ['COND,[TryGDC cond,['SETQ,'TrueDomain,['CONS,['CONS,u,name], + 'TrueDomain]]]] + LENGTH slist=1 => [CADAR slist] + --return a list, since it is CONSed + slist:= ['PROGN,:slist] + [['(QUOTE T),slist]] + +setVector4part3(catNames,catvecList) == + --the names are those that will be applied to the various vectors + generated:= nil + for u in catvecList for uname in catNames repeat + for v in CADDR u.4 repeat + if w:= ASSOC(first v,generated) + then RPLACD(w,[[rest v,:uname],:rest w]) + else generated:= [[first v,[rest v,:uname]],:generated] + codeList := nil + for [w,:u] in generated repeat + code := compCategories w + for v in u repeat + code:= [($QuickCode => 'QSETREFV; 'SETELT),rest v,first v,code] + if CONTAINED('$,w) then $epilogue := [code,:$epilogue] + else codeList := [code,:codeList] + codeList + +PrepareConditional u == u + +setVector5(catNames,locals) == + generated:= nil + for u in locals for uname in catNames repeat + if w:= ASSOC(u,generated) + then RPLACD(w,[uname,:rest w]) + else generated:= [[u,uname],:generated] + [(w:= mkVectorWithDeferral(first u,first rest u); + for v in rest u repeat + w:= [($QuickCode => 'QSETREFV; 'SETELT),v,5,w]; + w) + for u in generated] + +mkVectorWithDeferral(objects,tag) == +-- Basically a mkVector, but spots things that aren't safe to instantiate +-- and places them at the end of $ConstantAssignments, so that they get +-- called AFTER the constants of $ have been set up. JHD 26.July.89 + ['VECTOR,: + [if CONTAINED('$,u) then -- It's not safe to instantiate this now + $ConstantAssignments:=[:$ConstantAssignments, + [($QuickCode=>'QSETREFV;'SETELT), + [($QuickCode=>'QREFELT;'ELT), tag, 5], + count, + u]] + [] + else u + for u in objects for count in 0..]] + +DescendCodeAdd(base,flag) == + atom base => DescendCodeVarAdd(base,flag) + not (modemap:=get(opOf base,'modemap,$CategoryFrame)) => + if getmode(opOf base,$e) is ["Mapping",target,:formalArgModes] + then formalArgs:= take(#formalArgModes,$FormalMapVariableList) + --argument substitution if parameterized? + + else keyedSystemError("S2OR0001",[opOf base]) + DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) + for [[[.,:formalArgs],target,:formalArgModes],.] in modemap repeat + (ans:= DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes))=> + return ans + ans + +DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == + slist:= pairList(formalArgs,rest $addFormLhs) + --base = comp $addFormLhs-- bound in compAdd + e:= $e + newModes:= SUBLIS(slist,formalArgModes) + or/[not comp(u,m,e) for u in rest $addFormLhs for m in newModes] => + return nil + --I should check that the actual arguments are of the right type + for u in formalArgs for m in newModes repeat + [.,.,e]:= compMakeDeclaration(['_:,u,m],m,e) + --we can not substitute in the formal arguments before we comp + --for that may change the shape of the object, but we must before + --we match signatures + cat:= (compMakeCategoryObject(target,e)).expr + instantiatedBase:= GENVAR() + n:=MAXINDEX cat + code:= + [u + for i in 6..n | not atom cat.i and not atom (sig:= first cat.i) + and + (u:= + SetFunctionSlots(SUBLIS(slist,sig),['ELT,instantiatedBase,i],flag, + 'adding))^=nil] + --The code from here to the end is designed to replace repeated LOAD/STORE + --combinations (SETELT ...(ELT ..)) by MVCs where this is practicable + copyvec:=GETREFV (1+n) + for u in code repeat + if update(u,copyvec,[]) then code:=delete(u,code) + where update(code,copyvec,sofar) == + ATOM code =>nil + MEMQ(QCAR code,'(ELT QREFELT)) => + copyvec.(CADDR code):=union(copyvec.(CADDR code), sofar) + true + code is [x,name,number,u'] and MEMQ(x,'(SETELT QSETREFV)) => + update(u',copyvec,[[name,:number],:sofar]) + for i in 6..n repeat + for u in copyvec.i repeat + [name,:count]:=u + j:=i+1 + while j<= MIN(n,i+63) and LASSOC(name,copyvec.j) = count+j-i repeat j:=j+1 + --Maximum length of an MVC is 64 words + j:=j-1 + j > i+2 => + for k in i..j repeat copyvec.k:=delete([name,:count+k-i],copyvec.k) + code:=[['REPLACE, name, instantiatedBase, + INTERN('"START1",'"KEYWORD"), count, + INTERN('"START2",'"KEYWORD"), i, + INTERN('"END2",'"KEYWORD"), j+1],:code] + copyvec.i => + v:=[($QuickCode => 'QREFELT;'ELT),instantiatedBase,i] + for u in copyvec.i repeat + [name,:count]:=u + v:=[($QuickCode => 'QSETREFV;'SETELT),name,count,v] + code:=[v,:code] + [['LET,instantiatedBase,base],:code] + +DescendCode(code,flag,viewAssoc,EnvToPass) == + -- flag = true if we are walking down code always executed; + -- otherwise set to conditions in which + code=nil => nil + code='noBranch => nil + isMacro(code,$e) => nil --RDJ: added 3/16/83 + code is ['add,base,:codelist] => + codelist:= + [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil] + -- must do this first, to get this overriding Add code + ['PROGN,:DescendCodeAdd(base,flag),:codelist] + code is ['PROGN,:codelist] => + ['PROGN,: + --Two REVERSEs leave original order, but ensure last guy wins + NREVERSE [v for u in REVERSE codelist | + (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] + code is ['COND,:condlist] => + c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == + null u2 => nil + f:= + TruthP u2 => flag; + TruthP flag => + flag := ['NOT,u2] + u2 + flag := ['AND,flag,['NOT,u2]]; + ['AND,flag,u2] + [DescendCode(v, f, + if first u is ['HasCategory,dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc,EnvToPass) for v in rest u] + TruthP CAAR c => ['PROGN,:CDAR c] + while (c and (LAST c is [c1] or LAST c is [c1,[]]) and + (c1 = '(QUOTE T) or c1 is ['HasAttribute,:.])) repeat + --strip out some worthless junk at the end + c:=NREVERSE CDR NREVERSE c + null c => '(LIST) + ['COND,:c] + code is ['LET,name,body,:.] => + --only keep the names that are useful + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + u:=member(name,$locals) => + CONTAINED('$,body) and isDomainForm(body,$e) => + --instantiate domains which depend on $ after constants are set + code:=[($QuickCode => 'QSETREFV; 'SETELT),[($QuickCode => 'QREFELT; 'ELT),'$,5],#$locals-#u,code] + $epilogue:= + TruthP flag => [code,:$epilogue] + [['COND,[ProcessCond(flag,viewAssoc),code]],:$epilogue] + nil + code + code -- doItIf deletes entries from $locals so can't optimize this + code is ['CodeDefine,sig,implem] => + --Generated by doIt in COMPILER BOOT + dom:= EnvToPass + dom:= + u:= LASSOC(dom,viewAssoc) => ['getDomainView,dom,u] + dom + body:= ['CONS,implem,dom] + u:= SetFunctionSlots(sig,body,flag,'original) + ConstantCreator u => + if not (flag=true) then u:= ['COND,[ProcessCond(flag,viewAssoc),u]] + $ConstantAssignments:= [u,:$ConstantAssignments] + nil + u + code is ['_:,:.] => (RPLACA(code,'LIST); RPLACD(code,NIL)) + --Yes, I know that's a hack, but how else do you kill a line? + code is ['LIST,:.] => nil + code is ['devaluate,:.] => nil + code is ['MDEF,:.] => nil + code is ['call,:.] => code + code is ['SETELT,:.] => code -- can be generated by doItIf + code is ['QSETREFV,:.] => code -- can be generated by doItIf + stackWarning ['"unknown Functor code ",code] + code + +ConstantCreator u == + null u => nil + u is [q,.,.,u'] and (q='SETELT or q='QSETREFV) => ConstantCreator u' + u is ['CONS,:.] => nil + true + +ProcessCond(cond,viewassoc) == + ncond := SUBLIS($pairlis,cond) + INTEGERP POSN1(ncond,$NRTslot1PredicateList) => predicateBitRef ncond + cond +--+ +TryGDC cond == + --sees if a condition can be optimised by the use of + --information in $getDomainCode + atom cond => cond + cond is ['HasCategory,:l] => + solved:= nil + for u in $getDomainCode | not solved repeat + if u is ['LET,name, =cond] then solved:= name + solved => solved + cond + cond + +SetFunctionSlots(sig,body,flag,mode) == --mode is either "original" or "adding" +--+ + catNames := ['$] + for u in $catvecList for v in catNames repeat + null body => return NIL + for catImplem in LookUpSigSlots(sig,u.1) repeat + if catImplem is [q,.,index] and (q='ELT or q='CONST) + then + if q is 'CONST and body is ['CONS,a,b] then + body := ['CONS,'IDENTITY,['FUNCALL,a,b]] + body:= [($QuickCode => 'QSETREFV; 'SETELT),v,index,body] + if REFVECP $SetFunctions and TruthP flag then u.index:= true + --used by CheckVector to determine which ops are missing + if v='$ then -- i.e. we are looking at the principal view + not REFVECP $SetFunctions => nil + --packages don't set it + $MissingFunctionInfo.index:= flag + TruthP $SetFunctions.index => (body:= nil; return nil) + -- the function was already assigned + $SetFunctions.index:= + TruthP flag => true + not $SetFunctions.index=>flag --JHD didn't set $SF on this branch + ["or",$SetFunctions.index,flag] + else + if catImplem is ['Subsumed,:truename] + --a special marker generated by SigListUnion + then + if mode='original + then if truename is [fn,:.] and MEMQ(fn,'(Zero One)) + then nil --hack by RDJ 8/90 + else body:= SetFunctionSlots(truename,body,nil,mode) + else nil + else + if not (catImplem is ['PAC,:.]) then + keyedSystemError("S2OR0002",[catImplem]) + body is ['SETELT,:.] => body + body is ['QSETREFV,:.] => body + nil + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +LookUpSigSlots(sig,siglist) == +--+ must kill any implementations below of the form (ELT $ NIL) + siglist := $lisplibOperationAlist + REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) + and KADDR implem] + +SigSlotsMatch(sig,pattern,implem) == + sig=pattern => true + not (LENGTH CADR sig=LENGTH CADR pattern) => nil + --CADR sig is the actual signature part + not (first sig=first pattern) => nil + pat' :=SUBSTQ($definition,'$,CADR pattern) + sig' :=SUBSTQ($definition,'$,CADR sig) + sig'=pat' => true + --If we don't have this next test, then we'll recurse in SetFunctionSlots + implem is ['Subsumed,:.] => nil + SourceLevelSubsume(sig',pat') => true + nil + +CheckVector(vec,name,catvecListMaker) == + code:= nil + condAlist := + [[a,:first b] for [.,a,:b] in $getDomainCode] + -- used as substitution alist below + for i in 6..MAXINDEX vec repeat + v:= vec.i + v=true => nil + null v => nil + --a domain, which setVector4part3 will fill in + atom v => systemErrorHere '"CheckVector" + atom first v => + --It's a secondary view of a domain, which we + --must generate code to fill in + for x in $catNames for y in catvecListMaker repeat + if y=v then code:= + [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] + if name='$ then + ASSOC(first v,$CheckVectorList) => nil + $CheckVectorList:= + [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] +-- member(first v,$CheckVectorList) => nil +-- $CheckVectorList:= [first v,:$CheckVectorList] + code + +makeMissingFunctionEntry(alist,i) == + tran SUBLIS(alist,$MissingFunctionInfo.i) where + tran x == + x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b] + x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]] + x + +--% Under what conditions may views exist? + +InvestigateConditions catvecListMaker == + -- given a principal view and a list of secondary views, + -- discover under what conditions the secondary view are + -- always present. + $Conditions: local:= nil + $principal: local + [$principal,:secondaries]:= catvecListMaker + --We are not interested in the principal view + --The next block allows for the possibility that $principal may + --have conditional secondary views +--+ + null secondaries => '(T) + --return for packages which generally have no secondary views + if $principal is [op,:.] then + [principal',:.]:=compMakeCategoryObject($principal,$e) + --Rather like eval, but quotes parameters first + for u in CADR principal'.4 repeat + if not TruthP(cond:=CADR u) then + new:=['CATEGORY,'domain,['IF,cond,['ATTRIBUTE,CAR u], 'noBranch]] + $principal is ['Join,:l] => + not member(new,l) => + $principal:=['Join,:l,new] + $principal:=['Join,$principal,new] + principal' := + pessimise $principal where + pessimise a == + atom a => a + a is ['SIGNATURE,:.] => a + a is ['IF,cond,:.] => + if not member(cond,$Conditions) then $Conditions:= [cond,:$Conditions] + nil + [pessimise first a,:pessimise rest a] + null $Conditions => [true,:[true for u in secondaries]] + PrincipalSecondaries:= getViewsConditions principal' + MinimalPrimary:= CAR first PrincipalSecondaries + MaximalPrimary:= CAAR $domainShell.4 + necessarySecondaries:= [first u for u in PrincipalSecondaries | rest u=true] + and/[member(u,necessarySecondaries) for u in secondaries] => + [true,:[true for u in secondaries]] + $HackSlot4:= + MinimalPrimary=MaximalPrimary => nil + MaximalPrimaries:=[MaximalPrimary,:CAR (CatEval MaximalPrimary).4] + MinimalPrimaries:=[MinimalPrimary,:CAR (CatEval MinimalPrimary).4] + MaximalPrimaries:=S_-(MaximalPrimaries,MinimalPrimaries) + [[x] for x in MaximalPrimaries] + ($Conditions:= Conds($principal,nil)) where + Conds(code,previous) == + --each call takes a list of conditions, and returns a list + --of refinements of that list + atom code => [previous] + code is ['DomainSubstitutionMacro,.,b] => Conds(b,previous) + code is ['IF,a,b,c] => union(Conds(b,[a,:previous]),Conds(c,previous)) + code is ['PROGN,:l] => "union"/[Conds(u,previous) for u in l] + code is ['CATEGORY,:l] => "union"/[Conds(u,previous) for u in l] + code is ['Join,:l] => "union"/[Conds(u,previous) for u in l] + [previous] + $Conditions:= EFFACE(nil,[EFFACE(nil,u) for u in $Conditions]) + partList:= + [getViewsConditions partPessimise($principal,cond) for cond in $Conditions] + masterSecondaries:= secondaries + for u in partList repeat + for [v,:.] in u repeat + if not member(v,secondaries) then secondaries:= [v,:secondaries] + --PRETTYPRINT $Conditions + --PRETTYPRINT masterSecondaries + --PRETTYPRINT secondaries + (list:= [mkNilT member(u,necessarySecondaries) for u in secondaries]) where + mkNilT u == + u => true + nil + for u in $Conditions for newS in partList repeat + --newS is a list of secondaries and conditions (over and above + --u) for which they apply + u:= + LENGTH u=1 => first u + ['AND,:u] + for [v,:.] in newS repeat + for v' in [v,:CAR (CatEval v).4] repeat + if (w:=ASSOC(v',$HackSlot4)) then + RPLAC(rest w,if rest w then mkOr(u,rest w) else u) + (list:= update(list,u,secondaries,newS)) where + update(list,cond,secondaries,newS) == + (list2:= + [flist(sec,newS,old,cond) for sec in secondaries for old in list]) where + flist(sec,newS,old,cond) == + old=true => old + for [newS2,:morecond] in newS repeat + old:= + not AncestorP(sec,[newS2]) => old + cond2:= mkAnd(cond,morecond) + null old => cond2 + mkOr(cond2,old) + old + list2 + list:= [[sec,:ICformat u] for u in list for sec in secondaries] + pv:= getPossibleViews $principal +-- $HackSlot4 is used in SetVector4 to ensure that conditional +-- extensions of the principal view are handles correctly +-- here we build the code necessary to remove spurious extensions + ($HackSlot4:= [reshape u for u in $HackSlot4]) where + reshape u == + ['COND,[TryGDC ICformat rest u], + ['(QUOTE T),['RPLACA,'(CAR TrueDomain), + ['delete,['QUOTE,first u],'(CAAR TrueDomain)]]]] + $supplementaries:= + [u + for u in list | not member(first u,masterSecondaries) + and not (true=rest u) and not member(first u,pv)] + [true,:[LASSOC(ms,list) for ms in masterSecondaries]] + +ICformat u == + atom u => u + u is ['has,:.] => compHasFormat u + u is ['AND,:l] or u is ['and,:l] => + l:= REMDUP [ICformat v for [v,:l'] in tails l | not member(v,l')] + -- we could have duplicates after, even if not before + LENGTH l=1 => first l + l1:= first l + for u in rest l repeat + l1:=mkAnd(u,l1) + l1 + u is ['OR,:l] => + (l:= ORreduce l) where + ORreduce l == + for u in l | u is ['AND,:.] or u is ['and,:.] repeat + --check that B causes (and A B) to go + for v in l | not (v=u) repeat + if member(v,u) or (and/[member(w,u) for w in v]) then l:= + delete(u,l) + --v subsumes u + --Note that we are ignoring AND as a component. + --Convince yourself that this code still works + l + LENGTH l=1 => ICformat first l + l:= ORreduce REMDUP [ICformat u for u in l] + --causes multiple ANDs to be squashed, etc. + -- and duplicates that have been built up by tidying + (l:= Hasreduce l) where + Hasreduce l == + for u in l | u is ['HasCategory,name,cond] and cond is ['QUOTE, + cond] repeat + --check that v causes descendants to go + for v in l | not (v=u) and v is ['HasCategory, =name,['QUOTE, + cond2]] repeat if DescendantP(cond,cond2) then l:= delete(u,l) + --v subsumes u + for u in l | u is ['AND,:l'] or u is ['and,:l'] repeat + for u' in l' | u' is ['HasCategory,name,cond] and cond is ['QUOTE, + cond] repeat + --check that v causes descendants to go + for v in l | v is ['HasCategory, =name,['QUOTE, + cond2]] repeat if DescendantP(cond,cond2) then l:= delete(u,l) + --v subsumes u + l + LENGTH l=1 => first l + ['OR,:l] + systemErrorHere '"ICformat" + +partPessimise(a,trueconds) == + atom a => a + a is ['SIGNATURE,:.] => a + a is ['IF,cond,:.] => (member(cond,trueconds) => a; nil) + [partPessimise(first a,trueconds),:partPessimise(rest a,trueconds)] + +getPossibleViews u == + --returns a list of all the categories that can be views of this one + [vec,:.]:= compMakeCategoryObject(u,$e) or + systemErrorHere '"getPossibleViews" + views:= [first u for u in CADR vec.4] + null vec.0 => [CAAR vec.4,:views] --* + [vec.0,:views] --* + --the two lines marked ensure that the principal view comes first + --if you don't want it, CDR it off + +getViewsConditions u == + + --returns a list of all the categories that can be views of this one + --paired with the condition under which they are such views + [vec,:.]:= compMakeCategoryObject(u,$e) or + systemErrorHere '"getViewsConditions" + views:= [[first u,:CADR u] for u in CADR vec.4] + null vec.0 => +--+ + null CAR vec.4 => views + [[CAAR vec.4,:true],:views] --* + [[vec.0,:true],:views] --* + --the two lines marked ensure that the principal view comes first + --if you don't want it, CDR it off + +DescendCodeVarAdd(base,flag) == + princview := CAR $catvecList + [SetFunctionSlots(sig,SUBST('ELT,'CONST,implem),flag,'adding) repeat + for i in 6..MAXINDEX princview | + princview.i is [sig:=[op,types],:.] and + LASSOC([base,:SUBST(base,'$,types)],get(op,'modemap,$e)) is + [[pred,implem]]] + +resolvePatternVars(p,args) == + p := SUBLISLIS(args, $TriangleVariableList, p) + SUBLISLIS(args, $FormalMapVariableList, p) + +--resolvePatternVars(p,args) == +-- atom p => +-- isSharpVarWithNum p => args.(position(p,$FormalMapVariableList)) +-- p +-- [resolvePatternVars(CAR p,args),:resolvePatternVars(CDR p,args)] + +-- Mysterious JENKS definition follows: +--DescendCodeVarAdd(base,flag) == +-- baseops := [(u:=LASSOC([base,:SUBST(base,'$,types)], +-- get(op,'modemap,$e))) and [sig,:u] +-- for (sig := [op,types]) in $CheckVectorList] +-- $CheckVectorList := [sig for sig in $CheckVectorList +-- for op in baseops | null op] +-- [SetFunctionSlots(sig,implem,flag,'adding) +-- for u in baseops | u is [sig,[pred,implem]]] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-boot.boot b/src/interp/g-boot.boot deleted file mode 100644 index 11c45a29..00000000 --- a/src/interp/g-boot.boot +++ /dev/null @@ -1,459 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- @(#)g-boot.boot 2.2 89/11/02 14:44:09 - ---% BOOT to LISP Translation - --- these supplement those in DEF and MACRO LISP - ---% Utilities - - -$LET := 'SPADLET -- LET is a standard macro in Common Lisp - -nakedEXIT? c == - ATOM c => NIL - [a,:d] := c - IDENTP a => - a = 'EXIT => true - a = 'QUOTE => NIL - MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL - nakedEXIT?(d) - nakedEXIT?(a) or nakedEXIT?(d) - -mergeableCOND x == - ATOM(x) or x isnt ['COND,:cls] => NIL - -- to be mergeable, every result must be an EXIT and the last - -- predicate must be a pair - ok := true - while (cls and ok) repeat - [[p,:r],:cls] := cls - PAIRP QCDR r => ok := NIL - CAR(r) isnt ['EXIT,.] => ok := NIL - NULL(cls) and ATOM(p) => ok := NIL - NULL(cls) and (p = ''T) => ok := NIL - ok - -mergeCONDsWithEXITs l == - -- combines things like - -- (COND (foo (EXIT a))) - -- (COND (bar (EXIT b))) - -- into one COND - NULL l => NIL - ATOM l => l - NULL PAIRP QCDR l => l - a := QCAR l - if a is ['COND,:.] then a := flattenCOND a - am := mergeableCOND a - CDR(l) is [b,:k] and am and mergeableCOND(b) => - b:= flattenCOND b - c := ['COND,:QCDR a,:QCDR b] - mergeCONDsWithEXITs [flattenCOND c,:k] - CDR(l) is [b] and am => - [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] - [a,:mergeCONDsWithEXITs CDR l] - -removeEXITFromCOND? c == - -- c is '(COND ...) - -- only can do it if every clause simply EXITs - ok := true - c := CDR c - while ok and c repeat - [[p,:r],:c] := c - nakedEXIT? p => ok := NIL - [:f,r1] := r - nakedEXIT? f => ok := NIL - r1 isnt ['EXIT,r2] => ok := NIL - nakedEXIT? r2 => ok := NIL - ok - -removeEXITFromCOND c == - -- c is '(COND ...) - z := NIL - for cl in CDR c repeat - ATOM cl => z := CONS(cl,z) - cond := QCAR cl - length1? cl => - PAIRP(cond) and EQCAR(cond,'EXIT) => - z := CONS(QCDR cond,z) - z := CONS(cl,z) - cl' := REVERSE cl - lastSE := QCAR cl' - ATOM lastSE => z := CONS(cl,z) - EQCAR(lastSE,'EXIT) => - z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) - z := CONS(cl,z) - CONS('COND,NREVERSE z) - -flattenCOND body == - -- transforms nested COND clauses to flat ones, if possible - body isnt ['COND,:.] => body - ['COND,:extractCONDClauses body] - -extractCONDClauses clauses == - -- extracts nested COND clauses into a flat structure - clauses is ['COND, [pred1,:act1],:restClauses] => - if act1 is [['PROGN,:acts]] then act1 := acts - restClauses is [[''T,restCond]] => - [[pred1,:act1],:extractCONDClauses restCond] - [[pred1,:act1],:restClauses] - [[''T,clauses]] - ---% COND and IF - -bootIF c == - -- handles IF expressions by turning them into CONDs - c is [.,p,t] => bootCOND ['COND,[p,t]] - [.,p,t,e] := c - bootCOND ['COND,[p,t],[''T,e]] - -bootCOND c == - -- handles COND expressions: c is ['COND,:.] - cls := CDR c - NULL cls => NIL - cls is [[''T,r],:.] => r - [:icls,fcls] := cls - ncls := NIL - for cl in icls repeat - [p,:r] := cl - ncls := - r is [['PROGN,:r1]] => CONS([p,:r1],ncls) - CONS(cl,ncls) - fcls := bootPushEXITintoCONDclause fcls - ncls := - fcls is [''T,['COND,:mcls]] => - APPEND(REVERSE mcls,ncls) - fcls is [''T,['PROGN,:mcls]] => - CONS([''T,:mcls],ncls) - CONS(fcls,ncls) - ['COND,:REVERSE ncls] - -bootPushEXITintoCONDclause e == - e isnt [''T,['EXIT,['COND,:cls]]] => e - ncls := NIL - for cl in cls repeat - [p,:r] := cl - ncls := - r is [['EXIT,:.]] => CONS(cl,ncls) - r is [r1] => CONS([p,['EXIT,r1]],ncls) - CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) - [''T,['COND,:NREVERSE ncls]] - ---% SEQ and PROGN - --- following is a more sophisticated def than that in MACRO LISP --- it is used for boot code - -tryToRemoveSEQ e == - -- returns e if unsuccessful - e isnt ['SEQ,cl,:cls] => NIL - nakedEXIT? cl => - cl is ['COND,[p,['EXIT,r]],:ccls] => - nakedEXIT? p or nakedEXIT? r => e - null ccls => - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] - bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] - e - bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] - -bootAbsorbSEQsAndPROGNs e == - -- assume e is a list from a SEQ or a PROGN - ATOM e => e - [:cls,lcl] := e - g := [:flatten(f) for f in cls] where - flatten x == - NULL x => NIL - IDENTP x => - MEMQ(x,$labelsForGO) => [x] - NIL - ATOM x => NIL - x is ['PROGN,:pcls,lpcl] => - ATOM lpcl => pcls - CDR x - -- next usually comes about from if foo then bar := zap - x is ['COND,y,[''T,'NIL]] => [['COND,y]] - [x] - while lcl is ['EXIT,f] repeat - lcl := f - lcl is ['PROGN,:pcls] => APPEND(g,pcls) - lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) - lcl is ['COND,[pred,['EXIT,h]]] => - APPEND(g,[['COND,[pred,h]]]) - APPEND(g,[lcl]) - -bootSEQ e == - e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] - if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then - e := ['SEQ,:cls,['EXIT,lcl]] - cls := QCDR e - cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls - cls is [['EXIT,body]] => - nakedEXIT? body => bootTran ['SEQ,body] - body - not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => - bootTran ['PROGN,:cls] - e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => - nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => - tryToRemoveSEQ e - bootTran ['COND,[pred,r1],[''T,:r2]] - tryToRemoveSEQ e - -bootPROGN e == - e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] - [.,:cls] := e - NULL cls => NIL - cls is [body] => body - e - ---% LET - -defLetForm(lhs,rhs) == ---if functionp lhs then --- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] - [$LET,lhs,rhs] - -defLET1(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - IDENTP rhs and not CONTAINED(rhs,lhs) => - rhs' := defLET2(lhs,rhs) - EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] - EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) - if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) - MKPROGN [:rhs',rhs] - PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => - -- handle things like [a] := x := foo - l1 := defLET1(name,CADDR rhs) - l2 := defLET1(lhs,name) - EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] - if IDENTP CAR l2 then l2 := cons(l2,nil) - MKPROGN [l1,:l2,name] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs' := [$LET,g,rhs] - let' := defLET1(lhs,g) - EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] - if IDENTP CAR let' then let' := CONS(let',NIL) - MKPROGN [rhs',:let',g] - -defLET2(lhs,rhs) == - IDENTP lhs => defLetForm(lhs,rhs) - NULL lhs => NIL - lhs is ['FLUID,id] => defLetForm(lhs,rhs) - lhs is [=$LET,a,b] => - a := defLET2(a,rhs) - null (b := defLET2(b,rhs)) => a - ATOM b => [a,b] - PAIRP QCAR b => CONS(a,b) - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => - defLET2(var2,addCARorCDR('CDR,rhs)) - l1 := defLET2(var1,addCARorCDR('CAR,rhs)) - MEMQ(var2,'(NIL _.)) => l1 - if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) - IDENTP var2 => - [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := defLET2(var2,addCARorCDR('CDR,rhs)) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - APPEND(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := defISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := defLET2(patrev,g) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - var1 = "." => [[$LET,g,rev],:l2] - last l2 is [=$LET, =var1, val1] => - [[$LET,g,rev],:REVERSE CDR REVERSE l2, - defLetForm(var1,['NREVERSE,val1])] - [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] - lhs is ['EQUAL,var1] => - ['COND,[['EQUAL,var1,rhs],var1]] - -- let the IS code take over from here - isPred := - $inDefIS => defIS1(rhs,lhs) - defIS(rhs,lhs) - ['COND,[isPred,rhs]] - -defLET(lhs,rhs) == - $letGenVarCounter : local := 1 - $inDefLET : local := true - defLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - NULL PAIRP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => - cons('last,QCDR expr) - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := position(QCAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then CONS(funsA.p,QCDR expr) - else CONS(funsR.p,QCDR expr) - - ---% IS - -defISReverse(x,a) == - -- reverses forms coming from APPENDs in patterns - -- pretty much just a translation of DEF-IS-REV - x is ['CONS,:.] => - NULL CADDR x => ['CONS,CADR x, a] - y := defISReverse(CADDR x, NIL) - RPLAC(CADDR y,['CONS,CADR x,a]) - y - ERRHUH() - -defIS1(lhs,rhs) == - NULL rhs => - ['NULL,lhs] - STRINGP rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ['EQUAL,lhs,rhs] - ATOM rhs => - ['PROGN,defLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ['EQUAL,lhs,rhs] - rhs is [=$LET,c,d] => - l := - $inDefLET => defLET1(c,lhs) - defLET(c,lhs) - ['AND,defIS1(lhs,d),MKPROGN [l,''T]] - rhs is ['EQUAL,a] => - ['EQUAL,lhs,a] - PAIRP lhs => - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "." => - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL]] - ['AND,['PAIRP,lhs], - defIS1(['QCDR,lhs],b)] - NULL b => - ['AND,['PAIRP,lhs], - ['EQ,['QCDR,lhs],'NIL],_ - defIS1(['QCAR,lhs],a)] - b = "." => - ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] - a1 := defIS1(['QCAR,lhs],a) - b1 := defIS1(['QCDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] - ['AND,['PAIRP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := defISReverse(b,a) - g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] - l2 := defIS1(g,patrev) - if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - a = "." => ['AND,rev,:l2] - ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] - SAY '"WARNING (defIS1): possibly bad IS code being generated" - DEF_-IS [lhs,rhs] - -defIS(lhs,rhs) == - $isGenVarCounter : local := 1 - $inDefIS : local := true - defIS1(DEFTRAN lhs,rhs) - ---% OR and AND - -bootOR e == - -- flatten any contained ORs. - cls := CDR e - NULL cls => NIL - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['OR,:.] => QCDR x - [x] - ['OR,:ncls] - -bootAND e == - -- flatten any contained ANDs. - cls := CDR e - NULL cls => 'T - NULL CDR cls => CAR cls - ncls := [:flatten(c) for c in cls] where - flatten x == - x is ['AND,:.] => QCDR x - [x] - ['AND,:ncls] - ---% Main Transformation Functions - -bootLabelsForGO e == - ATOM e => NIL - [head,:tail] := e - IDENTP head => - head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) - head = 'QUOTE => NIL - bootLabelsForGO tail - bootLabelsForGO head - bootLabelsForGO tail - -bootTran e == - ATOM e => e - [head,:tail] := e - head = 'QUOTE => e - tail := [bootTran t for t in tail] - e := [head,:tail] - IDENTP head => - head = 'IF => bootIF e - head = 'COND => bootCOND e - head = 'PROGN => bootPROGN e - head = 'SEQ => bootSEQ e - head = 'OR => bootOR e - head = 'AND => bootAND e - e - [bootTran head,:QCDR e] - -bootTransform e == ---NULL $BOOT => e - $labelsForGO : local := NIL - bootLabelsForGO e - bootTran e diff --git a/src/interp/g-boot.boot.pamphlet b/src/interp/g-boot.boot.pamphlet new file mode 100644 index 00000000..63a7c00a --- /dev/null +++ b/src/interp/g-boot.boot.pamphlet @@ -0,0 +1,485 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/g-boot.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- @(#)g-boot.boot 2.2 89/11/02 14:44:09 + +--% BOOT to LISP Translation + +-- these supplement those in DEF and MACRO LISP + +--% Utilities + + +$LET := 'SPADLET -- LET is a standard macro in Common Lisp + +nakedEXIT? c == + ATOM c => NIL + [a,:d] := c + IDENTP a => + a = 'EXIT => true + a = 'QUOTE => NIL + MEMQ(a,'(SEQ PROG LAMBDA MLAMBDA LAM)) => NIL + nakedEXIT?(d) + nakedEXIT?(a) or nakedEXIT?(d) + +mergeableCOND x == + ATOM(x) or x isnt ['COND,:cls] => NIL + -- to be mergeable, every result must be an EXIT and the last + -- predicate must be a pair + ok := true + while (cls and ok) repeat + [[p,:r],:cls] := cls + PAIRP QCDR r => ok := NIL + CAR(r) isnt ['EXIT,.] => ok := NIL + NULL(cls) and ATOM(p) => ok := NIL + NULL(cls) and (p = ''T) => ok := NIL + ok + +mergeCONDsWithEXITs l == + -- combines things like + -- (COND (foo (EXIT a))) + -- (COND (bar (EXIT b))) + -- into one COND + NULL l => NIL + ATOM l => l + NULL PAIRP QCDR l => l + a := QCAR l + if a is ['COND,:.] then a := flattenCOND a + am := mergeableCOND a + CDR(l) is [b,:k] and am and mergeableCOND(b) => + b:= flattenCOND b + c := ['COND,:QCDR a,:QCDR b] + mergeCONDsWithEXITs [flattenCOND c,:k] + CDR(l) is [b] and am => + [removeEXITFromCOND flattenCOND ['COND,:QCDR a,[''T,b]]] + [a,:mergeCONDsWithEXITs CDR l] + +removeEXITFromCOND? c == + -- c is '(COND ...) + -- only can do it if every clause simply EXITs + ok := true + c := CDR c + while ok and c repeat + [[p,:r],:c] := c + nakedEXIT? p => ok := NIL + [:f,r1] := r + nakedEXIT? f => ok := NIL + r1 isnt ['EXIT,r2] => ok := NIL + nakedEXIT? r2 => ok := NIL + ok + +removeEXITFromCOND c == + -- c is '(COND ...) + z := NIL + for cl in CDR c repeat + ATOM cl => z := CONS(cl,z) + cond := QCAR cl + length1? cl => + PAIRP(cond) and EQCAR(cond,'EXIT) => + z := CONS(QCDR cond,z) + z := CONS(cl,z) + cl' := REVERSE cl + lastSE := QCAR cl' + ATOM lastSE => z := CONS(cl,z) + EQCAR(lastSE,'EXIT) => + z := CONS(REVERSE CONS(CADR lastSE,CDR cl'),z) + z := CONS(cl,z) + CONS('COND,NREVERSE z) + +flattenCOND body == + -- transforms nested COND clauses to flat ones, if possible + body isnt ['COND,:.] => body + ['COND,:extractCONDClauses body] + +extractCONDClauses clauses == + -- extracts nested COND clauses into a flat structure + clauses is ['COND, [pred1,:act1],:restClauses] => + if act1 is [['PROGN,:acts]] then act1 := acts + restClauses is [[''T,restCond]] => + [[pred1,:act1],:extractCONDClauses restCond] + [[pred1,:act1],:restClauses] + [[''T,clauses]] + +--% COND and IF + +bootIF c == + -- handles IF expressions by turning them into CONDs + c is [.,p,t] => bootCOND ['COND,[p,t]] + [.,p,t,e] := c + bootCOND ['COND,[p,t],[''T,e]] + +bootCOND c == + -- handles COND expressions: c is ['COND,:.] + cls := CDR c + NULL cls => NIL + cls is [[''T,r],:.] => r + [:icls,fcls] := cls + ncls := NIL + for cl in icls repeat + [p,:r] := cl + ncls := + r is [['PROGN,:r1]] => CONS([p,:r1],ncls) + CONS(cl,ncls) + fcls := bootPushEXITintoCONDclause fcls + ncls := + fcls is [''T,['COND,:mcls]] => + APPEND(REVERSE mcls,ncls) + fcls is [''T,['PROGN,:mcls]] => + CONS([''T,:mcls],ncls) + CONS(fcls,ncls) + ['COND,:REVERSE ncls] + +bootPushEXITintoCONDclause e == + e isnt [''T,['EXIT,['COND,:cls]]] => e + ncls := NIL + for cl in cls repeat + [p,:r] := cl + ncls := + r is [['EXIT,:.]] => CONS(cl,ncls) + r is [r1] => CONS([p,['EXIT,r1]],ncls) + CONS([p,['EXIT,bootTran ['PROGN,:r]]],ncls) + [''T,['COND,:NREVERSE ncls]] + +--% SEQ and PROGN + +-- following is a more sophisticated def than that in MACRO LISP +-- it is used for boot code + +tryToRemoveSEQ e == + -- returns e if unsuccessful + e isnt ['SEQ,cl,:cls] => NIL + nakedEXIT? cl => + cl is ['COND,[p,['EXIT,r]],:ccls] => + nakedEXIT? p or nakedEXIT? r => e + null ccls => + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,:cls]]] + bootCOND ['COND,[p,r],[''T,bootSEQ ['SEQ,['COND,:ccls],:cls]]] + e + bootPROGN ['PROGN,cl,bootSEQ ['SEQ,:cls]] + +bootAbsorbSEQsAndPROGNs e == + -- assume e is a list from a SEQ or a PROGN + ATOM e => e + [:cls,lcl] := e + g := [:flatten(f) for f in cls] where + flatten x == + NULL x => NIL + IDENTP x => + MEMQ(x,$labelsForGO) => [x] + NIL + ATOM x => NIL + x is ['PROGN,:pcls,lpcl] => + ATOM lpcl => pcls + CDR x + -- next usually comes about from if foo then bar := zap + x is ['COND,y,[''T,'NIL]] => [['COND,y]] + [x] + while lcl is ['EXIT,f] repeat + lcl := f + lcl is ['PROGN,:pcls] => APPEND(g,pcls) + lcl is ['COND,[''T,:pcls]] => APPEND(g,pcls) + lcl is ['COND,[pred,['EXIT,h]]] => + APPEND(g,[['COND,[pred,h]]]) + APPEND(g,[lcl]) + +bootSEQ e == + e := ['SEQ,:mergeCONDsWithEXITs bootAbsorbSEQsAndPROGNs CDR e] + if e is [.,:cls,lcl] and IDENTP lcl and not MEMQ(lcl,$labelsForGO) then + e := ['SEQ,:cls,['EXIT,lcl]] + cls := QCDR e + cls is [['SEQ,:.]] => tryToRemoveSEQ QCAR cls + cls is [['EXIT,body]] => + nakedEXIT? body => bootTran ['SEQ,body] + body + not (nakedEXIT?(cls) or "or"/[MEMQ(g,$labelsForGO) for g in cls]) => + bootTran ['PROGN,:cls] + e is ['SEQ,['COND,[pred,['EXIT,r1]]],:r2] => + nakedEXIT?(pred) or nakedEXIT?(r1) or nakedEXIT?(r2) => + tryToRemoveSEQ e + bootTran ['COND,[pred,r1],[''T,:r2]] + tryToRemoveSEQ e + +bootPROGN e == + e := ['PROGN,:bootAbsorbSEQsAndPROGNs CDR e] + [.,:cls] := e + NULL cls => NIL + cls is [body] => body + e + +--% LET + +defLetForm(lhs,rhs) == +--if functionp lhs then +-- sayMSG ['"Danger: Reassigning value to LISP function:",:bright lhs] + [$LET,lhs,rhs] + +defLET1(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + IDENTP rhs and not CONTAINED(rhs,lhs) => + rhs' := defLET2(lhs,rhs) + EQCAR(rhs',$LET) => MKPROGN [rhs',rhs] + EQCAR(rhs','PROGN) => APPEND(rhs',[rhs]) + if IDENTP CAR rhs' then rhs' := CONS(rhs',NIL) + MKPROGN [:rhs',rhs] + PAIRP(rhs) and EQCAR(rhs, $LET) and IDENTP(name := CADR rhs) => + -- handle things like [a] := x := foo + l1 := defLET1(name,CADDR rhs) + l2 := defLET1(lhs,name) + EQCAR(l2,'PROGN) => MKPROGN [l1,:CDR l2] + if IDENTP CAR l2 then l2 := cons(l2,nil) + MKPROGN [l1,:l2,name] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + rhs' := [$LET,g,rhs] + let' := defLET1(lhs,g) + EQCAR(let','PROGN) => MKPROGN [rhs',:CDR let'] + if IDENTP CAR let' then let' := CONS(let',NIL) + MKPROGN [rhs',:let',g] + +defLET2(lhs,rhs) == + IDENTP lhs => defLetForm(lhs,rhs) + NULL lhs => NIL + lhs is ['FLUID,id] => defLetForm(lhs,rhs) + lhs is [=$LET,a,b] => + a := defLET2(a,rhs) + null (b := defLET2(b,rhs)) => a + ATOM b => [a,b] + PAIRP QCAR b => CONS(a,b) + [a,b] + lhs is ['CONS,var1,var2] => + var1 = "." or (PAIRP(var1) and EQCAR(var1,'QUOTE)) => + defLET2(var2,addCARorCDR('CDR,rhs)) + l1 := defLET2(var1,addCARorCDR('CAR,rhs)) + MEMQ(var2,'(NIL _.)) => l1 + if PAIRP l1 and ATOM CAR l1 then l1 := cons(l1,nil) + IDENTP var2 => + [:l1,defLetForm(var2,addCARorCDR('CDR,rhs))] + l2 := defLET2(var2,addCARorCDR('CDR,rhs)) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + APPEND(l1,l2) + lhs is ['APPEND,var1,var2] => + patrev := defISReverse(var2,var1) + rev := ['REVERSE,rhs] + g := INTERN STRCONC('"LETTMP#",STRINGIMAGE $letGenVarCounter) + $letGenVarCounter := $letGenVarCounter + 1 + l2 := defLET2(patrev,g) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + var1 = "." => [[$LET,g,rev],:l2] + last l2 is [=$LET, =var1, val1] => + [[$LET,g,rev],:REVERSE CDR REVERSE l2, + defLetForm(var1,['NREVERSE,val1])] + [[$LET,g,rev],:l2,defLetForm(var1,['NREVERSE,var1])] + lhs is ['EQUAL,var1] => + ['COND,[['EQUAL,var1,rhs],var1]] + -- let the IS code take over from here + isPred := + $inDefIS => defIS1(rhs,lhs) + defIS(rhs,lhs) + ['COND,[isPred,rhs]] + +defLET(lhs,rhs) == + $letGenVarCounter : local := 1 + $inDefLET : local := true + defLET1(lhs,rhs) + +addCARorCDR(acc,expr) == + NULL PAIRP expr => [acc,expr] + acc = 'CAR and EQCAR(expr,'REVERSE) => + cons('last,QCDR expr) + funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR) + p := position(QCAR expr,funs) + p = -1 => [acc,expr] + funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR + CAADDR CADAAR CADDAR CADADR CADDDR) + funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR + CDADDR CDDAAR CDDDAR CDDADR CDDDDR) + if acc = 'CAR then CONS(funsA.p,QCDR expr) + else CONS(funsR.p,QCDR expr) + + +--% IS + +defISReverse(x,a) == + -- reverses forms coming from APPENDs in patterns + -- pretty much just a translation of DEF-IS-REV + x is ['CONS,:.] => + NULL CADDR x => ['CONS,CADR x, a] + y := defISReverse(CADDR x, NIL) + RPLAC(CADDR y,['CONS,CADR x,a]) + y + ERRHUH() + +defIS1(lhs,rhs) == + NULL rhs => + ['NULL,lhs] + STRINGP rhs => + ['EQ,lhs,['QUOTE,INTERN rhs]] + NUMBERP rhs => + ['EQUAL,lhs,rhs] + ATOM rhs => + ['PROGN,defLetForm(rhs,lhs),''T] + rhs is ['QUOTE,a] => + IDENTP a => ['EQ,lhs,rhs] + ['EQUAL,lhs,rhs] + rhs is [=$LET,c,d] => + l := + $inDefLET => defLET1(c,lhs) + defLET(c,lhs) + ['AND,defIS1(lhs,d),MKPROGN [l,''T]] + rhs is ['EQUAL,a] => + ['EQUAL,lhs,a] + PAIRP lhs => + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + MKPROGN [[$LET,g,lhs],defIS1(g,rhs)] + rhs is ['CONS,a,b] => + a = "." => + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL]] + ['AND,['PAIRP,lhs], + defIS1(['QCDR,lhs],b)] + NULL b => + ['AND,['PAIRP,lhs], + ['EQ,['QCDR,lhs],'NIL],_ + defIS1(['QCAR,lhs],a)] + b = "." => + ['AND,['PAIRP,lhs],defIS1(['QCAR,lhs],a)] + a1 := defIS1(['QCAR,lhs],a) + b1 := defIS1(['QCDR,lhs],b) + a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => + ['AND,['PAIRP,lhs],MKPROGN [c,:cls]] + ['AND,['PAIRP,lhs],a1,b1] + rhs is ['APPEND,a,b] => + patrev := defISReverse(b,a) + g := INTERN STRCONC('"ISTMP#",STRINGIMAGE $isGenVarCounter) + $isGenVarCounter := $isGenVarCounter + 1 + rev := ['AND,['PAIRP,lhs],['PROGN,[$LET,g,['REVERSE,lhs]],''T]] + l2 := defIS1(g,patrev) + if PAIRP l2 and ATOM CAR l2 then l2 := cons(l2,nil) + a = "." => ['AND,rev,:l2] + ['AND,rev,:l2,['PROGN,defLetForm(a,['NREVERSE,a]),''T]] + SAY '"WARNING (defIS1): possibly bad IS code being generated" + DEF_-IS [lhs,rhs] + +defIS(lhs,rhs) == + $isGenVarCounter : local := 1 + $inDefIS : local := true + defIS1(DEFTRAN lhs,rhs) + +--% OR and AND + +bootOR e == + -- flatten any contained ORs. + cls := CDR e + NULL cls => NIL + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['OR,:.] => QCDR x + [x] + ['OR,:ncls] + +bootAND e == + -- flatten any contained ANDs. + cls := CDR e + NULL cls => 'T + NULL CDR cls => CAR cls + ncls := [:flatten(c) for c in cls] where + flatten x == + x is ['AND,:.] => QCDR x + [x] + ['AND,:ncls] + +--% Main Transformation Functions + +bootLabelsForGO e == + ATOM e => NIL + [head,:tail] := e + IDENTP head => + head = 'GO => $labelsForGO := CONS(CAR tail,$labelsForGO) + head = 'QUOTE => NIL + bootLabelsForGO tail + bootLabelsForGO head + bootLabelsForGO tail + +bootTran e == + ATOM e => e + [head,:tail] := e + head = 'QUOTE => e + tail := [bootTran t for t in tail] + e := [head,:tail] + IDENTP head => + head = 'IF => bootIF e + head = 'COND => bootCOND e + head = 'PROGN => bootPROGN e + head = 'SEQ => bootSEQ e + head = 'OR => bootOR e + head = 'AND => bootAND e + e + [bootTran head,:QCDR e] + +bootTransform e == +--NULL $BOOT => e + $labelsForGO : local := NIL + bootLabelsForGO e + bootTran e +@ + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot deleted file mode 100644 index eaa9dee7..00000000 --- a/src/interp/g-cndata.boot +++ /dev/null @@ -1,240 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Manipulation of Constructor Datat - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= -mkLowerCaseConTable() == ---Called at system build time by function BUILD-INTERPSYS (see util.lisp) ---Table is referenced by functions conPageFastPath and grepForAbbrev - $lowerCaseConTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat augmentLowerCaseConTable x - $lowerCaseConTb - -augmentLowerCaseConTable x == - y:=GETDATABASE(x,'ABBREVIATION) - item:=[x,y,nil] - HPUT($lowerCaseConTb,x,item) - HPUT($lowerCaseConTb,DOWNCASE x,item) - HPUT($lowerCaseConTb,y,item) - -getCDTEntry(info,isName) == - not IDENTP info => NIL - (entry := HGET($lowerCaseConTb,info)) => - [name,abb,:.] := entry - isName and EQ(name,info) => entry - not isName and EQ(abb,info) => entry - NIL - entry - -putConstructorProperty(name,prop,val) == - null (entry := getCDTEntry(name,true)) => NIL - RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) - true - -attribute? name == - MEMQ(name, _*ATTRIBUTES_*) - -abbreviation? abb == - -- if it is an abbreviation, return the corresponding name - GETDATABASE(abb,'CONSTRUCTOR) - -constructor? name == - -- if it is a constructor name, return the abbreviation - GETDATABASE(name,'ABBREVIATION) - -domainForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain - -packageForm? d == - GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package - -categoryForm? c == - op := opOf c - MEMQ(op, $CategoryNames) => true - GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true - nil - -getImmediateSuperDomain(d) == - IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) - -maximalSuperType d == - d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' - d - --- probably will switch over to 'libName soon -getLisplibName(c) == getConstructorAbbreviation(c) - -getConstructorAbbreviation op == - constructor?(op) or throwKeyedMsg("S2IL0015",[op]) - -getConstructorUnabbreviation op == - abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) - -mkUserConstructorAbbreviation(c,a,type) == - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - -abbQuery(x) == - abb := GETDATABASE(x,'ABBREVIATION) => - sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) - sayKeyedMsg("S2IZ0003",[x]) - -installConstructor(cname,type) == - (entry := getCDTEntry(cname,true)) => entry - item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] - if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then - HPUT($lowerCaseConTb,cname,item) - HPUT($lowerCaseConTb,DOWNCASE cname,item) - -constructorNameConflict(name,kind) == - userError - ["The name",:bright name,"conflicts with the name of an existing rule", - "%l","please choose another ",kind] - -constructorAbbreviationErrorCheck(c,a,typ,errmess) == - siz := SIZE (s := PNAME a) - if typ = 'category and siz > 7 - then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) - if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) - if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) - abb := GETDATABASE(c,'ABBREVIATION) - name:= GETDATABASE(a,'CONSTRUCTOR) - type := GETDATABASE(c,'CONSTRUCTORKIND) - a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) - a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) - c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) - -abbreviationError(c,a,typ,abb,name,type,error) == - sayKeyedMsg("S2IL0009",[a,typ,c]) - error='duplicateAbb => - throwKeyedMsg("S2IL0010",[a,typ,name]) - error='abbIsName => - throwKeyedMsg("S2IL0011",[a,type]) - error='wrongType => - throwKeyedMsg("S2IL0012",[c,type]) - NIL - -abbreviate u == - u is ['Union,:arglist] => - ['Union,:[abbreviate a for a in arglist]] - u is [op,:arglist] => - abb := constructor?(op) => - [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] - u - constructor?(u) or u - -unabbrev u == unabbrev1(u,nil) - -unabbrevAndLoad u == unabbrev1(u,true) - -isNameOfType x == - $doNotAddEmptyModeIfTrue:local:= true - (val := get(x,'value,$InteractiveFrame)) and - (domain := objMode val) and - domain in '((Mode) (Domain) (SubDomain (Domain))) => true - y := opOf unabbrev x - constructor? y - -unabbrev1(u,modeIfTrue) == - atom u => - modeIfTrue => - d:= isDomainValuedVariable u => u - a := abbreviation? u => - GETDATABASE(a,'NILADIC) => [a] - largs := ['_$EmptyMode for arg in - getPartialConstructorModemapSig(a)] - unabbrev1([u,:largs],modeIfTrue) - u - a:= abbreviation?(u) or u - GETDATABASE(a,'NILADIC) => [a] - a - [op,:arglist] := u - op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] - d:= isDomainValuedVariable op => - throwKeyedMsg("S2IL0013",[op,d]) - (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r - (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => - (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r - -- ??? if modeIfTrue then loadIfNecessary cname - [cname,:condUnabbrev(op,arglist, - getPartialConstructorModemapSig(cname),modeIfTrue)] - u - -unabbrevSpecialForms(op,arglist,modeIfTrue) == - op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] - op = 'Union => - [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] - op = 'Record => - [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] - nil - -unabbrevRecordComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - userError "wrong format for Record type" - -unabbrevUnionComponent(a,modeIfTrue) == - a is ["Declare",b,T] or a is [":",b,T] => - [":",b,unabbrev1(T,modeIfTrue)] - unabbrev1(a, modeIfTrue) - -condAbbrev(arglist,argtypes) == - res:= nil - for arg in arglist for type in argtypes repeat - if categoryForm?(type) then arg:= abbreviate arg - res:=[:res,arg] - res - -condUnabbrev(op,arglist,argtypes,modeIfTrue) == - #arglist ^= #argtypes => - throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), - bright(#arglist)]) - [newArg for arg in arglist for type in argtypes] where newArg == - categoryForm?(type) => unabbrev1(arg,modeIfTrue) - arg - ---% Code Being Phased Out - -nAssocQ(x,l,n) == - repeat - if atom l then return nil - if EQ(x,(QCAR l).n) then return QCAR l - l:= QCDR l - - diff --git a/src/interp/g-cndata.boot.pamphlet b/src/interp/g-cndata.boot.pamphlet new file mode 100644 index 00000000..7e09df96 --- /dev/null +++ b/src/interp/g-cndata.boot.pamphlet @@ -0,0 +1,262 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-cndata.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Manipulation of Constructor Datat + +--======================================================================= +-- Build Table of Lower Case Constructor Names +--======================================================================= +mkLowerCaseConTable() == +--Called at system build time by function BUILD-INTERPSYS (see util.lisp) +--Table is referenced by functions conPageFastPath and grepForAbbrev + $lowerCaseConTb := MAKE_-HASH_-TABLE() + for x in allConstructors() repeat augmentLowerCaseConTable x + $lowerCaseConTb + +augmentLowerCaseConTable x == + y:=GETDATABASE(x,'ABBREVIATION) + item:=[x,y,nil] + HPUT($lowerCaseConTb,x,item) + HPUT($lowerCaseConTb,DOWNCASE x,item) + HPUT($lowerCaseConTb,y,item) + +getCDTEntry(info,isName) == + not IDENTP info => NIL + (entry := HGET($lowerCaseConTb,info)) => + [name,abb,:.] := entry + isName and EQ(name,info) => entry + not isName and EQ(abb,info) => entry + NIL + entry + +putConstructorProperty(name,prop,val) == + null (entry := getCDTEntry(name,true)) => NIL + RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val)) + true + +attribute? name == + MEMQ(name, _*ATTRIBUTES_*) + +abbreviation? abb == + -- if it is an abbreviation, return the corresponding name + GETDATABASE(abb,'CONSTRUCTOR) + +constructor? name == + -- if it is a constructor name, return the abbreviation + GETDATABASE(name,'ABBREVIATION) + +domainForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain + +packageForm? d == + GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package + +categoryForm? c == + op := opOf c + MEMQ(op, $CategoryNames) => true + GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true + nil + +getImmediateSuperDomain(d) == + IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN) + +maximalSuperType d == + d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d' + d + +-- probably will switch over to 'libName soon +getLisplibName(c) == getConstructorAbbreviation(c) + +getConstructorAbbreviation op == + constructor?(op) or throwKeyedMsg("S2IL0015",[op]) + +getConstructorUnabbreviation op == + abbreviation?(op) or throwKeyedMsg("S2IL0019",[op]) + +mkUserConstructorAbbreviation(c,a,type) == + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +abbQuery(x) == + abb := GETDATABASE(x,'ABBREVIATION) => + sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x]) + sayKeyedMsg("S2IZ0003",[x]) + +installConstructor(cname,type) == + (entry := getCDTEntry(cname,true)) => entry + item := [cname,GETDATABASE(cname,'ABBREVIATION),nil] + if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then + HPUT($lowerCaseConTb,cname,item) + HPUT($lowerCaseConTb,DOWNCASE cname,item) + +constructorNameConflict(name,kind) == + userError + ["The name",:bright name,"conflicts with the name of an existing rule", + "%l","please choose another ",kind] + +constructorAbbreviationErrorCheck(c,a,typ,errmess) == + siz := SIZE (s := PNAME a) + if typ = 'category and siz > 7 + then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL) + if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL) + if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL) + abb := GETDATABASE(c,'ABBREVIATION) + name:= GETDATABASE(a,'CONSTRUCTOR) + type := GETDATABASE(c,'CONSTRUCTORKIND) + a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb) + a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName) + c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType) + +abbreviationError(c,a,typ,abb,name,type,error) == + sayKeyedMsg("S2IL0009",[a,typ,c]) + error='duplicateAbb => + throwKeyedMsg("S2IL0010",[a,typ,name]) + error='abbIsName => + throwKeyedMsg("S2IL0011",[a,type]) + error='wrongType => + throwKeyedMsg("S2IL0012",[c,type]) + NIL + +abbreviate u == + u is ['Union,:arglist] => + ['Union,:[abbreviate a for a in arglist]] + u is [op,:arglist] => + abb := constructor?(op) => + [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))] + u + constructor?(u) or u + +unabbrev u == unabbrev1(u,nil) + +unabbrevAndLoad u == unabbrev1(u,true) + +isNameOfType x == + $doNotAddEmptyModeIfTrue:local:= true + (val := get(x,'value,$InteractiveFrame)) and + (domain := objMode val) and + domain in '((Mode) (Domain) (SubDomain (Domain))) => true + y := opOf unabbrev x + constructor? y + +unabbrev1(u,modeIfTrue) == + atom u => + modeIfTrue => + d:= isDomainValuedVariable u => u + a := abbreviation? u => + GETDATABASE(a,'NILADIC) => [a] + largs := ['_$EmptyMode for arg in + getPartialConstructorModemapSig(a)] + unabbrev1([u,:largs],modeIfTrue) + u + a:= abbreviation?(u) or u + GETDATABASE(a,'NILADIC) => [a] + a + [op,:arglist] := u + op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]] + d:= isDomainValuedVariable op => + throwKeyedMsg("S2IL0013",[op,d]) + (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r + (cname := abbreviation? op) or (constructor?(op) and (cname := op)) => + (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r + -- ??? if modeIfTrue then loadIfNecessary cname + [cname,:condUnabbrev(op,arglist, + getPartialConstructorModemapSig(cname),modeIfTrue)] + u + +unabbrevSpecialForms(op,arglist,modeIfTrue) == + op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]] + op = 'Union => + [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]] + op = 'Record => + [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]] + nil + +unabbrevRecordComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + userError "wrong format for Record type" + +unabbrevUnionComponent(a,modeIfTrue) == + a is ["Declare",b,T] or a is [":",b,T] => + [":",b,unabbrev1(T,modeIfTrue)] + unabbrev1(a, modeIfTrue) + +condAbbrev(arglist,argtypes) == + res:= nil + for arg in arglist for type in argtypes repeat + if categoryForm?(type) then arg:= abbreviate arg + res:=[:res,arg] + res + +condUnabbrev(op,arglist,argtypes,modeIfTrue) == + #arglist ^= #argtypes => + throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"), + bright(#arglist)]) + [newArg for arg in arglist for type in argtypes] where newArg == + categoryForm?(type) => unabbrev1(arg,modeIfTrue) + arg + +--% Code Being Phased Out + +nAssocQ(x,l,n) == + repeat + if atom l then return nil + if EQ(x,(QCAR l).n) then return QCAR l + l:= QCDR l + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-error.boot b/src/interp/g-error.boot deleted file mode 100644 index 47e45e6d..00000000 --- a/src/interp/g-error.boot +++ /dev/null @@ -1,199 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import '"diagnostics" -)package "BOOT" - --- This file contains the error printing code used in BOOT and SPAD. --- While SPAD only calls "error" (which is then labeled as an algebra --- error, BOOT calls "userError" and "systemError" when a problem is --- found. --- --- The variable $BreakMode is set using the system command )set breakmode --- and can have one of the values: --- break -- always enter a lisp break when an error is signalled --- nobreak -- do not enter lisp break mode --- query -- ask the user if break mode should be entered - -SETANDFILEQ($SystemError,'SystemError) -SETANDFILEQ($UserError,'UserError) -SETANDFILEQ($AlgebraError,'AlgebraError) - --- REDERR is used in BFLOAT LISP, should be a macro --- REDERR msg == error msg - --- BFLERRMSG func == --- errorSupervisor($AlgebraError,STRCONC( --- '"BigFloat: invalid argument to ",func)) - -argumentDataError(argnum, condit, funname) == - msg := ['"The test",:bright pred2English condit,'"evaluates to", - :bright '"false",'%l,'" for argument",:bright argnum,_ - '"to the function",:bright funname,'"and this indicates",'%l,_ - '" that the argument is not appropriate."] - errorSupervisor($AlgebraError,msg) - -queryUser msg == - -- display message and return reply - sayBrightly msg - READ_-LINE _*TERMINAL_-IO_* - --- errorSupervisor is the old style error message trapper - -errorSupervisor(errorType,errorMsg) == - errorSupervisor1(errorType,errorMsg,$BreakMode) - -errorSupervisor1(errorType,errorMsg,$BreakMode) == - $cclSystem and $BreakMode = 'trapNumerics => - THROW('trapNumerics,$numericFailure) - BUMPERRORCOUNT "semantic" - errorLabel := - errorType = $SystemError => '"System error" - errorType = $UserError => '"Apparent user error" - errorType = $AlgebraError => - '"Error detected within library code" - STRINGP errorType => errorType - '"Error with unknown classification" - msg := - errorMsg is ['mathprint, :.] => errorMsg - not PAIRP errorMsg => ['" ", errorMsg] - splitmsg := true - if member('%b,errorMsg) then splitmsg := nil - else if member('%d,errorMsg) then splitmsg := nil - else if member('%l,errorMsg) then splitmsg := nil - splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] - ['" ",:errorMsg] - sayErrorly(errorLabel, msg) - handleLispBreakLoop($BreakMode) - -handleLispBreakLoop($BreakMode) == - TERPRI() - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - $BreakMode = 'break => - sayBrightly '" " - BREAK() - $BreakMode = 'query => - gotIt := nil - while not gotIt repeat - gotIt := true - msgQ := - $cclSystem => - ['%l,'" You have two options. Enter:",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - ['%l,'" You have three options. Enter:",'%l,_ - '" ",:bright '"continue",'" to continue processing,",'%l,_ - '" ",:bright '"top ",'" to return to top level, or",'%l,_ - '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ - '%l,'" Please enter your choice now:"] - x := STRING2ID_-N(queryUser msgQ,1) - x := - $cclSystem => - selectOptionLC(x,'(top break),NIL) - selectOptionLC(x,'(top break continue),NIL) - null x => - sayBrightly bright '" That was not one of your choices!" - gotIt := NIL - x = 'top => returnToTopLevel() - x = 'break => - $BreakMode := 'break - if not $cclSystem then - sayBrightly ['" Enter",:bright '":C", - '"when you are ready to continue processing where you ",'%l,_ - '" interrupted the system, enter",:bright '"(TOP)",_ - '"when you wish to return",'%l,'" to top level.",'%l,'%l] - BREAK() - sayBrightly - '" Processing will continue where it was interrupted." - THROW('SPAD__READER, nil) - $BreakMode = 'resume => - returnToReader() - returnToTopLevel() - -TOP() == returnToTopLevel() - -returnToTopLevel() == - SETQ(CHR, "ENDOFLINECHR") - SETQ(TOK, 'END__UNIT) - TOPLEVEL() - -returnToReader() == - ^$ReadingFile => returnToTopLevel() - sayBrightly ['" Continuing to read the file...", '%l] - THROW('SPAD__READER, nil) - -sayErrorly(errorLabel, msg) == - $saturn => saturnSayErrorly(errorLabel, msg) - sayErrorly1(errorLabel, msg) - -saturnSayErrorly(errorLabel, msg) == - _*STANDARD_-OUTPUT_* : fluid := $texOutputStream - old := pushSatOutput("line") - sayString '"\bgroup\color{red}" - sayString '"\begin{verbatim}" - sayErrorly1(errorLabel, msg) - sayString '"\end{verbatim}" - sayString '"\egroup" - popSatOutput(old) - -sayErrorly1(errorLabel, msg) == - sayBrightly '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayBrightly ['" >> ",errorLabel,'":"] - m := msg - msg is ['mathprint, mathexpr] => - mathprint mathexpr - sayBrightly msg - --- systemError is being phased out. Please use keyedSystemError. -systemError(:x) == errorSupervisor($SystemError,IFCAR x) - --- unexpectedSystemError() == --- systemError '"Oh, no. Unexpected internal error." - -userError x == errorSupervisor($UserError,x) - -error(x) == errorSupervisor($AlgebraError,x) - -IdentityError(op) == - error(["No identity element for reduce of empty list using operation",op]) - -throwMessage(:msg) == - if $compilingMap then clearCache $mapName - msg' := mkMessage concatList msg - sayMSG msg' - if $printMsgsToFile then sayMSG2File msg' - spadThrow() - diff --git a/src/interp/g-error.boot.pamphlet b/src/interp/g-error.boot.pamphlet new file mode 100644 index 00000000..103b8b0a --- /dev/null +++ b/src/interp/g-error.boot.pamphlet @@ -0,0 +1,224 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/g-error.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +import '"diagnostics" +)package "BOOT" + +-- This file contains the error printing code used in BOOT and SPAD. +-- While SPAD only calls "error" (which is then labeled as an algebra +-- error, BOOT calls "userError" and "systemError" when a problem is +-- found. +-- +-- The variable $BreakMode is set using the system command )set breakmode +-- and can have one of the values: +-- break -- always enter a lisp break when an error is signalled +-- nobreak -- do not enter lisp break mode +-- query -- ask the user if break mode should be entered + +SETANDFILEQ($SystemError,'SystemError) +SETANDFILEQ($UserError,'UserError) +SETANDFILEQ($AlgebraError,'AlgebraError) + +-- REDERR is used in BFLOAT LISP, should be a macro +-- REDERR msg == error msg + +-- BFLERRMSG func == +-- errorSupervisor($AlgebraError,STRCONC( +-- '"BigFloat: invalid argument to ",func)) + +argumentDataError(argnum, condit, funname) == + msg := ['"The test",:bright pred2English condit,'"evaluates to", + :bright '"false",'%l,'" for argument",:bright argnum,_ + '"to the function",:bright funname,'"and this indicates",'%l,_ + '" that the argument is not appropriate."] + errorSupervisor($AlgebraError,msg) + +queryUser msg == + -- display message and return reply + sayBrightly msg + READ_-LINE _*TERMINAL_-IO_* + +-- errorSupervisor is the old style error message trapper + +errorSupervisor(errorType,errorMsg) == + errorSupervisor1(errorType,errorMsg,$BreakMode) + +errorSupervisor1(errorType,errorMsg,$BreakMode) == + $cclSystem and $BreakMode = 'trapNumerics => + THROW('trapNumerics,$numericFailure) + BUMPERRORCOUNT "semantic" + errorLabel := + errorType = $SystemError => '"System error" + errorType = $UserError => '"Apparent user error" + errorType = $AlgebraError => + '"Error detected within library code" + STRINGP errorType => errorType + '"Error with unknown classification" + msg := + errorMsg is ['mathprint, :.] => errorMsg + not PAIRP errorMsg => ['" ", errorMsg] + splitmsg := true + if member('%b,errorMsg) then splitmsg := nil + else if member('%d,errorMsg) then splitmsg := nil + else if member('%l,errorMsg) then splitmsg := nil + splitmsg => CDR [:['%l,'" ",u] for u in errorMsg] + ['" ",:errorMsg] + sayErrorly(errorLabel, msg) + handleLispBreakLoop($BreakMode) + +handleLispBreakLoop($BreakMode) == + TERPRI() + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + $BreakMode = 'break => + sayBrightly '" " + BREAK() + $BreakMode = 'query => + gotIt := nil + while not gotIt repeat + gotIt := true + msgQ := + $cclSystem => + ['%l,'" You have two options. Enter:",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + ['%l,'" You have three options. Enter:",'%l,_ + '" ",:bright '"continue",'" to continue processing,",'%l,_ + '" ",:bright '"top ",'" to return to top level, or",'%l,_ + '" ",:bright '"break ",'" to enter a LISP break loop.",'%l,_ + '%l,'" Please enter your choice now:"] + x := STRING2ID_-N(queryUser msgQ,1) + x := + $cclSystem => + selectOptionLC(x,'(top break),NIL) + selectOptionLC(x,'(top break continue),NIL) + null x => + sayBrightly bright '" That was not one of your choices!" + gotIt := NIL + x = 'top => returnToTopLevel() + x = 'break => + $BreakMode := 'break + if not $cclSystem then + sayBrightly ['" Enter",:bright '":C", + '"when you are ready to continue processing where you ",'%l,_ + '" interrupted the system, enter",:bright '"(TOP)",_ + '"when you wish to return",'%l,'" to top level.",'%l,'%l] + BREAK() + sayBrightly + '" Processing will continue where it was interrupted." + THROW('SPAD__READER, nil) + $BreakMode = 'resume => + returnToReader() + returnToTopLevel() + +TOP() == returnToTopLevel() + +returnToTopLevel() == + SETQ(CHR, "ENDOFLINECHR") + SETQ(TOK, 'END__UNIT) + TOPLEVEL() + +returnToReader() == + ^$ReadingFile => returnToTopLevel() + sayBrightly ['" Continuing to read the file...", '%l] + THROW('SPAD__READER, nil) + +sayErrorly(errorLabel, msg) == + $saturn => saturnSayErrorly(errorLabel, msg) + sayErrorly1(errorLabel, msg) + +saturnSayErrorly(errorLabel, msg) == + _*STANDARD_-OUTPUT_* : fluid := $texOutputStream + old := pushSatOutput("line") + sayString '"\bgroup\color{red}" + sayString '"\begin{verbatim}" + sayErrorly1(errorLabel, msg) + sayString '"\end{verbatim}" + sayString '"\egroup" + popSatOutput(old) + +sayErrorly1(errorLabel, msg) == + sayBrightly '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayBrightly ['" >> ",errorLabel,'":"] + m := msg + msg is ['mathprint, mathexpr] => + mathprint mathexpr + sayBrightly msg + +-- systemError is being phased out. Please use keyedSystemError. +systemError(:x) == errorSupervisor($SystemError,IFCAR x) + +-- unexpectedSystemError() == +-- systemError '"Oh, no. Unexpected internal error." + +userError x == errorSupervisor($UserError,x) + +error(x) == errorSupervisor($AlgebraError,x) + +IdentityError(op) == + error(["No identity element for reduce of empty list using operation",op]) + +throwMessage(:msg) == + if $compilingMap then clearCache $mapName + msg' := mkMessage concatList msg + sayMSG msg' + if $printMsgsToFile then sayMSG2File msg' + spadThrow() + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot deleted file mode 100644 index 932cff17..00000000 --- a/src/interp/g-opt.boot +++ /dev/null @@ -1,399 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% OPTIMIZER - -optimizeFunctionDef(def) == - if $reportOptimization then - sayBrightlyI bright '"Original LISP code:" - pp def - - def' := optimize COPY def - - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp def' - sayBrightlyI bright '"Final LISP code:" - [name,[slamOrLam,args,body]] := def' - - body':= - removeTopLevelCatch body where - removeTopLevelCatch body == - body is ["CATCH",g,u] => - removeTopLevelCatch replaceThrowByReturn(u,g) - body - replaceThrowByReturn(x,g) == - fn(x,g) - x - fn(x,g) == - x is ["THROW", =g,:u] => - rplac(first x,"RETURN") - rplac(rest x,replaceThrowByReturn(u,g)) - atom x => nil - replaceThrowByReturn(first x,g) - replaceThrowByReturn(rest x,g) - [name,[slamOrLam,args,body']] - -optimize x == - (opt x; x) where - opt x == - atom x => nil - (y:= first x)='QUOTE => nil - y='CLOSEDFN => nil - y is [["XLAM",argl,body],:a] => - optimize rest x - argl = "ignore" => RPLAC(first x,body) - if not (LENGTH argl<=LENGTH a) then - SAY '"length mismatch in XLAM expression" - PRETTYPRINT y - RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) - atom y => - optimize rest x - y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) - y="false" => RPLAC(first x,nil) - if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) - op:= GETL(subrname first y,"OPTIMIZE") => - (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) - RPLAC(first x,optimize first x) - optimize rest x - -subrname u == - IDENTP u => u - COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u - nil - -optCatch (x is ["CATCH",g,a]) == - $InteractiveMode => x - atom a => a - if a is ["SEQ",:s,["THROW", =g,u]] then - changeThrowToExit(s,g) where - changeThrowToExit(s,g) == - atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil - s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) - changeThrowToExit(first s,g) - changeThrowToExit(rest s,g) - rplac(rest a,[:s,["EXIT",u]]) - ["CATCH",y,a]:= optimize x - if hasNoThrows(a,g) - then (rplac(first x,first a); rplac(rest x,rest a)) where - hasNoThrows(a,g) == - a is ["THROW", =g,:.] => false - atom a => true - hasNoThrows(first a,g) and hasNoThrows(rest a,g) - else - changeThrowToGo(a,g) where - changeThrowToGo(s,g) == - atom s or first s='QUOTE => nil - s is ["THROW", =g,u] => - changeThrowToGo(u,g) - rplac(first s,"PROGN") - rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) - changeThrowToGo(first s,g) - changeThrowToGo(rest s,g) - rplac(first x,"SEQ") - rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) - x - -optSPADCALL(form is ['SPADCALL,:argl]) == - null $InteractiveMode => form - -- last arg is function/env, but may be a form - argl is [:argl,fun] => - fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => - optCall ['call,['ELT,dom,slot],:argl] - form - form - -optCall (x is ["call",:u]) == - -- destructively optimizes this new x - x:= optimize [u] - -- next should happen only as result of macro expansion - atom first x => first x - [fn,:a]:= first x - atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) - fn is ["PAC",:.] => optPackageCall(x,fn,a) - fn is ["applyFun",name] => - (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) - fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => - not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w - q="CONST" => ---+ - ["spadConstant",R,n] - --putInLocalDomainReferences will change this to ELT or QREFELT - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - systemErrorHere '"optCall" - -optCallSpecially(q,x,n,R) == - y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) - MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) - (y:= get(R,"value",$e)) and - MEMQ(opOf y.expr,$optimizableConstructorNames) => - optSpecialCall(x,y.expr,n) - ( - (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and - (yy:= LASSOC(y,$specialCaseKeyList)) => - optSpecialCall(x,[op,yy,prop],n)) where - lookup(a,l) == - null l => nil - [l',:l]:= l - l' is ["LET", =a,l',:.] => l' - lookup(a,l) - nil - -optCallEval u == - u is ["List",:.] => List Integer() - u is ["Vector",:.] => Vector Integer() - u is ["PrimitiveArray",:.] => PrimitiveArray Integer() - u is ["FactoredForm",:.] => FactoredForm Integer() - u is ["Matrix",:.] => Matrix Integer() - eval u - -optCons (x is ["CONS",a,b]) == - a="NIL" => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) - x - a is ['QUOTE,a'] => - b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) - b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) - x - x - -optSpecialCall(x,y,n) == - yval := optCallEval y - CAAAR x="CONST" => - KAR yval.n = function Undef => - keyedSystemError("S2GE0016",['"optSpecialCall", - '"invalid constant"]) - MKQ yval.n - fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => - rplac(rest x,CDAR x) - rplac(first x,fn) - if fn is ["XLAM",:.] then x:=first optimize [x] - x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) - --DEF-EQUAL is really an optimiser - x - [fn,:a]:= first x - RPLAC(first x,"SPADCALL") - if $QuickCode then RPLACA(fn,"QREFELT") - RPLAC(rest x,[:a,fn]) - x - -compileTimeBindingOf u == - NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) - name="Undef" => MOAN "optimiser found unknown function" - name - -optMkRecord ["mkRecord",:u] == - u is [x] => ["LIST",x] - #u=2 => ["CONS",:u] - ["VECTOR",:u] - -optCond (x is ['COND,:l]) == - if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then - RPLACD(rest x,c) - if l is [[p1,:c1],[p2,:c2],:.] then - if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then - l:=[[p1,:c1],['(QUOTE T),:c2]] - RPLACD( x,l) - c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => - p1 is ['NULL,p1']=> return p1' - return ['NULL,p1] - l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => - EqualBarGensym(c1,c3) => - ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] - EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] - x - for y in tails l repeat - while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat - a:=['OR,a1,a2] - RPLAC(first first y,a) - RPLAC(rest y,y') - x - -AssocBarGensym(key,l) == - for x in l repeat - PAIRP x => - EqualBarGensym(key,CAR x) => return x - -EqualBarGensym(x,y) == - $GensymAssoc: nil - fn(x,y) where - fn(x,y) == - x=y => true - GENSYMP x and GENSYMP y => - z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) - $GensymAssoc:= [[x,:y],:$GensymAssoc] - true - null x => y is [g] and GENSYMP g - null y => x is [g] and GENSYMP g - atom x or atom y => false - fn(first x,first y) and fn(rest x,rest y) - ---Called early, to change IF to COND - -optIF2COND ["IF",a,b,c] == - b is "noBranch" => ["COND",[["NULL",a],c]] - c is "noBranch" => ["COND",[a,b]] - c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] - c is ["COND",:p] => ["COND",[a,b],:p] - ["COND",[a,b],[$true,c]] - -optXLAMCond x == - x is ["COND",u:= [p,c],:l] => - (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) - atom x => x - RPLAC(first x,optXLAMCond first x) - RPLAC(rest x,optXLAMCond rest x) - x - -optPredicateIfTrue p == - p is ['QUOTE,:.] => true - p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true - nil - -optCONDtail l == - null l => nil - [frst:= [p,c],:l']:= l - optPredicateIfTrue p => [[$true,c]] - null rest l => [frst,[$true,["CondError"]]] - [frst,:optCONDtail l'] - -optSEQ ["SEQ",:l] == - tryToRemoveSEQ SEQToCOND getRidOfTemps l where - getRidOfTemps l == - null l => nil - l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => - getRidOfTemps substitute(x,g,r) - first l="/throwAway" => getRidOfTemps rest l - --this gets rid of unwanted labels generated by declarations in SEQs - [first l,:getRidOfTemps rest l] - SEQToCOND l == - transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] - before:= take(#transform,l) - aft:= after(l,before) - null before => ["SEQ",:aft] - null aft => ["COND",:transform,'((QUOTE T) (conderr))] - true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] - tryToRemoveSEQ l == - l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a - l - -optRECORDELT ["RECORDELT",name,ind,len] == - len=1 => - ind=0 => ["QCAR",name] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["QCAR",name] - ind=1 => ["QCDR",name] - keyedSystemError("S2OO0002",[ind]) - ["QVELT",name,ind] - -optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == - len=1 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - keyedSystemError("S2OO0002",[ind]) - len=2 => - ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] - ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] - keyedSystemError("S2OO0002",[ind]) - ["QSETVELT",name,ind,expr] - -optRECORDCOPY ["RECORDCOPY",name,len] == - len=1 => ["LIST",["CAR",name]] - len=2 => ["CONS",["CAR",name],["CDR",name]] - ["MOVEVEC",["MAKE_-VEC",len],name] - ---mkRecordAccessFunction(ind,len) == --- stringOfDs:= $EmptyString --- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") --- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" --- if $QuickCode then prefix:=STRCONC("Q",prefix) --- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) - -optSuchthat [.,:u] == ["SUCHTHAT",:u] - -optMINUS u == - u is ['MINUS,v] => - NUMBERP v => -v - u - u - -optQSMINUS u == - u is ['QSMINUS,v] => - NUMBERP v => -v - u - u - -opt_- u == - u is ['_-,v] => - NUMBERP v => -v - u - u - -optLESSP u == - u is ['LESSP,a,b] => - b = 0 => ['MINUSP,a] - ['GREATERP,b,a] - u - -optEQ u == - u is ['EQ,l,r] => - NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] - -- That undoes some weird work in Boolean to do with the definition of true - u - u - -EVALANDFILEACTQ - ( - for x in '( (call optCall) _ - (SEQ optSEQ)_ - (EQ optEQ) - (MINUS optMINUS)_ - (QSMINUS optQSMINUS)_ - (_- opt_-)_ - (LESSP optLESSP)_ - (SPADCALL optSPADCALL)_ - (_| optSuchthat)_ - (CATCH optCatch)_ - (COND optCond)_ - (mkRecord optMkRecord)_ - (RECORDELT optRECORDELT)_ - (SETRECORDELT optSETRECORDELT)_ - (RECORDCOPY optRECORDCOPY)) _ - repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) - --much quicker to call functions if they have an SBC - ) - - diff --git a/src/interp/g-opt.boot.pamphlet b/src/interp/g-opt.boot.pamphlet new file mode 100644 index 00000000..33fad9dd --- /dev/null +++ b/src/interp/g-opt.boot.pamphlet @@ -0,0 +1,421 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-opt.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% OPTIMIZER + +optimizeFunctionDef(def) == + if $reportOptimization then + sayBrightlyI bright '"Original LISP code:" + pp def + + def' := optimize COPY def + + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp def' + sayBrightlyI bright '"Final LISP code:" + [name,[slamOrLam,args,body]] := def' + + body':= + removeTopLevelCatch body where + removeTopLevelCatch body == + body is ["CATCH",g,u] => + removeTopLevelCatch replaceThrowByReturn(u,g) + body + replaceThrowByReturn(x,g) == + fn(x,g) + x + fn(x,g) == + x is ["THROW", =g,:u] => + rplac(first x,"RETURN") + rplac(rest x,replaceThrowByReturn(u,g)) + atom x => nil + replaceThrowByReturn(first x,g) + replaceThrowByReturn(rest x,g) + [name,[slamOrLam,args,body']] + +optimize x == + (opt x; x) where + opt x == + atom x => nil + (y:= first x)='QUOTE => nil + y='CLOSEDFN => nil + y is [["XLAM",argl,body],:a] => + optimize rest x + argl = "ignore" => RPLAC(first x,body) + if not (LENGTH argl<=LENGTH a) then + SAY '"length mismatch in XLAM expression" + PRETTYPRINT y + RPLAC(first x,optimize optXLAMCond SUBLIS(pairList(argl,a),body)) + atom y => + optimize rest x + y="true" => RPLAC(first x,'(QUOTE (QUOTE T))) + y="false" => RPLAC(first x,nil) + if first y="IF" then (RPLAC(first x,optIF2COND y); y:= first x) + op:= GETL(subrname first y,"OPTIMIZE") => + (optimize rest x; RPLAC(first x,FUNCALL(op,optimize first x))) + RPLAC(first x,optimize first x) + optimize rest x + +subrname u == + IDENTP u => u + COMPILED_-FUNCTION_-P u or MBPIP u => BPINAME u + nil + +optCatch (x is ["CATCH",g,a]) == + $InteractiveMode => x + atom a => a + if a is ["SEQ",:s,["THROW", =g,u]] then + changeThrowToExit(s,g) where + changeThrowToExit(s,g) == + atom s or MEMQ(first s,'(QUOTE SEQ REPEAT COLLECT)) => nil + s is ["THROW", =g,:u] => (rplac(first s,"EXIT"); rplac(rest s,u)) + changeThrowToExit(first s,g) + changeThrowToExit(rest s,g) + rplac(rest a,[:s,["EXIT",u]]) + ["CATCH",y,a]:= optimize x + if hasNoThrows(a,g) + then (rplac(first x,first a); rplac(rest x,rest a)) where + hasNoThrows(a,g) == + a is ["THROW", =g,:.] => false + atom a => true + hasNoThrows(first a,g) and hasNoThrows(rest a,g) + else + changeThrowToGo(a,g) where + changeThrowToGo(s,g) == + atom s or first s='QUOTE => nil + s is ["THROW", =g,u] => + changeThrowToGo(u,g) + rplac(first s,"PROGN") + rplac(rest s,[["LET",CADR g,u],["GO",CADR g]]) + changeThrowToGo(first s,g) + changeThrowToGo(rest s,g) + rplac(first x,"SEQ") + rplac(rest x,[["EXIT",a],CADR g,["EXIT",CADR g]]) + x + +optSPADCALL(form is ['SPADCALL,:argl]) == + null $InteractiveMode => form + -- last arg is function/env, but may be a form + argl is [:argl,fun] => + fun is ['ELT,dom,slot] or fun is ['LISPELT,dom,slot] => + optCall ['call,['ELT,dom,slot],:argl] + form + form + +optCall (x is ["call",:u]) == + -- destructively optimizes this new x + x:= optimize [u] + -- next should happen only as result of macro expansion + atom first x => first x + [fn,:a]:= first x + atom fn => (RPLAC(rest x,a); RPLAC(first x,fn)) + fn is ["PAC",:.] => optPackageCall(x,fn,a) + fn is ["applyFun",name] => + (RPLAC(first x,"SPADCALL"); RPLAC(rest x,[:a,name]); x) + fn is [q,R,n] and MEMQ(q,'(ELT QREFELT CONST)) => + not $bootStrapMode and (w:= optCallSpecially(q,x,n,R)) => w + q="CONST" => +--+ + ["spadConstant",R,n] + --putInLocalDomainReferences will change this to ELT or QREFELT + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + systemErrorHere '"optCall" + +optCallSpecially(q,x,n,R) == + y:= LASSOC(R,$specialCaseKeyList) => optSpecialCall(x,y,n) + MEMQ(KAR R,$optimizableConstructorNames) => optSpecialCall(x,R,n) + (y:= get(R,"value",$e)) and + MEMQ(opOf y.expr,$optimizableConstructorNames) => + optSpecialCall(x,y.expr,n) + ( + (y:= lookup(R,$getDomainCode)) and ([op,y,prop]:= y) and + (yy:= LASSOC(y,$specialCaseKeyList)) => + optSpecialCall(x,[op,yy,prop],n)) where + lookup(a,l) == + null l => nil + [l',:l]:= l + l' is ["LET", =a,l',:.] => l' + lookup(a,l) + nil + +optCallEval u == + u is ["List",:.] => List Integer() + u is ["Vector",:.] => Vector Integer() + u is ["PrimitiveArray",:.] => PrimitiveArray Integer() + u is ["FactoredForm",:.] => FactoredForm Integer() + u is ["Matrix",:.] => Matrix Integer() + eval u + +optCons (x is ["CONS",a,b]) == + a="NIL" => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,['NIL,:c]); x) + x + a is ['QUOTE,a'] => + b='NIL => (rplac(first x,'QUOTE); rplac(rest x,[a',:'NIL]); x) + b is ['QUOTE,:c] => (rplac(first x,'QUOTE); rplac(rest x,[a',:c]); x) + x + x + +optSpecialCall(x,y,n) == + yval := optCallEval y + CAAAR x="CONST" => + KAR yval.n = function Undef => + keyedSystemError("S2GE0016",['"optSpecialCall", + '"invalid constant"]) + MKQ yval.n + fn := GETL(compileTimeBindingOf first yval.n,'SPADreplace) => + rplac(rest x,CDAR x) + rplac(first x,fn) + if fn is ["XLAM",:.] then x:=first optimize [x] + x is ["EQUAL",:args] => RPLACW(x,DEF_-EQUAL args) + --DEF-EQUAL is really an optimiser + x + [fn,:a]:= first x + RPLAC(first x,"SPADCALL") + if $QuickCode then RPLACA(fn,"QREFELT") + RPLAC(rest x,[:a,fn]) + x + +compileTimeBindingOf u == + NULL(name:= BPINAME u) => keyedSystemError("S2OO0001",[u]) + name="Undef" => MOAN "optimiser found unknown function" + name + +optMkRecord ["mkRecord",:u] == + u is [x] => ["LIST",x] + #u=2 => ["CONS",:u] + ["VECTOR",:u] + +optCond (x is ['COND,:l]) == + if l is [a,[aa,b]] and TruthP aa and b is ["COND",:c] then + RPLACD(rest x,c) + if l is [[p1,:c1],[p2,:c2],:.] then + if (p1 is ['NULL,p1'] and p1' = p2) or (p2 is ['NULL,p2'] and p2' = p1) then + l:=[[p1,:c1],['(QUOTE T),:c2]] + RPLACD( x,l) + c1 is ['NIL] and p2 = '(QUOTE T) and first c2 = '(QUOTE T) => + p1 is ['NULL,p1']=> return p1' + return ['NULL,p1] + l is [[p1,:c1],[p2,:c2],[p3,:c3]] and TruthP p3 => + EqualBarGensym(c1,c3) => + ["COND",[["OR",p1,["NULL",p2]],:c1],[['QUOTE,true],:c2]] + EqualBarGensym(c1,c2) => ["COND",[["OR",p1,p2],:c1],[['QUOTE,true],:c3]] + x + for y in tails l repeat + while y is [[a1,c1],[a2,c2],:y'] and EqualBarGensym(c1,c2) repeat + a:=['OR,a1,a2] + RPLAC(first first y,a) + RPLAC(rest y,y') + x + +AssocBarGensym(key,l) == + for x in l repeat + PAIRP x => + EqualBarGensym(key,CAR x) => return x + +EqualBarGensym(x,y) == + $GensymAssoc: nil + fn(x,y) where + fn(x,y) == + x=y => true + GENSYMP x and GENSYMP y => + z:= ASSOC(x,$GensymAssoc) => (y=rest z => true; false) + $GensymAssoc:= [[x,:y],:$GensymAssoc] + true + null x => y is [g] and GENSYMP g + null y => x is [g] and GENSYMP g + atom x or atom y => false + fn(first x,first y) and fn(rest x,rest y) + +--Called early, to change IF to COND + +optIF2COND ["IF",a,b,c] == + b is "noBranch" => ["COND",[["NULL",a],c]] + c is "noBranch" => ["COND",[a,b]] + c is ["IF",:.] => ["COND",[a,b],:rest optIF2COND c] + c is ["COND",:p] => ["COND",[a,b],:p] + ["COND",[a,b],[$true,c]] + +optXLAMCond x == + x is ["COND",u:= [p,c],:l] => + (optPredicateIfTrue p => c; ["COND",u,:optCONDtail l]) + atom x => x + RPLAC(first x,optXLAMCond first x) + RPLAC(rest x,optXLAMCond rest x) + x + +optPredicateIfTrue p == + p is ['QUOTE,:.] => true + p is [fn,x] and MEMQ(fn,$BasicPredicates) and FUNCALL(fn,x) => true + nil + +optCONDtail l == + null l => nil + [frst:= [p,c],:l']:= l + optPredicateIfTrue p => [[$true,c]] + null rest l => [frst,[$true,["CondError"]]] + [frst,:optCONDtail l'] + +optSEQ ["SEQ",:l] == + tryToRemoveSEQ SEQToCOND getRidOfTemps l where + getRidOfTemps l == + null l => nil + l is [["LET",g,x,:.],:r] and GENSYMP g and 2>numOfOccurencesOf(g,r) => + getRidOfTemps substitute(x,g,r) + first l="/throwAway" => getRidOfTemps rest l + --this gets rid of unwanted labels generated by declarations in SEQs + [first l,:getRidOfTemps rest l] + SEQToCOND l == + transform:= [[a,b] for x in l while (x is ["COND",[a,["EXIT",b]]])] + before:= take(#transform,l) + aft:= after(l,before) + null before => ["SEQ",:aft] + null aft => ["COND",:transform,'((QUOTE T) (conderr))] + true => ["COND",:transform,['(QUOTE T),optSEQ ["SEQ",:aft]]] + tryToRemoveSEQ l == + l is ["SEQ",[op,a]] and MEMQ(op,'(EXIT RETURN THROW)) => a + l + +optRECORDELT ["RECORDELT",name,ind,len] == + len=1 => + ind=0 => ["QCAR",name] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["QCAR",name] + ind=1 => ["QCDR",name] + keyedSystemError("S2OO0002",[ind]) + ["QVELT",name,ind] + +optSETRECORDELT ["SETRECORDELT",name,ind,len,expr] == + len=1 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + keyedSystemError("S2OO0002",[ind]) + len=2 => + ind=0 => ["PROGN",["RPLACA",name,expr],["QCAR",name]] + ind=1 => ["PROGN",["RPLACD",name,expr],["QCDR",name]] + keyedSystemError("S2OO0002",[ind]) + ["QSETVELT",name,ind,expr] + +optRECORDCOPY ["RECORDCOPY",name,len] == + len=1 => ["LIST",["CAR",name]] + len=2 => ["CONS",["CAR",name],["CDR",name]] + ["MOVEVEC",["MAKE_-VEC",len],name] + +--mkRecordAccessFunction(ind,len) == +-- stringOfDs:= $EmptyString +-- for i in 0..(ind-1) do stringOfDs:= STRCONC(stringOfDs,PNAME "D") +-- prefix:= if ind=len-1 then PNAME "C" else PNAME "CA" +-- if $QuickCode then prefix:=STRCONC("Q",prefix) +-- INTERN(STRCONC(prefix,stringOfDs,PNAME "R")) + +optSuchthat [.,:u] == ["SUCHTHAT",:u] + +optMINUS u == + u is ['MINUS,v] => + NUMBERP v => -v + u + u + +optQSMINUS u == + u is ['QSMINUS,v] => + NUMBERP v => -v + u + u + +opt_- u == + u is ['_-,v] => + NUMBERP v => -v + u + u + +optLESSP u == + u is ['LESSP,a,b] => + b = 0 => ['MINUSP,a] + ['GREATERP,b,a] + u + +optEQ u == + u is ['EQ,l,r] => + NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] + -- That undoes some weird work in Boolean to do with the definition of true + u + u + +EVALANDFILEACTQ + ( + for x in '( (call optCall) _ + (SEQ optSEQ)_ + (EQ optEQ) + (MINUS optMINUS)_ + (QSMINUS optQSMINUS)_ + (_- opt_-)_ + (LESSP optLESSP)_ + (SPADCALL optSPADCALL)_ + (_| optSuchthat)_ + (CATCH optCatch)_ + (COND optCond)_ + (mkRecord optMkRecord)_ + (RECORDELT optRECORDELT)_ + (SETRECORDELT optSETRECORDELT)_ + (RECORDCOPY optRECORDCOPY)) _ + repeat MAKEPROP(CAR x,'OPTIMIZE,CREATE_-SBC CADR x) + --much quicker to call functions if they have an SBC + ) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot deleted file mode 100644 index b922387a..00000000 --- a/src/interp/g-timer.boot +++ /dev/null @@ -1,270 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Code instrumentation facilities --- These functions can be used with arbitrary lists of --- named stats (listofnames) grouped in classes (listofclasses) --- and with measurement types (property, classproperty). - -printNamedStatsByProperty(listofnames, property) == - total := +/[GETL(name,property) for [name,:.] in listofnames] - for [name,:.] in listofnames repeat - n := GETL(name, property) - strname := STRINGIMAGE name - strval := STRINGIMAGE n - sayBrightly concat(bright strname, - fillerSpaces(70-#strname-#strval,'"."),bright strval) - sayBrightly bright fillerSpaces(72,'"-") - sayBrightly concat(bright '"Total", - fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) - -makeLongStatStringByProperty _ - (listofnames, listofclasses, property, classproperty, units, flag) == - total := 0 - str := '"" - otherStatTotal := GETL('other, property) - for [name,class,:ab] in listofnames repeat - name = 'other => 'iterate - cl := CAR LASSOC(class,listofclasses) - n := GETL( name, property) - PUT(cl,classproperty, n + GETL(cl,classproperty)) - total := total + n - if n >= 0.01 - then timestr := normalizeStatAndStringify n - else - timestr := '"" - otherStatTotal := otherStatTotal + n - str := makeStatString(str,timestr,ab,flag) - otherStatTotal := otherStatTotal - PUT('other, property, otherStatTotal) - if otherStatTotal > 0 then - str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) - total := total + otherStatTotal - cl := CAR LASSOC('other,listofnames) - cl := CAR LASSOC(cl,listofclasses) - PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) - if flag ^= 'long then - total := 0 - str := '"" - for [class,name,:ab] in listofclasses repeat - n := GETL(name, classproperty) - n = 0.0 => 'iterate - total := total + n - timestr := normalizeStatAndStringify n - str := makeStatString(str,timestr,ab,flag) - total := STRCONC(normalizeStatAndStringify total,'" ", units) - str = '"" => total - STRCONC(str, '" = ", total) - -normalizeStatAndStringify t == - RNUMP t => - t := roundStat t - t = 0.0 => '"0" - FORMAT(nil,'"~,2F",t) - INTP t => - K := 1024 - M := K*K - t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") - t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") - STRINGIMAGE t - STRINGIMAGE t - -significantStat t == - RNUMP t => (t > 0.01) - INTP t => (t > 100) - true - -roundStat t == - not RNUMP t => t - (FIX (0.5 + t * 1000.0)) / 1000.0 - -makeStatString(oldstr,time,abb,flag) == - time = '"" => oldstr - opening := (flag = 'long => '"("; '" (") - oldstr = '"" => STRCONC(time,opening,abb,'")") - STRCONC(oldstr,'" + ",time,opening,abb,'")") - -peekTimedName() == IFCAR $timedNameStack - -popTimedName() == - name := IFCAR $timedNameStack - $timedNameStack := IFCDR $timedNameStack - name - -pushTimedName name == - PUSH(name,$timedNameStack) - ---currentlyTimedName() == CAR $timedNameStack - -startTimingProcess name == - updateTimedName peekTimedName() - pushTimedName name - if EQ(name, 'load) then statRecordLoadEvent() - -stopTimingProcess name == - (name ^= peekTimedName()) and null $InteractiveMode => - keyedSystemError("S2GL0015",[name,peekTimedName()]) - updateTimedName peekTimedName() - popTimedName() - ---% Instrumentation specific to the interpreter -SETANDFILEQ($oldElapsedSpace, 0) -SETANDFILEQ($oldElapsedGCTime,0.0) -SETANDFILEQ($oldElapsedTime,0.0) -SETANDFILEQ($gcTimeTotal,0.0) - --- $timedNameStack is used to hold the names of sections of the --- code being timed. - -SETANDFILEQ($timedNameStack,'(other)) - -SETANDFILEQ($interpreterTimedNames,'( --- name class abbrev - (algebra 2 . B) _ - (analysis 1 . A) _ - (coercion 1 . C) _ - (compilation 3 . T) _ - (debug 3 . D) _ - (evaluation 2 . E) _ - (gc 4 . G) _ - (history 3 . H) _ - (instantiation 3 . I) _ - (load 3 . L) _ - (modemaps 1 . M) _ - (optimization 3 . Z) _ - (querycoerce 1 . Q) _ - (other 3 . O) _ - (diskread 3 . K) _ - (print 3 . P) _ - (resolve 1 . R) _ - )) - -SETANDFILEQ($interpreterTimedClasses, '( --- number class name short name - ( 1 interpreter . IN) _ - ( 2 evaluation . EV) _ - ( 3 other . OT) _ - ( 4 reclaim . GC) _ - )) - -initializeTimedNames(listofnames,listofclasses) == - for [name,:.] in listofnames repeat - PUT(name, 'TimeTotal, 0.0) - PUT(name, 'SpaceTotal, 0) - for [.,name,:.] in listofclasses repeat - PUT( name, 'ClassTimeTotal, 0.0) - PUT( name, 'ClassSpaceTotal, 0) - $timedNameStack := '(other) - computeElapsedTime() - PUT('gc, 'TimeTotal, 0.0) - PUT('gc, 'SpaceTotal, 0) - NIL - -updateTimedName name == - count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() - PUT(name,'TimeTotal, count) - -printNamedStats listofnames == - printNamedStatsByProperty(listofnames, 'TimeTotal) - sayBrightly '" " - sayBrightly '"Space (in bytes):" - printNamedStatsByProperty(listofnames, 'SpaceTotal) - -makeLongTimeString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'TimeTotal, 'ClassTimeTotal, _ - '"sec", $printTimeIfTrue) - -makeLongSpaceString(listofnames,listofclasses) == - makeLongStatStringByProperty(listofnames, listofclasses, _ - 'SpaceTotal, 'ClassSpaceTotal, _ - '"bytes", $printStorageIfTrue) - -computeElapsedTime() == - -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU - currentTime:= elapsedUserTime() - currentGCTime:= elapsedGcTime() - gcDelta := currentGCTime - $oldElapsedGCTime - elapsedSeconds:= - -- In CCL total time does not include GC time. - $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond - 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond - PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + - 1.*gcDelta/$timerTicksPerSecond) - $oldElapsedTime := elapsedUserTime() - $oldElapsedGCTime := elapsedGcTime() - elapsedSeconds - -computeElapsedSpace() == - currentElapsedSpace := HEAPELAPSED() - elapsedBytes := currentElapsedSpace - $oldElapsedSpace - $oldElapsedSpace := currentElapsedSpace - elapsedBytes - -timedAlgebraEvaluation(code) == - startTimingProcess 'algebra - r := eval code - stopTimingProcess 'algebra - r - -timedOptimization(code) == - startTimingProcess 'optimization - $getDomainCode : local := NIL - r := lispize code - if $reportOptimization then - sayBrightlyI bright '"Optimized LISP code:" - pp r - stopTimingProcess 'optimization - r - -timedEVALFUN(code) == - startTimingProcess 'evaluation - r := timedEvaluate code - stopTimingProcess 'evaluation - r - -timedEvaluate code == - code is ["LIST",:a] and #a > 200 => - "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] - eval code - -displayHeapStatsIfWanted() == - $printStorageIfTrue => sayBrightly OLDHEAPSTATS() - ---EVALANDFILEACTQ( --- PUTGCEXIT function displayHeapStatsIfWanted ) - ---% stubs for the stats summary fns -statRecordInstantiationEvent() == nil -statRecordLoadEvent() == nil - -statisticsSummary() == '"No statistics available." diff --git a/src/interp/g-timer.boot.pamphlet b/src/interp/g-timer.boot.pamphlet new file mode 100644 index 00000000..513e367d --- /dev/null +++ b/src/interp/g-timer.boot.pamphlet @@ -0,0 +1,292 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp g-timer.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Code instrumentation facilities +-- These functions can be used with arbitrary lists of +-- named stats (listofnames) grouped in classes (listofclasses) +-- and with measurement types (property, classproperty). + +printNamedStatsByProperty(listofnames, property) == + total := +/[GETL(name,property) for [name,:.] in listofnames] + for [name,:.] in listofnames repeat + n := GETL(name, property) + strname := STRINGIMAGE name + strval := STRINGIMAGE n + sayBrightly concat(bright strname, + fillerSpaces(70-#strname-#strval,'"."),bright strval) + sayBrightly bright fillerSpaces(72,'"-") + sayBrightly concat(bright '"Total", + fillerSpaces(65-# STRINGIMAGE total,'"."),bright STRINGIMAGE total) + +makeLongStatStringByProperty _ + (listofnames, listofclasses, property, classproperty, units, flag) == + total := 0 + str := '"" + otherStatTotal := GETL('other, property) + for [name,class,:ab] in listofnames repeat + name = 'other => 'iterate + cl := CAR LASSOC(class,listofclasses) + n := GETL( name, property) + PUT(cl,classproperty, n + GETL(cl,classproperty)) + total := total + n + if n >= 0.01 + then timestr := normalizeStatAndStringify n + else + timestr := '"" + otherStatTotal := otherStatTotal + n + str := makeStatString(str,timestr,ab,flag) + otherStatTotal := otherStatTotal + PUT('other, property, otherStatTotal) + if otherStatTotal > 0 then + str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) + total := total + otherStatTotal + cl := CAR LASSOC('other,listofnames) + cl := CAR LASSOC(cl,listofclasses) + PUT(cl,classproperty, otherStatTotal + GETL(cl,classproperty)) + if flag ^= 'long then + total := 0 + str := '"" + for [class,name,:ab] in listofclasses repeat + n := GETL(name, classproperty) + n = 0.0 => 'iterate + total := total + n + timestr := normalizeStatAndStringify n + str := makeStatString(str,timestr,ab,flag) + total := STRCONC(normalizeStatAndStringify total,'" ", units) + str = '"" => total + STRCONC(str, '" = ", total) + +normalizeStatAndStringify t == + RNUMP t => + t := roundStat t + t = 0.0 => '"0" + FORMAT(nil,'"~,2F",t) + INTP t => + K := 1024 + M := K*K + t > 9*M => CONCAT(STRINGIMAGE((t + 512*K)/M), '"M") + t > 9*K => CONCAT(STRINGIMAGE((t + 512)/K), '"K") + STRINGIMAGE t + STRINGIMAGE t + +significantStat t == + RNUMP t => (t > 0.01) + INTP t => (t > 100) + true + +roundStat t == + not RNUMP t => t + (FIX (0.5 + t * 1000.0)) / 1000.0 + +makeStatString(oldstr,time,abb,flag) == + time = '"" => oldstr + opening := (flag = 'long => '"("; '" (") + oldstr = '"" => STRCONC(time,opening,abb,'")") + STRCONC(oldstr,'" + ",time,opening,abb,'")") + +peekTimedName() == IFCAR $timedNameStack + +popTimedName() == + name := IFCAR $timedNameStack + $timedNameStack := IFCDR $timedNameStack + name + +pushTimedName name == + PUSH(name,$timedNameStack) + +--currentlyTimedName() == CAR $timedNameStack + +startTimingProcess name == + updateTimedName peekTimedName() + pushTimedName name + if EQ(name, 'load) then statRecordLoadEvent() + +stopTimingProcess name == + (name ^= peekTimedName()) and null $InteractiveMode => + keyedSystemError("S2GL0015",[name,peekTimedName()]) + updateTimedName peekTimedName() + popTimedName() + +--% Instrumentation specific to the interpreter +SETANDFILEQ($oldElapsedSpace, 0) +SETANDFILEQ($oldElapsedGCTime,0.0) +SETANDFILEQ($oldElapsedTime,0.0) +SETANDFILEQ($gcTimeTotal,0.0) + +-- $timedNameStack is used to hold the names of sections of the +-- code being timed. + +SETANDFILEQ($timedNameStack,'(other)) + +SETANDFILEQ($interpreterTimedNames,'( +-- name class abbrev + (algebra 2 . B) _ + (analysis 1 . A) _ + (coercion 1 . C) _ + (compilation 3 . T) _ + (debug 3 . D) _ + (evaluation 2 . E) _ + (gc 4 . G) _ + (history 3 . H) _ + (instantiation 3 . I) _ + (load 3 . L) _ + (modemaps 1 . M) _ + (optimization 3 . Z) _ + (querycoerce 1 . Q) _ + (other 3 . O) _ + (diskread 3 . K) _ + (print 3 . P) _ + (resolve 1 . R) _ + )) + +SETANDFILEQ($interpreterTimedClasses, '( +-- number class name short name + ( 1 interpreter . IN) _ + ( 2 evaluation . EV) _ + ( 3 other . OT) _ + ( 4 reclaim . GC) _ + )) + +initializeTimedNames(listofnames,listofclasses) == + for [name,:.] in listofnames repeat + PUT(name, 'TimeTotal, 0.0) + PUT(name, 'SpaceTotal, 0) + for [.,name,:.] in listofclasses repeat + PUT( name, 'ClassTimeTotal, 0.0) + PUT( name, 'ClassSpaceTotal, 0) + $timedNameStack := '(other) + computeElapsedTime() + PUT('gc, 'TimeTotal, 0.0) + PUT('gc, 'SpaceTotal, 0) + NIL + +updateTimedName name == + count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() + PUT(name,'TimeTotal, count) + +printNamedStats listofnames == + printNamedStatsByProperty(listofnames, 'TimeTotal) + sayBrightly '" " + sayBrightly '"Space (in bytes):" + printNamedStatsByProperty(listofnames, 'SpaceTotal) + +makeLongTimeString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'TimeTotal, 'ClassTimeTotal, _ + '"sec", $printTimeIfTrue) + +makeLongSpaceString(listofnames,listofclasses) == + makeLongStatStringByProperty(listofnames, listofclasses, _ + 'SpaceTotal, 'ClassSpaceTotal, _ + '"bytes", $printStorageIfTrue) + +computeElapsedTime() == + -- in total time lists, CAR is VIRTCPU and CADR is TOTCPU + currentTime:= elapsedUserTime() + currentGCTime:= elapsedGcTime() + gcDelta := currentGCTime - $oldElapsedGCTime + elapsedSeconds:= + -- In CCL total time does not include GC time. + $cclSystem => 1.*(currentTime-$oldElapsedTime)/$timerTicksPerSecond + 1.*(currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond + PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + + 1.*gcDelta/$timerTicksPerSecond) + $oldElapsedTime := elapsedUserTime() + $oldElapsedGCTime := elapsedGcTime() + elapsedSeconds + +computeElapsedSpace() == + currentElapsedSpace := HEAPELAPSED() + elapsedBytes := currentElapsedSpace - $oldElapsedSpace + $oldElapsedSpace := currentElapsedSpace + elapsedBytes + +timedAlgebraEvaluation(code) == + startTimingProcess 'algebra + r := eval code + stopTimingProcess 'algebra + r + +timedOptimization(code) == + startTimingProcess 'optimization + $getDomainCode : local := NIL + r := lispize code + if $reportOptimization then + sayBrightlyI bright '"Optimized LISP code:" + pp r + stopTimingProcess 'optimization + r + +timedEVALFUN(code) == + startTimingProcess 'evaluation + r := timedEvaluate code + stopTimingProcess 'evaluation + r + +timedEvaluate code == + code is ["LIST",:a] and #a > 200 => + "append"/[eval ["LIST",:x] for x in splitIntoBlocksOf200 a] + eval code + +displayHeapStatsIfWanted() == + $printStorageIfTrue => sayBrightly OLDHEAPSTATS() + +--EVALANDFILEACTQ( +-- PUTGCEXIT function displayHeapStatsIfWanted ) + +--% stubs for the stats summary fns +statRecordInstantiationEvent() == nil +statRecordLoadEvent() == nil + +statisticsSummary() == '"No statistics available." +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot deleted file mode 100644 index 30c5ccd4..00000000 --- a/src/interp/g-util.boot +++ /dev/null @@ -1,635 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - ---% Utility Functions of General Use - -ELEMN(x, n, d) == - null x => d - n = 1 => car x - ELEMN(cdr x, SUB1 n, d) - -PPtoFile(x, fname) == - stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) - PRETTYPRINT(x, stream) - SHUT stream - x - --- Convert an arbitrary lisp object to canonical boolean. -bool x == - NULL NULL x - ---% Various lispy things - -Identity x == x - -length1? l == PAIRP l and not PAIRP QCDR l - -length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l - -pairList(u,v) == [[x,:y] for x in u for y in v] - --- GETALIST(alist,prop) == IFCDR assoc(prop,alist) -GETALIST(alist,prop) == CDR assoc(prop,alist) - -PUTALIST(alist,prop,val) == - null alist => [[prop,:val]] - pair := assoc(prop,alist) => - CDR pair = val => alist - -- else we fall over Lucid's read-only storage feature again - QRPLACD(pair,val) - alist - QRPLACD(LASTPAIR alist,[[prop,:val]]) - alist - -REMALIST(alist,prop) == - null alist => alist - alist is [[ =prop,:.],:r] => - null r => NIL - QRPLACA(alist,CAR r) - QRPLACD(alist,CDR r) - alist - null rest alist => alist - l := alist - ok := true - while ok repeat - [.,[p,:.],:r] := l - p = prop => - ok := NIL - QRPLACD(l,r) - if null (l := QCDR l) or null rest l then ok := NIL - alist - -deleteLassoc(x,y) == - y is [[a,:.],:y'] => - EQ(x,a) => y' - [first y,:deleteLassoc(x,y')] - y - ---% association list functions - -deleteAssoc(x,y) == - y is [[a,:.],:y'] => - a=x => deleteAssoc(x,y') - [first y,:deleteAssoc(x,y')] - y - -deleteAssocWOC(x,y) == - null y => y - [[a,:.],:t]:= y - x=a => t - (fn(x,y);y) where fn(x,y is [h,:t]) == - t is [[a,:.],:t1] => - x=a => RPLACD(y,t1) - fn(x,t) - nil - -insertWOC(x,y) == - null y => [x] - (fn(x,y); y) where fn(x,y is [h,:t]) == - x=h => nil - null t => - RPLACD(y,[h,:t]) - RPLACA(y,x) - fn(x,t) - - - ---% Miscellaneous Functions for Working with Strings - -fillerSpaces(n,:charPart) == - n <= 0 => '"" - MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") - -centerString(text,width,fillchar) == - wid := entryWidth text - wid >= width => text - f := DIVIDE(width - wid,2) - fill1 := "" - for i in 1..(f.0) repeat - fill1 := STRCONC(fillchar,fill1) - fill2:= fill1 - if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) - [fill1,text,fill2] - -stringPrefix?(pref,str) == - -- sees if the first #pref letters of str are pref - -- replaces STRINGPREFIXP - null (STRINGP(pref) and STRINGP(str)) => NIL - (lp := QCSIZE pref) = 0 => true - lp > QCSIZE str => NIL - ok := true - i := 0 - while ok and (i < lp) repeat - not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL - i := i + 1 - ok - -stringChar2Integer(str,pos) == - -- replaces GETSTRINGDIGIT in UT LISP - -- returns small integer represented by character in position pos - -- in string str. Returns NIL if not a digit or other error. - if IDENTP str then str := PNAME str - null (STRINGP(str) and - INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL - not DIGITP(d := SCHAR(str,pos)) => NIL - DIG2FIX d - -dropLeadingBlanks str == - str := object2String str - l := QCSIZE str - nb := NIL - i := 0 - while (i < l) and not nb repeat - if SCHAR(str,i) ^= " " then nb := i - else i := i + 1 - nb = 0 => str - nb => SUBSTRING(str,nb,NIL) - '"" - -concat(:l) == concatList l - -concatList [x,:y] == - null y => x - null x => concatList y - concat1(x,concatList y) - -concat1(x,y) == - null x => y - atom x => (null y => x; atom y => [x,y]; [x,:y]) - null y => x - atom y => [:x,y] - [:x,:y] - ---% BOOT ravel and reshape - -ravel a == a - -reshape(a,b) == a - ---% Some functions for algebra code - -boolODDP x == ODDP x - ---% Miscellaneous - -freeOfSharpVars x == - atom x => not isSharpVarWithNum x - freeOfSharpVars first x and freeOfSharpVars rest x - -listOfSharpVars x == - atom x => (isSharpVarWithNum x => LIST x; nil) - setUnion(listOfSharpVars first x,listOfSharpVars rest x) - -listOfPatternIds x == - isPatternVar x => [x] - atom x => nil - x is ['QUOTE,:.] => nil - UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) - -isPatternVar v == - -- a pattern variable consists of a star followed by a star or digit(s) - IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 - _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true - -removeZeroOne x == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 - x = $Zero => 0 - x = $One => 1 - atom x => x - [removeZeroOne first x,:removeZeroOne rest x] - -removeZeroOneDestructively t == - -- replace all occurrences of (Zero) and (One) with - -- 0 and 1 destructively - t = $Zero => 0 - t = $One => 1 - atom t => t - RPLNODE(t,removeZeroOneDestructively first t, - removeZeroOneDestructively rest t) - -flattenSexpr s == - null s => s - ATOM s => s - [f,:r] := s - ATOM f => [f,:flattenSexpr r] - [:flattenSexpr f,:flattenSexpr r] - -isLowerCaseLetter c == charRangeTest CHAR2NUM c - -isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -isLetter c == - n:= CHAR2NUM c - charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) - -charRangeTest n == - QSLESSP(153,n) => - QSLESSP(169,n) => false - QSLESSP(161,n) => true - false - QSLESSP(128,n) => - QSLESSP(144,n) => true - QSLESSP(138,n) => false - true - false - -update() == - OBEY - STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") - _/UPDATE() - ---% Inplace Merge Sort for Lists --- MBM April/88 - --- listSort(pred,list) or listSort(pred,list,key) --- the pred function is a boolean valued function defining the ordering --- the key function extracts the key from an item for comparison by pred - -listSort(pred,list,:optional) == - NOT functionp pred => error "listSort: first arg must be a function" - NOT LISTP list => error "listSort: second argument must be a list" - NULL optional => mergeSort(pred,function Identity,list,LENGTH list) - key := CAR optional - NOT functionp key => error "listSort: last arg must be a function" - mergeSort(pred,key,list,LENGTH list) - --- non-destructive merge sort using NOT GGREATERP as predicate -MSORT list == listSort(function GLESSEQP, COPY_-LIST list) - --- destructive merge sort using NOT GGREATERP as predicate -NMSORT list == listSort(function GLESSEQP, list) - --- non-destructive merge sort using ?ORDER as predicate -orderList l == listSort(function _?ORDER, COPY_-LIST l) - --- dummy defn until clean-up --- order l == orderList l - -mergeInPlace(f,g,p,q) == - -- merge the two sorted lists p and q - if NULL p then return p - if NULL q then return q - if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) - then (r := t := p; p := QCDR p) - else (r := t := q; q := QCDR q) - while not NULL p and not NULL q repeat - if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) - then (QRPLACD(t,p); t := p; p := QCDR p) - else (QRPLACD(t,q); t := q; q := QCDR q) - if NULL p then QRPLACD(t,q) else QRPLACD(t,p) - r - -mergeSort(f,g,p,n) == - if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then - t := p - p := QCDR p - QRPLACD(p,t) - QRPLACD(t,NIL) - if QSLESSP(n,3) then return p - -- split the list p into p and q of equal length - l := QSQUOTIENT(n,2) - t := p - for i in 1..l-1 repeat t := QCDR t - q := rest t - QRPLACD(t,NIL) - p := mergeSort(f,g,p,l) - q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) - mergeInPlace(f,g,p,q) - ---% Throwing with glorious highlighting (maybe) - -spadThrow() == - if $interpOnly and $mapName then - putHist($mapName,'localModemap, nil, $e) - THROW("SPAD__READER",nil) - -spadThrowBrightly x == - sayBrightly x - spadThrow() - ---% Type Formatting Without Abbreviation - -formatUnabbreviatedSig sig == - null sig => ["() -> ()"] - [target,:args] := sig - target := formatUnabbreviated target - null args => ['"() -> ",:target] - null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] - args := formatUnabbreviatedTuple args - ['"(",:args,'") -> ",:target] - -formatUnabbreviatedTuple t == - -- t is a list of types - null t => t - atom t => [t] - t0 := formatUnabbreviated QCAR t - null rest t => t0 - [:t0,'",",:formatUnabbreviatedTuple QCDR t] - -formatUnabbreviated t == - atom t => - [t] - null t => - ['"()"] - t is [p,sel,arg] and p in '(_: ":") => - [sel,'": ",:formatUnabbreviated arg] - t is ['Union,:args] => - ['Union,'"(",:formatUnabbreviatedTuple args,'")"] - t is ['Mapping,:args] => - formatUnabbreviatedSig args - t is ['Record,:args] => - ['Record,'"(",:formatUnabbreviatedTuple args,'")"] - t is [arg] => - t - t is [arg,arg1] => - [arg,'" ",:formatUnabbreviated arg1] - t is [arg,:args] => - [arg,'"(",:formatUnabbreviatedTuple args,'")"] - t - -sublisNQ(al,e) == - atom al => e - fn(al,e) where fn(al,e) == - atom e => - for x in al repeat - EQ(first x,e) => return (e := rest x) - e - EQ(a := first e,'QUOTE) => e - u := fn(al,a) - v := fn(al,rest e) - EQ(a,u) and EQ(rest e,v) => e - [u,:v] - --- function for turning strings in tex format - -str2Outform s == - parse := ncParseFromString s or systemError '"String for TeX will not parse" - parse2Outform parse - -parse2Outform x == - x is [op,:argl] => - nargl := [parse2Outform y for y in argl] - op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] - op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] - [op,:nargl] - x - -str2Tex s == - outf := str2Outform s - val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) - val := objValUnwrap val - CAR val.1 - -opOf x == - atom x => x - first x - -getProplist(x,E) == - not atom x => getProplist(first x,E) - u:= search(x,E) => u - --$InteractiveMode => nil - --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u - (pl:=search(x,$CategoryFrame)) => - pl --- (pl:=PROPLIST x) => pl --- Above line commented out JHD/BMT 2.Aug.90 - -search(x,e is [curEnv,:tailEnv]) == - searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) - -searchCurrentEnv(x,currentEnv) == - for contour in currentEnv repeat - if u:= ASSQ(x,contour) then return (signal:= u) - KDR signal - -searchTailEnv(x,e) == - for env in e repeat - signal:= - for contour in env repeat - if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) - if signal then return signal - KDR signal - -augProplist(proplist,prop,val) == - $InteractiveMode => augProplistInteractive(proplist,prop,val) - while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' - val=(u:= LASSOC(prop,proplist)) => proplist - null val => - null u => proplist - DELLASOS(prop,proplist) - [[prop,:val],:proplist] - -augProplistOf(var,prop,val,e) == - proplist:= getProplist(var,e) - semchkProplist(var,proplist,prop,val) - augProplist(proplist,prop,val) - -semchkProplist(x,proplist,prop,val) == - prop="isLiteral" => - LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x - MEMQ(prop,'(mode value)) => - LASSOC("isLiteral",proplist) => warnLiteral x - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == - EQ(proplist,getProplist(var,e)) => e - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - -position(x,l) == - posn(x,l,0) where - posn(x,l,n) == - null l => -1 - x=first l => n - posn(x,rest l,n+1) - -insert(x,y) == - member(x,y) => y - [x,:y] - -after(u,v) == - r:= u - for x in u for y in v repeat r:= rest r - r - - -$blank := char ('_ ) - -trimString s == - leftTrim rightTrim s - -leftTrim s == - k := MAXINDEX s - k < 0 => s - s.0 = $blank => - for i in 0..k while s.i = $blank repeat (j := i) - SUBSTRING(s,j + 1,nil) - s - -rightTrim s == -- assumed a non-empty string - k := MAXINDEX s - k < 0 => s - s.k = $blank => - for i in k..0 by -1 while s.i = $blank repeat (j := i) - SUBSTRING(s,0,j) - s - -pp x == - PRETTYPRINT x - x - -pr x == - F_,PRINT_-ONE x - nil - -quickAnd(a,b) == - a = true => b - b = true => a - a = false or b = false => false - simpBool ['AND,a,b] - -quickOr(a,b) == - a = true or b = true => true - b = false => a - a = false => b - simpCatPredicate simpBool ['OR,a,b] - -intern x == - STRINGP x => - DIGITP x.0 => string2Integer x - INTERN x - x - ---------------------> NEW DEFINITION (override in interop.boot.pamphlet) -isDomain a == - REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain - --- variables used by browser - -$htHash := MAKE_-HASH_-TABLE() -$glossHash := MAKE_-HASH_-TABLE() -$lispHash := MAKE_-HASH_-TABLE() -$sysHash := MAKE_-HASH_-TABLE() -$htSystemCommands := '( - (boot . development) clear display (fin . development) edit help - frame history load quit read set show synonym system - trace what ) -$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root -$outStream := nil -$recheckingFlag := false --see transformAndRecheckComments -$exposeFlag := false --if true, messages go to $outStream -$exposeFlagHeading := false --see htcheck.boot -$checkingXmptex? := false --see htcheck.boot -$exposeDocHeading:= nil --see htcheck.boot -$charPlus := char '_+ -$charBlank:= (char '_ ) -$charLbrace:= char '_{ -$charRbrace:= char '_} -$charBack := char '_\ -$charDash := char '_- - -$charTab := CODE_-CHAR(9) -$charNewline := CODE_-CHAR(10) -$charFauxNewline := CODE_-CHAR(25) -$stringNewline := PNAME CODE_-CHAR(10) -$stringFauxNewline := PNAME CODE_-CHAR(25) - -$charExclusions := [char 'a, char 'A] -$charQuote := char '_' -$charSemiColon := char '_; -$charComma := char '_, -$charPeriod := char '_. -$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] -$charEscapeList:= [char '_%,char '_#,$charBack] -$charIdentifierEndings := [char '__, char '_!, char '_?] -$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] -$charDelimiters := [$charBlank, char '_(, char '_), $charBack] -$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") -$HTmacs := [ - ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], - ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], - ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], - ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], - ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], - ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] - -$HTlinks := '( - "\downlink" - "\menulink" - "\menudownlink" - "\menuwindowlink" - "\menumemolink") - -$HTlisplinks := '( - "\lispdownlink" - "\menulispdownlink" - "\menulispwindowlink" - "\menulispmemolink" - "\lispwindowlink" - "\lispmemolink") - -$beginEndList := '( - "page" - "items" - "menu" - "scroll" - "verbatim" - "detail") - -isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& - - --- gensym utils - -charDigitVal c == - digits := '"0123456789" - n := -1 - for i in 0..#digits-1 while n < 0 repeat - if c = digits.i then n := i - n < 0 => error '"Character is not a digit" - n - -gensymInt g == - not GENSYMP g => error '"Need a GENSYM" - p := PNAME g - n := 0 - for i in 2..#p-1 repeat n := 10 * n + charDigitVal p.i - n - - - --- Push into the BOOT package when invoked in batch mode. -AxiomCore::$sysScope := '"BOOT" diff --git a/src/interp/g-util.boot.pamphlet b/src/interp/g-util.boot.pamphlet new file mode 100644 index 00000000..05e262c8 --- /dev/null +++ b/src/interp/g-util.boot.pamphlet @@ -0,0 +1,663 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/g-util.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} + +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +--% Utility Functions of General Use + +ELEMN(x, n, d) == + null x => d + n = 1 => car x + ELEMN(cdr x, SUB1 n, d) + +PPtoFile(x, fname) == + stream := DEFIOSTREAM([['MODE, :'OUTPUT], ['FILE, :fname]], 80, 0) + PRETTYPRINT(x, stream) + SHUT stream + x + +-- Convert an arbitrary lisp object to canonical boolean. +bool x == + NULL NULL x + +--% Various lispy things + +Identity x == x + +length1? l == PAIRP l and not PAIRP QCDR l + +length2? l == PAIRP l and PAIRP (l := QCDR l) and not PAIRP QCDR l + +pairList(u,v) == [[x,:y] for x in u for y in v] + +-- GETALIST(alist,prop) == IFCDR assoc(prop,alist) +GETALIST(alist,prop) == CDR assoc(prop,alist) + +PUTALIST(alist,prop,val) == + null alist => [[prop,:val]] + pair := assoc(prop,alist) => + CDR pair = val => alist + -- else we fall over Lucid's read-only storage feature again + QRPLACD(pair,val) + alist + QRPLACD(LASTPAIR alist,[[prop,:val]]) + alist + +REMALIST(alist,prop) == + null alist => alist + alist is [[ =prop,:.],:r] => + null r => NIL + QRPLACA(alist,CAR r) + QRPLACD(alist,CDR r) + alist + null rest alist => alist + l := alist + ok := true + while ok repeat + [.,[p,:.],:r] := l + p = prop => + ok := NIL + QRPLACD(l,r) + if null (l := QCDR l) or null rest l then ok := NIL + alist + +deleteLassoc(x,y) == + y is [[a,:.],:y'] => + EQ(x,a) => y' + [first y,:deleteLassoc(x,y')] + y + +--% association list functions + +deleteAssoc(x,y) == + y is [[a,:.],:y'] => + a=x => deleteAssoc(x,y') + [first y,:deleteAssoc(x,y')] + y + +deleteAssocWOC(x,y) == + null y => y + [[a,:.],:t]:= y + x=a => t + (fn(x,y);y) where fn(x,y is [h,:t]) == + t is [[a,:.],:t1] => + x=a => RPLACD(y,t1) + fn(x,t) + nil + +insertWOC(x,y) == + null y => [x] + (fn(x,y); y) where fn(x,y is [h,:t]) == + x=h => nil + null t => + RPLACD(y,[h,:t]) + RPLACA(y,x) + fn(x,t) + + + +--% Miscellaneous Functions for Working with Strings + +fillerSpaces(n,:charPart) == + n <= 0 => '"" + MAKE_-FULL_-CVEC(n,IFCAR charPart or '" ") + +centerString(text,width,fillchar) == + wid := entryWidth text + wid >= width => text + f := DIVIDE(width - wid,2) + fill1 := "" + for i in 1..(f.0) repeat + fill1 := STRCONC(fillchar,fill1) + fill2:= fill1 + if f.1 ^= 0 then fill1 := STRCONC(fillchar,fill1) + [fill1,text,fill2] + +stringPrefix?(pref,str) == + -- sees if the first #pref letters of str are pref + -- replaces STRINGPREFIXP + null (STRINGP(pref) and STRINGP(str)) => NIL + (lp := QCSIZE pref) = 0 => true + lp > QCSIZE str => NIL + ok := true + i := 0 + while ok and (i < lp) repeat + not EQ(SCHAR(pref,i),SCHAR(str,i)) => ok := NIL + i := i + 1 + ok + +stringChar2Integer(str,pos) == + -- replaces GETSTRINGDIGIT in UT LISP + -- returns small integer represented by character in position pos + -- in string str. Returns NIL if not a digit or other error. + if IDENTP str then str := PNAME str + null (STRINGP(str) and + INTEGERP(pos) and (pos >= 0) and (pos < QCSIZE(str))) => NIL + not DIGITP(d := SCHAR(str,pos)) => NIL + DIG2FIX d + +dropLeadingBlanks str == + str := object2String str + l := QCSIZE str + nb := NIL + i := 0 + while (i < l) and not nb repeat + if SCHAR(str,i) ^= " " then nb := i + else i := i + 1 + nb = 0 => str + nb => SUBSTRING(str,nb,NIL) + '"" + +concat(:l) == concatList l + +concatList [x,:y] == + null y => x + null x => concatList y + concat1(x,concatList y) + +concat1(x,y) == + null x => y + atom x => (null y => x; atom y => [x,y]; [x,:y]) + null y => x + atom y => [:x,y] + [:x,:y] + +--% BOOT ravel and reshape + +ravel a == a + +reshape(a,b) == a + +--% Some functions for algebra code + +boolODDP x == ODDP x + +--% Miscellaneous + +freeOfSharpVars x == + atom x => not isSharpVarWithNum x + freeOfSharpVars first x and freeOfSharpVars rest x + +listOfSharpVars x == + atom x => (isSharpVarWithNum x => LIST x; nil) + setUnion(listOfSharpVars first x,listOfSharpVars rest x) + +listOfPatternIds x == + isPatternVar x => [x] + atom x => nil + x is ['QUOTE,:.] => nil + UNIONQ(listOfPatternIds first x,listOfPatternIds rest x) + +isPatternVar v == + -- a pattern variable consists of a star followed by a star or digit(s) + IDENTP(v) and MEMQ(v,'(_*_* _*1 _*2 _*3 _*4 _*5 _*6 _*7 _*8 _*9 _*10 + _*11 _*12 _*13 _*14 _*15 _*16 _*17 _*18 _*19 _*20)) and true + +removeZeroOne x == + -- replace all occurrences of (Zero) and (One) with + -- 0 and 1 + x = $Zero => 0 + x = $One => 1 + atom x => x + [removeZeroOne first x,:removeZeroOne rest x] + +removeZeroOneDestructively t == + -- replace all occurrences of (Zero) and (One) with + -- 0 and 1 destructively + t = $Zero => 0 + t = $One => 1 + atom t => t + RPLNODE(t,removeZeroOneDestructively first t, + removeZeroOneDestructively rest t) + +flattenSexpr s == + null s => s + ATOM s => s + [f,:r] := s + ATOM f => [f,:flattenSexpr r] + [:flattenSexpr f,:flattenSexpr r] + +isLowerCaseLetter c == charRangeTest CHAR2NUM c + +isUpperCaseLetter c == charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +isLetter c == + n:= CHAR2NUM c + charRangeTest n or charRangeTest QSDIFFERENCE(CHAR2NUM c,64) + +charRangeTest n == + QSLESSP(153,n) => + QSLESSP(169,n) => false + QSLESSP(161,n) => true + false + QSLESSP(128,n) => + QSLESSP(144,n) => true + QSLESSP(138,n) => false + true + false + +update() == + OBEY + STRCONC('"SPADEDIT ",STRINGIMAGE _/VERSION,'" ",STRINGIMAGE _/WSNAME,'" A") + _/UPDATE() + +--% Inplace Merge Sort for Lists +-- MBM April/88 + +-- listSort(pred,list) or listSort(pred,list,key) +-- the pred function is a boolean valued function defining the ordering +-- the key function extracts the key from an item for comparison by pred + +listSort(pred,list,:optional) == + NOT functionp pred => error "listSort: first arg must be a function" + NOT LISTP list => error "listSort: second argument must be a list" + NULL optional => mergeSort(pred,function Identity,list,LENGTH list) + key := CAR optional + NOT functionp key => error "listSort: last arg must be a function" + mergeSort(pred,key,list,LENGTH list) + +-- non-destructive merge sort using NOT GGREATERP as predicate +MSORT list == listSort(function GLESSEQP, COPY_-LIST list) + +-- destructive merge sort using NOT GGREATERP as predicate +NMSORT list == listSort(function GLESSEQP, list) + +-- non-destructive merge sort using ?ORDER as predicate +orderList l == listSort(function _?ORDER, COPY_-LIST l) + +-- dummy defn until clean-up +-- order l == orderList l + +mergeInPlace(f,g,p,q) == + -- merge the two sorted lists p and q + if NULL p then return p + if NULL q then return q + if FUNCALL(f,FUNCALL(g, QCAR p),FUNCALL(g, QCAR q)) + then (r := t := p; p := QCDR p) + else (r := t := q; q := QCDR q) + while not NULL p and not NULL q repeat + if FUNCALL(f,FUNCALL(g,QCAR p),FUNCALL(g,QCAR q)) + then (QRPLACD(t,p); t := p; p := QCDR p) + else (QRPLACD(t,q); t := q; q := QCDR q) + if NULL p then QRPLACD(t,q) else QRPLACD(t,p) + r + +mergeSort(f,g,p,n) == + if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then + t := p + p := QCDR p + QRPLACD(p,t) + QRPLACD(t,NIL) + if QSLESSP(n,3) then return p + -- split the list p into p and q of equal length + l := QSQUOTIENT(n,2) + t := p + for i in 1..l-1 repeat t := QCDR t + q := rest t + QRPLACD(t,NIL) + p := mergeSort(f,g,p,l) + q := mergeSort(f,g,q,QSDIFFERENCE(n,l)) + mergeInPlace(f,g,p,q) + +--% Throwing with glorious highlighting (maybe) + +spadThrow() == + if $interpOnly and $mapName then + putHist($mapName,'localModemap, nil, $e) + THROW("SPAD__READER",nil) + +spadThrowBrightly x == + sayBrightly x + spadThrow() + +--% Type Formatting Without Abbreviation + +formatUnabbreviatedSig sig == + null sig => ["() -> ()"] + [target,:args] := sig + target := formatUnabbreviated target + null args => ['"() -> ",:target] + null rest args => [:formatUnabbreviated QCAR args,'" -> ",:target] + args := formatUnabbreviatedTuple args + ['"(",:args,'") -> ",:target] + +formatUnabbreviatedTuple t == + -- t is a list of types + null t => t + atom t => [t] + t0 := formatUnabbreviated QCAR t + null rest t => t0 + [:t0,'",",:formatUnabbreviatedTuple QCDR t] + +formatUnabbreviated t == + atom t => + [t] + null t => + ['"()"] + t is [p,sel,arg] and p in '(_: ":") => + [sel,'": ",:formatUnabbreviated arg] + t is ['Union,:args] => + ['Union,'"(",:formatUnabbreviatedTuple args,'")"] + t is ['Mapping,:args] => + formatUnabbreviatedSig args + t is ['Record,:args] => + ['Record,'"(",:formatUnabbreviatedTuple args,'")"] + t is [arg] => + t + t is [arg,arg1] => + [arg,'" ",:formatUnabbreviated arg1] + t is [arg,:args] => + [arg,'"(",:formatUnabbreviatedTuple args,'")"] + t + +sublisNQ(al,e) == + atom al => e + fn(al,e) where fn(al,e) == + atom e => + for x in al repeat + EQ(first x,e) => return (e := rest x) + e + EQ(a := first e,'QUOTE) => e + u := fn(al,a) + v := fn(al,rest e) + EQ(a,u) and EQ(rest e,v) => e + [u,:v] + +-- function for turning strings in tex format + +str2Outform s == + parse := ncParseFromString s or systemError '"String for TeX will not parse" + parse2Outform parse + +parse2Outform x == + x is [op,:argl] => + nargl := [parse2Outform y for y in argl] + op = 'construct => ['BRACKET,['ARGLST,:[parse2Outform y for y in argl]]] + op = 'brace and nargl is [[BRACKET,:r]] => ['BRACE,:r] + [op,:nargl] + x + +str2Tex s == + outf := str2Outform s + val := coerceInt(mkObj(wrap outf, '(OutputForm)), '(TexFormat)) + val := objValUnwrap val + CAR val.1 + +opOf x == + atom x => x + first x + +getProplist(x,E) == + not atom x => getProplist(first x,E) + u:= search(x,E) => u + --$InteractiveMode => nil + --$InteractiveMode and (u:= search(x,$InteractiveFrame)) => u + (pl:=search(x,$CategoryFrame)) => + pl +-- (pl:=PROPLIST x) => pl +-- Above line commented out JHD/BMT 2.Aug.90 + +search(x,e is [curEnv,:tailEnv]) == + searchCurrentEnv(x,curEnv) or searchTailEnv(x,tailEnv) + +searchCurrentEnv(x,currentEnv) == + for contour in currentEnv repeat + if u:= ASSQ(x,contour) then return (signal:= u) + KDR signal + +searchTailEnv(x,e) == + for env in e repeat + signal:= + for contour in env repeat + if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u) + if signal then return signal + KDR signal + +augProplist(proplist,prop,val) == + $InteractiveMode => augProplistInteractive(proplist,prop,val) + while (proplist is [[ =prop,:.],:proplist']) repeat proplist:= proplist' + val=(u:= LASSOC(prop,proplist)) => proplist + null val => + null u => proplist + DELLASOS(prop,proplist) + [[prop,:val],:proplist] + +augProplistOf(var,prop,val,e) == + proplist:= getProplist(var,e) + semchkProplist(var,proplist,prop,val) + augProplist(proplist,prop,val) + +semchkProplist(x,proplist,prop,val) == + prop="isLiteral" => + LASSOC("value",proplist) or LASSOC("mode",proplist) => warnLiteral x + MEMQ(prop,'(mode value)) => + LASSOC("isLiteral",proplist) => warnLiteral x + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == + EQ(proplist,getProplist(var,e)) => e + $InteractiveMode => addBindingInteractive(var,proplist,e) + if curContour is [[ =var,:.],:.] then curContour:= rest curContour + --Previous line should save some space + [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] + +position(x,l) == + posn(x,l,0) where + posn(x,l,n) == + null l => -1 + x=first l => n + posn(x,rest l,n+1) + +insert(x,y) == + member(x,y) => y + [x,:y] + +after(u,v) == + r:= u + for x in u for y in v repeat r:= rest r + r + + +$blank := char ('_ ) + +trimString s == + leftTrim rightTrim s + +leftTrim s == + k := MAXINDEX s + k < 0 => s + s.0 = $blank => + for i in 0..k while s.i = $blank repeat (j := i) + SUBSTRING(s,j + 1,nil) + s + +rightTrim s == -- assumed a non-empty string + k := MAXINDEX s + k < 0 => s + s.k = $blank => + for i in k..0 by -1 while s.i = $blank repeat (j := i) + SUBSTRING(s,0,j) + s + +pp x == + PRETTYPRINT x + x + +pr x == + F_,PRINT_-ONE x + nil + +quickAnd(a,b) == + a = true => b + b = true => a + a = false or b = false => false + simpBool ['AND,a,b] + +quickOr(a,b) == + a = true or b = true => true + b = false => a + a = false => b + simpCatPredicate simpBool ['OR,a,b] + +intern x == + STRINGP x => + DIGITP x.0 => string2Integer x + INTERN x + x + +--------------------> NEW DEFINITION (override in interop.boot.pamphlet) +isDomain a == + REFVECP a and #a>5 and GETDATABASE(a.0,'CONSTRUCTORKIND) = 'domain + +-- variables used by browser + +$htHash := MAKE_-HASH_-TABLE() +$glossHash := MAKE_-HASH_-TABLE() +$lispHash := MAKE_-HASH_-TABLE() +$sysHash := MAKE_-HASH_-TABLE() +$htSystemCommands := '( + (boot . development) clear display (fin . development) edit help + frame history load quit read set show synonym system + trace what ) +$currentSysList := [opOf x for x in $htSystemCommands] --see ht-root +$outStream := nil +$recheckingFlag := false --see transformAndRecheckComments +$exposeFlag := false --if true, messages go to $outStream +$exposeFlagHeading := false --see htcheck.boot +$checkingXmptex? := false --see htcheck.boot +$exposeDocHeading:= nil --see htcheck.boot +$charPlus := char '_+ +$charBlank:= (char '_ ) +$charLbrace:= char '_{ +$charRbrace:= char '_} +$charBack := char '_\ +$charDash := char '_- + +$charTab := CODE_-CHAR(9) +$charNewline := CODE_-CHAR(10) +$charFauxNewline := CODE_-CHAR(25) +$stringNewline := PNAME CODE_-CHAR(10) +$stringFauxNewline := PNAME CODE_-CHAR(25) + +$charExclusions := [char 'a, char 'A] +$charQuote := char '_' +$charSemiColon := char '_; +$charComma := char '_, +$charPeriod := char '_. +$checkPrenAlist := [[char '_(,:char '_)],[char '_{,:char '_}],[char '_[,:char '_]]] +$charEscapeList:= [char '_%,char '_#,$charBack] +$charIdentifierEndings := [char '__, char '_!, char '_?] +$charSplitList := [$charComma,$charPeriod,char '_[, char '_],$charLbrace, $charRbrace, char '_(, char '_), char '_$, char '_%] +$charDelimiters := [$charBlank, char '_(, char '_), $charBack] +$HTspadmacros := '("\spadtype" "\spadcommand" "\spadop" "\spadfun" "\spadatt" "\spadsyscom" "\spad" "\s") +$HTmacs := [ + ['"\beginmenu",$charRbrace,'"menu",$charLbrace,'"\begin"], + ['"\endmenu",$charRbrace,'"menu",$charLbrace,'"\end"], + ['"\beginitems",$charRbrace,'"items",$charLbrace,'"\begin"], + ['"\enditems",$charRbrace,'"items",$charLbrace,'"\end"], + ['"\beginscroll",$charRbrace,'"scroll",$charLbrace,'"\begin"], + ['"\endscroll",$charRbrace,'"scroll",$charLbrace,'"\end"]] + +$HTlinks := '( + "\downlink" + "\menulink" + "\menudownlink" + "\menuwindowlink" + "\menumemolink") + +$HTlisplinks := '( + "\lispdownlink" + "\menulispdownlink" + "\menulispwindowlink" + "\menulispmemolink" + "\lispwindowlink" + "\lispmemolink") + +$beginEndList := '( + "page" + "items" + "menu" + "scroll" + "verbatim" + "detail") + +isDefaultPackageName x == (s := PNAME x).(MAXINDEX s) = char '_& + + +-- gensym utils + +charDigitVal c == + digits := '"0123456789" + n := -1 + for i in 0..#digits-1 while n < 0 repeat + if c = digits.i then n := i + n < 0 => error '"Character is not a digit" + n + +gensymInt g == + not GENSYMP g => error '"Need a GENSYM" + p := PNAME g + n := 0 + for i in 2..#p-1 repeat n := 10 * n + charDigitVal p.i + n + + + +-- Push into the BOOT package when invoked in batch mode. +AxiomCore::$sysScope := '"BOOT" +@ + + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/guess.boot b/src/interp/guess.boot deleted file mode 100644 index 8dde919c..00000000 --- a/src/interp/guess.boot +++ /dev/null @@ -1,347 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -$minThreshold := 3 -$maxThreshold := 7 - ---======================================================================= --- Build Directories ---======================================================================= -buildOperationWordTable() == - $opWordTable := buildWordTable [PNAME x for x in allOperations()] - -buildWordTable u == - table:= MAKE_-HASHTABLE 'ID - for s in u repeat - words := wordsOfString s - key := UPCASE s.0 - HPUT(table,key,[[s,:words],:HGET(table,key)]) - for key in HKEYS table repeat - HPUT(table,key, - listSort(function GLESSEQP,removeDupOrderedAlist - listSort(function GLESSEQP, HGET(table,key),function CAR), - function CADR)) - table - -measureWordTable u == - +/[+/[#entry for entry in HGET(u,key)] for key in HKEYS u] - -removeDupOrderedAlist u == - -- removes duplicate entries in ordered alist - -- (where duplicates are adjacent) - for x in tails u repeat - (y := rest x) and first first x = first first y => RPLACD(x,rest y) - u - -wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] - -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] - -wordsOfString1(s,j) == - k := or/[i for i in j..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => - tailWords:= - UPPER_-CASE_-P s.(k+1) => - n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not UPPER_-CASE_-P s.i] - null n => [SUBSTRING(s,k,nil)] - n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] - m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => - [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] - [SUBSTRING(s,k,nil)] - k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] - tailWords - nil - -wordKeys s == - REMDUP [UPCASE s.0,:fn(s,1,-1,MAXINDEX s,nil)] where fn(s,i,lastKeyIndex,n,acc) == - i > n => acc - UPPER_-CASE_-P s.i => --- i = lastKeyIndex + 1 => fn(s,i + 1,i,n,[s.i,:rest acc]) - fn(s,i + 1,i,n,[s.i,:acc]) - fn(s,i + 1,lastKeyIndex,n,acc) - ---======================================================================= --- Augment Function Directories ---======================================================================= -add2WordFunctionTable fn == ---called from DEF - $functionTable and - null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => - HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) - ---======================================================================= --- Guess Function Name ---======================================================================= -findWords(word,table) == - $lastWord := word - $lastTable:= table - $totalWords:= nil - $countThreshold := $minThreshold - $lastMinimum := -1 - res := findApproximateWords(word,table) - if null res then - $countThreshold := $countThreshold + 2 - res := findApproximateWords(word,table) - $lastAlist := mySort res => --- $lastMinimum := CAR LAST $lastAlist --- $lastWords := wordSort CDAR $lastAlist --- $totalWords:= $lastWords --- $lastAlist := CDR $lastAlist --- $totalWords - $lastMinimum := CAAR $lastAlist - $lastWords := wordSort CDAR $lastAlist - $totalWords:= $lastWords - $lastAlist := CDR $lastAlist - $totalWords - $lastWords := nil - -wordSort u == REMDUP listSort(function GLESSEQP,u) - -more() == moreWords($lastWord,$lastTable) - -moreWords(word,table) == - $lastAlist => - $lastMinimum := CAR LAST pp $lastAlist - numberOfLastWords := #$lastWords - $lastWords := "append"/(ASSOCRIGHT $lastAlist) - if #$lastWords > numberOfLastWords then - trialLastAlist := - [p for p in $lastAlist | p.0 < $maxThreshold] - trialLastWords := "append"/(ASSOCRIGHT trialLastAlist) - if #trialLastWords > numberOfLastWords then - $lastWords := trialLastWords - $totalWords:= wordSort [:$lastWords,:$totalWords] - $lastAlist := nil - $totalWords - $countThreshold := $countThreshold + 2 - $lastAlist := findApproximateWords(word,table) - moreWords(word,table) - -findApproximateWords(word,table) == - count := $countThreshold - words:= wordsOfString word - upperWord:= UPCASE COPY word - n := #words - threshold:= - n = 1 => count - count+1 - - --first try to break up as list of words - alist:= nil - for i in 1..#words repeat - $penalty :local := (i = 1 => 0; 1) - wordAlist:= HGET(table,UPCASE (first words).0) - for [x,:wordList] in wordAlist repeat - k := findApproxWordList(words,wordList,n,threshold,#wordList) - k => - k := k + $penalty - k <= $lastMinimum => 'skip - alist := consAlist(k,x,alist) - - if i = 1 and null alist then - --no winners, so try flattening to upper case and checking again - wordSize := SIZE word - lastThreshold := MAX(threshold - 1,wordSize/2) - for [x,:.] in wordAlist repeat - k := deltaWordEntry(upperWord,UPCASE x) - k < lastThreshold => alist := consAlist(k,x,alist) - - rotateWordList words - - alist - -consAlist(x,y,alist) == - u := ASSOC(x,alist) => - RPLACD(u,[y,:CDR u]) - alist - [[x,y],:alist] - -findApproxWordList(words,wordList,n,threshold,w) == - val := findApproxWordList1(words,wordList,n,threshold,w) - null val => val ---pp [val,:wordList] - val - -findApproxWordList1(words,wordList,n,threshold,w) == - two := threshold - 2 - n = w => - k := findApproxSimple(words,wordList,threshold) => k - - n < 3 => false - threshold := threshold - 1 - sum := 0 --next, throw out one bad word - - badWord := false - for entry in wordList for part in words while sum < threshold repeat - k:= deltaWordEntry(part,entry) - k < two => sum:= sum + k - null badWord => badWord := true - sum := 1000 - sum < threshold => --- pp [2,sum,wordList] - sum + 2 - - n+1 = w => --assume one word is missing - sum := 0 - badWord := false - for entries in tails wordList for part in words - while sum < threshold repeat - entry := first entries - k:= deltaWordEntry(part,entry) - k < two => sum:= sum + k - null badWord => - badWord := true - entries := rest entries --skip this bad word - entry := first entries - k := deltaWordEntry(part,entry) - k < two => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold => --- pp [3,sum,wordList] - sum + 2 - false - n-1 = w => --assume one word too many - sum := 0 --here: KEEP it hard to satisfy - badWord := false - for entry in wordList for parts in tails words - while sum < threshold repeat - part := first parts - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - parts := rest parts --skip this bad word - part := first parts - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - return (sum := 1000) - return (sum := 1000) - sum < threshold => --- pp [4,sum,wordList] - $penalty = 1 => sum - sum + 1 - false - false - -findApproxSimple(words,wordList,threshold) == - sum := 0 - --first try matching words in order - for entry in wordList for part in words while sum < threshold repeat - sum:= sum + deltaWordEntry(part,entry) - sum < threshold => --- pp ['"--->",sum,:wordList] - sum - nil - -rotateWordList u == - v := u - p := CAR v - while QCDR v repeat - RPLACA(v,CADR v) - v := QCDR v - RPLACA(v,p) - u - -deltaWordEntry(word,entry) == - word = entry => 0 - word.0 ^= entry.0 => 1000 - #word > 2 and stringPrefix?(word,entry) => 1 - ABS(diff := SIZE word - SIZE entry) > 4 => 1000 - canForgeWord(word,entry) - ---+ Note these are optimized definitions below-- see commented out versions ---+ to understand the algorithm -canForgeWord(word,entry) == - forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) - -forge(word,w,W,entry,e,E,n) == - w > W => - e > E => n - QSADD1 QSPLUS(E-e,n) - e > E => QSADD1 QSPLUS(W-w,n) - word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) - w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) - word.w=entry.(e+1) => - word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) - forge(word,w+1,W,entry,e+2,E,QSADD1 n) - word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) - - (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => - --if word is long, can we delete chars to match 2 consective chars - deltaW >= deltaE and - (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) - and word.(k+1) = entry.(e+1) => - forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) - deltaW <= deltaE and - --if word is short, can we insert chars so as to match 2 consecutive chars - (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) - and word.(w+1) = entry.(k+1) => - forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - --check for two consecutive matches down the line - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - ---+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm ---+ canForgeWord(word,entry) ==-- ---+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) ---+ --d=deletions, i=insertions, s=substitutions, t=transpositions ---+ --list is formed only for tuning purposes-- remove later on ---+ d + i + s + t - ---+forge(word,w,W,entry,e,E,d,i,s,t) == ---+ w > W => ---+ e > E => [d,i,s,t] ---+ [d,E-e+i+1,s,t] ---+ e > E => [W-w+d+1,i,s,t] ---+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) ---+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ word.w=entry.(e+1) => ---+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) ---+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) ---+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) ---+ ---+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => ---+ --if word is long, can we delete chars to match 2 consective chars ---+ deltaW >= deltaE and ---+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) ---+ and word.(k+1) = entry.(e+1) => ---+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) ---+ deltaW <= deltaE and ---+ --if word is short, can we insert chars so as to match 2 consecutive chars ---+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) ---+ and word.(w+1) = entry.(k+1) => ---+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ --check for two consecutive matches down the line ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) - -mySort u == listSort(function GLESSEQP,u) diff --git a/src/interp/guess.boot.pamphlet b/src/interp/guess.boot.pamphlet new file mode 100644 index 00000000..4f4d2544 --- /dev/null +++ b/src/interp/guess.boot.pamphlet @@ -0,0 +1,369 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp guess.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +$minThreshold := 3 +$maxThreshold := 7 + +--======================================================================= +-- Build Directories +--======================================================================= +buildOperationWordTable() == + $opWordTable := buildWordTable [PNAME x for x in allOperations()] + +buildWordTable u == + table:= MAKE_-HASHTABLE 'ID + for s in u repeat + words := wordsOfString s + key := UPCASE s.0 + HPUT(table,key,[[s,:words],:HGET(table,key)]) + for key in HKEYS table repeat + HPUT(table,key, + listSort(function GLESSEQP,removeDupOrderedAlist + listSort(function GLESSEQP, HGET(table,key),function CAR), + function CADR)) + table + +measureWordTable u == + +/[+/[#entry for entry in HGET(u,key)] for key in HKEYS u] + +removeDupOrderedAlist u == + -- removes duplicate entries in ordered alist + -- (where duplicates are adjacent) + for x in tails u repeat + (y := rest x) and first first x = first first y => RPLACD(x,rest y) + u + +wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] + +wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] + +wordsOfString1(s,j) == + k := or/[i for i in j..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => + tailWords:= + UPPER_-CASE_-P s.(k+1) => + n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not UPPER_-CASE_-P s.i] + null n => [SUBSTRING(s,k,nil)] + n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] + m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | UPPER_-CASE_-P s.i] => + [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] + [SUBSTRING(s,k,nil)] + k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] + tailWords + nil + +wordKeys s == + REMDUP [UPCASE s.0,:fn(s,1,-1,MAXINDEX s,nil)] where fn(s,i,lastKeyIndex,n,acc) == + i > n => acc + UPPER_-CASE_-P s.i => +-- i = lastKeyIndex + 1 => fn(s,i + 1,i,n,[s.i,:rest acc]) + fn(s,i + 1,i,n,[s.i,:acc]) + fn(s,i + 1,lastKeyIndex,n,acc) + +--======================================================================= +-- Augment Function Directories +--======================================================================= +add2WordFunctionTable fn == +--called from DEF + $functionTable and + null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => + HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) + +--======================================================================= +-- Guess Function Name +--======================================================================= +findWords(word,table) == + $lastWord := word + $lastTable:= table + $totalWords:= nil + $countThreshold := $minThreshold + $lastMinimum := -1 + res := findApproximateWords(word,table) + if null res then + $countThreshold := $countThreshold + 2 + res := findApproximateWords(word,table) + $lastAlist := mySort res => +-- $lastMinimum := CAR LAST $lastAlist +-- $lastWords := wordSort CDAR $lastAlist +-- $totalWords:= $lastWords +-- $lastAlist := CDR $lastAlist +-- $totalWords + $lastMinimum := CAAR $lastAlist + $lastWords := wordSort CDAR $lastAlist + $totalWords:= $lastWords + $lastAlist := CDR $lastAlist + $totalWords + $lastWords := nil + +wordSort u == REMDUP listSort(function GLESSEQP,u) + +more() == moreWords($lastWord,$lastTable) + +moreWords(word,table) == + $lastAlist => + $lastMinimum := CAR LAST pp $lastAlist + numberOfLastWords := #$lastWords + $lastWords := "append"/(ASSOCRIGHT $lastAlist) + if #$lastWords > numberOfLastWords then + trialLastAlist := + [p for p in $lastAlist | p.0 < $maxThreshold] + trialLastWords := "append"/(ASSOCRIGHT trialLastAlist) + if #trialLastWords > numberOfLastWords then + $lastWords := trialLastWords + $totalWords:= wordSort [:$lastWords,:$totalWords] + $lastAlist := nil + $totalWords + $countThreshold := $countThreshold + 2 + $lastAlist := findApproximateWords(word,table) + moreWords(word,table) + +findApproximateWords(word,table) == + count := $countThreshold + words:= wordsOfString word + upperWord:= UPCASE COPY word + n := #words + threshold:= + n = 1 => count + count+1 + + --first try to break up as list of words + alist:= nil + for i in 1..#words repeat + $penalty :local := (i = 1 => 0; 1) + wordAlist:= HGET(table,UPCASE (first words).0) + for [x,:wordList] in wordAlist repeat + k := findApproxWordList(words,wordList,n,threshold,#wordList) + k => + k := k + $penalty + k <= $lastMinimum => 'skip + alist := consAlist(k,x,alist) + + if i = 1 and null alist then + --no winners, so try flattening to upper case and checking again + wordSize := SIZE word + lastThreshold := MAX(threshold - 1,wordSize/2) + for [x,:.] in wordAlist repeat + k := deltaWordEntry(upperWord,UPCASE x) + k < lastThreshold => alist := consAlist(k,x,alist) + + rotateWordList words + + alist + +consAlist(x,y,alist) == + u := ASSOC(x,alist) => + RPLACD(u,[y,:CDR u]) + alist + [[x,y],:alist] + +findApproxWordList(words,wordList,n,threshold,w) == + val := findApproxWordList1(words,wordList,n,threshold,w) + null val => val +--pp [val,:wordList] + val + +findApproxWordList1(words,wordList,n,threshold,w) == + two := threshold - 2 + n = w => + k := findApproxSimple(words,wordList,threshold) => k + + n < 3 => false + threshold := threshold - 1 + sum := 0 --next, throw out one bad word + + badWord := false + for entry in wordList for part in words while sum < threshold repeat + k:= deltaWordEntry(part,entry) + k < two => sum:= sum + k + null badWord => badWord := true + sum := 1000 + sum < threshold => +-- pp [2,sum,wordList] + sum + 2 + + n+1 = w => --assume one word is missing + sum := 0 + badWord := false + for entries in tails wordList for part in words + while sum < threshold repeat + entry := first entries + k:= deltaWordEntry(part,entry) + k < two => sum:= sum + k + null badWord => + badWord := true + entries := rest entries --skip this bad word + entry := first entries + k := deltaWordEntry(part,entry) + k < two => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold => +-- pp [3,sum,wordList] + sum + 2 + false + n-1 = w => --assume one word too many + sum := 0 --here: KEEP it hard to satisfy + badWord := false + for entry in wordList for parts in tails words + while sum < threshold repeat + part := first parts + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + parts := rest parts --skip this bad word + part := first parts + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + return (sum := 1000) + return (sum := 1000) + sum < threshold => +-- pp [4,sum,wordList] + $penalty = 1 => sum + sum + 1 + false + false + +findApproxSimple(words,wordList,threshold) == + sum := 0 + --first try matching words in order + for entry in wordList for part in words while sum < threshold repeat + sum:= sum + deltaWordEntry(part,entry) + sum < threshold => +-- pp ['"--->",sum,:wordList] + sum + nil + +rotateWordList u == + v := u + p := CAR v + while QCDR v repeat + RPLACA(v,CADR v) + v := QCDR v + RPLACA(v,p) + u + +deltaWordEntry(word,entry) == + word = entry => 0 + word.0 ^= entry.0 => 1000 + #word > 2 and stringPrefix?(word,entry) => 1 + ABS(diff := SIZE word - SIZE entry) > 4 => 1000 + canForgeWord(word,entry) + +--+ Note these are optimized definitions below-- see commented out versions +--+ to understand the algorithm +canForgeWord(word,entry) == + forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) + +forge(word,w,W,entry,e,E,n) == + w > W => + e > E => n + QSADD1 QSPLUS(E-e,n) + e > E => QSADD1 QSPLUS(W-w,n) + word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) + w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) + word.w=entry.(e+1) => + word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) + forge(word,w+1,W,entry,e+2,E,QSADD1 n) + word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) + + (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => + --if word is long, can we delete chars to match 2 consective chars + deltaW >= deltaE and + (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) + and word.(k+1) = entry.(e+1) => + forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) + deltaW <= deltaE and + --if word is short, can we insert chars so as to match 2 consecutive chars + (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) + and word.(w+1) = entry.(k+1) => + forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + --check for two consecutive matches down the line + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + +--+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm +--+ canForgeWord(word,entry) ==-- +--+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) +--+ --d=deletions, i=insertions, s=substitutions, t=transpositions +--+ --list is formed only for tuning purposes-- remove later on +--+ d + i + s + t + +--+forge(word,w,W,entry,e,E,d,i,s,t) == +--+ w > W => +--+ e > E => [d,i,s,t] +--+ [d,E-e+i+1,s,t] +--+ e > E => [W-w+d+1,i,s,t] +--+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) +--+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ word.w=entry.(e+1) => +--+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) +--+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) +--+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) +--+ +--+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => +--+ --if word is long, can we delete chars to match 2 consective chars +--+ deltaW >= deltaE and +--+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) +--+ and word.(k+1) = entry.(e+1) => +--+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) +--+ deltaW <= deltaE and +--+ --if word is short, can we insert chars so as to match 2 consecutive chars +--+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) +--+ and word.(w+1) = entry.(k+1) => +--+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ --check for two consecutive matches down the line +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) + +mySort u == listSort(function GLESSEQP,u) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/hash.lisp b/src/interp/hash.lisp deleted file mode 100644 index 5dfda6e1..00000000 --- a/src/interp/hash.lisp +++ /dev/null @@ -1,121 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(IMPORT-MODULE "vmlisp") -(in-package "BOOT") - -(export '(MAKE-HASHTABLE HGET HKEYS HCOUNT HPUT HPUT* HREM HCLEAR HREMPROP - HASHEQ HASHUEQUAL HASHCVEC HASHID HASHTABLEP CVEC UEQUAL ID HPUTPROP - HASHTABLE-CLASS)) - -;17.0 Operations on Hashtables -;17.1 Creation - -(defun MAKE-HASHTABLE (id1 &optional (id2 nil)) - (declare (ignore id2)) - (let ((test (case id1 - ((EQ ID) #'eq) - (CVEC #'equal) - (EQL #'eql) - #+Lucid ((UEQUAL EQUALP) #'EQUALP) - #-Lucid ((UEQUAL EQUAL) #'equal) - (otherwise (error "bad arg to make-hashtable"))))) - (make-hash-table :test test))) - -;17.2 Accessing - -(defmacro HGET (table key &rest default) - `(gethash ,key ,table ,@default)) - -(defun HKEYS (table) - (let (keys) - (maphash - #'(lambda (key val) (declare (ignore val)) (push key keys)) table) - keys)) - -#+Lucid -(define-function 'HASHTABLE-CLASS #'system::hash-table-test) - -#+AKCL -(clines "int mem_value(x ,i)object x;int i; { return ((short *)x)[i];}") -#+AKCL -(defentry memory-value-short(object int) (int "mem_value")) - -;(memory-value-short (make-hash-table :test 'equal) 12) is 0,1,or 2 -;depending on whether the test is eq,eql or equal. -#+AKCL -(defun HASHTABLE-CLASS (table) - (case (memory-value-short table 12) - (0 'EQ) - (1 'EQL) - (2 'EQUAL) - (t "error unknown hash table class"))) - -#+:CCL -(defun HASHTABLE-CLASS (table) - (case (hashtable-flavour table) - (0 'EQ) - (1 'EQL) - (2 'EQUAL) - (t (format nil "error unknown hash table class ~a" (hashtable-flavour table))))) - -(define-function 'HCOUNT #'hash-table-count) - -;17.4 Searching and Updating - -(defun HPUT (table key value) (setf (gethash key table) value)) - -(defun HPUT* (table alist) - (mapc #'(lambda (pair) (hput table (car pair) (cdr pair))) alist)) - -(defmacro HREM (table key) `(remhash ,key ,table)) - -(defun HREMPROP (table key property) - (let ((plist (gethash key table))) - (if plist (setf (gethash key table) - (delete property plist :test #'equal :key #'car))))) - -;17.5 Updating - -(define-function 'HCLEAR #'clrhash) - -;17.6 Miscellaneous - -(define-function 'HASHTABLEP #'hash-table-p) - -(define-function 'HASHEQ #'sxhash) - -(define-function 'HASHUEQUAL #'sxhash) - -(define-function 'HASHCVEC #'sxhash) - -(define-function 'HASHID #'sxhash) diff --git a/src/interp/hash.lisp.pamphlet b/src/interp/hash.lisp.pamphlet new file mode 100644 index 00000000..be039807 --- /dev/null +++ b/src/interp/hash.lisp.pamphlet @@ -0,0 +1,147 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/hash.lisp} Pamphlet} +\author{Timothy Daly} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(IMPORT-MODULE "vmlisp") +(in-package "BOOT") + +(export '(MAKE-HASHTABLE HGET HKEYS HCOUNT HPUT HPUT* HREM HCLEAR HREMPROP + HASHEQ HASHUEQUAL HASHCVEC HASHID HASHTABLEP CVEC UEQUAL ID HPUTPROP + HASHTABLE-CLASS)) + +;17.0 Operations on Hashtables +;17.1 Creation + +(defun MAKE-HASHTABLE (id1 &optional (id2 nil)) + (declare (ignore id2)) + (let ((test (case id1 + ((EQ ID) #'eq) + (CVEC #'equal) + (EQL #'eql) + #+Lucid ((UEQUAL EQUALP) #'EQUALP) + #-Lucid ((UEQUAL EQUAL) #'equal) + (otherwise (error "bad arg to make-hashtable"))))) + (make-hash-table :test test))) + +;17.2 Accessing + +(defmacro HGET (table key &rest default) + `(gethash ,key ,table ,@default)) + +(defun HKEYS (table) + (let (keys) + (maphash + #'(lambda (key val) (declare (ignore val)) (push key keys)) table) + keys)) + +#+Lucid +(define-function 'HASHTABLE-CLASS #'system::hash-table-test) + +#+AKCL +(clines "int mem_value(x ,i)object x;int i; { return ((short *)x)[i];}") +#+AKCL +(defentry memory-value-short(object int) (int "mem_value")) + +;(memory-value-short (make-hash-table :test 'equal) 12) is 0,1,or 2 +;depending on whether the test is eq,eql or equal. +#+AKCL +(defun HASHTABLE-CLASS (table) + (case (memory-value-short table 12) + (0 'EQ) + (1 'EQL) + (2 'EQUAL) + (t "error unknown hash table class"))) + +#+:CCL +(defun HASHTABLE-CLASS (table) + (case (hashtable-flavour table) + (0 'EQ) + (1 'EQL) + (2 'EQUAL) + (t (format nil "error unknown hash table class ~a" (hashtable-flavour table))))) + +(define-function 'HCOUNT #'hash-table-count) + +;17.4 Searching and Updating + +(defun HPUT (table key value) (setf (gethash key table) value)) + +(defun HPUT* (table alist) + (mapc #'(lambda (pair) (hput table (car pair) (cdr pair))) alist)) + +(defmacro HREM (table key) `(remhash ,key ,table)) + +(defun HREMPROP (table key property) + (let ((plist (gethash key table))) + (if plist (setf (gethash key table) + (delete property plist :test #'equal :key #'car))))) + +;17.5 Updating + +(define-function 'HCLEAR #'clrhash) + +;17.6 Miscellaneous + +(define-function 'HASHTABLEP #'hash-table-p) + +(define-function 'HASHEQ #'sxhash) + +(define-function 'HASHUEQUAL #'sxhash) + +(define-function 'HASHCVEC #'sxhash) + +(define-function 'HASHID #'sxhash) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/hashcode.boot b/src/interp/hashcode.boot deleted file mode 100644 index 53a42d04..00000000 --- a/src/interp/hashcode.boot +++ /dev/null @@ -1,109 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- Type hasher for old compiler style type names which produces a hash code --- compatible with the asharp compiler. Takes a hard error if the type --- is parameterized, but has no constructor modemap. -getDomainHash dom == SPADCALL(CDR dom, (CAR dom).4) - -hashType(type, percentHash) == - SYMBOLP type => - type = '$ => percentHash - type = "%" => percentHash - hashString SYMBOL_-NAME type - STRINGP type => hashCombine(hashString type, - hashString('"Enumeration")) - type is ['QUOTE, val] => hashType(val, percentHash) - type is [dom] => hashString SYMBOL_-NAME dom - type is ['_:, ., type2] => hashType(type2, percentHash) - isDomain type => getDomainHash type - [op, :args] := type - hash := hashString SYMBOL_-NAME op - op = 'Mapping => - hash := hashString '"->" - [retType, :mapArgs] := args - for arg in mapArgs repeat - hash := hashCombine(hashType(arg, percentHash), hash) - retCode := hashType(retType, percentHash) - EQL(retCode, $VoidHash) => hash - hashCombine(retCode, hash) - op = 'Enumeration => - for arg in args repeat - hash := hashCombine(hashString(STRING arg), hash) - hash - op in $DomainsWithoutLisplibs => - for arg in args repeat - hash := hashCombine(hashType(arg, percentHash), hash) - hash - - cmm := CDDAR getConstructorModemap(op) - cosig := CDR GETDATABASE(op, 'COSIG) - for arg in args for c in cosig for ct in cmm repeat - if c then - hash := hashCombine(hashType(arg, percentHash), hash) - else - hash := hashCombine(7, hash) --- !!! If/when asharp hashes values using their type, use instead --- ctt := EQSUBSTLIST(args, $FormalMapVariableList, ct) --- hash := hashCombine(hashType(ctt, percentHash), hash) - - - hash - ---The following are in cfuns.lisp -$hashModulus := 1073741789 -- largest 30-bit prime - --- Produce a 30-bit hash code. This function must produce the same codes --- as the asharp string hasher in src/strops.c -hashString str == - h := 0 - for i in 0..#str-1 repeat - j := CHAR_-CODE char str.i - h := LOGXOR(h, ASH(h, 8)) - h := h + j + 200041 - h := LOGAND(h, 1073741823) -- 0x3FFFFFFF - REM(h, $hashModulus) - --- Combine two hash codes to make a new one. Must be the same as in --- the hashCombine function in aslib/runtime.as in asharp. -hashCombine(hash1, hash2) == - MOD(ASH(LOGAND(hash2, 16777215), 6) + hash1, $hashModulus) - - -$VoidHash := hashString '"Void" - - --- following two lines correct bad coSig properties due to SubsetCategory ---putConstructorProperty('LocalAlgebra,'coSig,'(NIL T T T)) ---putConstructorProperty('Localize,'coSig,'(NIL T T T)) diff --git a/src/interp/hashcode.boot.pamphlet b/src/interp/hashcode.boot.pamphlet new file mode 100644 index 00000000..4a0f640e --- /dev/null +++ b/src/interp/hashcode.boot.pamphlet @@ -0,0 +1,131 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp hashcode.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- Type hasher for old compiler style type names which produces a hash code +-- compatible with the asharp compiler. Takes a hard error if the type +-- is parameterized, but has no constructor modemap. +getDomainHash dom == SPADCALL(CDR dom, (CAR dom).4) + +hashType(type, percentHash) == + SYMBOLP type => + type = '$ => percentHash + type = "%" => percentHash + hashString SYMBOL_-NAME type + STRINGP type => hashCombine(hashString type, + hashString('"Enumeration")) + type is ['QUOTE, val] => hashType(val, percentHash) + type is [dom] => hashString SYMBOL_-NAME dom + type is ['_:, ., type2] => hashType(type2, percentHash) + isDomain type => getDomainHash type + [op, :args] := type + hash := hashString SYMBOL_-NAME op + op = 'Mapping => + hash := hashString '"->" + [retType, :mapArgs] := args + for arg in mapArgs repeat + hash := hashCombine(hashType(arg, percentHash), hash) + retCode := hashType(retType, percentHash) + EQL(retCode, $VoidHash) => hash + hashCombine(retCode, hash) + op = 'Enumeration => + for arg in args repeat + hash := hashCombine(hashString(STRING arg), hash) + hash + op in $DomainsWithoutLisplibs => + for arg in args repeat + hash := hashCombine(hashType(arg, percentHash), hash) + hash + + cmm := CDDAR getConstructorModemap(op) + cosig := CDR GETDATABASE(op, 'COSIG) + for arg in args for c in cosig for ct in cmm repeat + if c then + hash := hashCombine(hashType(arg, percentHash), hash) + else + hash := hashCombine(7, hash) +-- !!! If/when asharp hashes values using their type, use instead +-- ctt := EQSUBSTLIST(args, $FormalMapVariableList, ct) +-- hash := hashCombine(hashType(ctt, percentHash), hash) + + + hash + +--The following are in cfuns.lisp +$hashModulus := 1073741789 -- largest 30-bit prime + +-- Produce a 30-bit hash code. This function must produce the same codes +-- as the asharp string hasher in src/strops.c +hashString str == + h := 0 + for i in 0..#str-1 repeat + j := CHAR_-CODE char str.i + h := LOGXOR(h, ASH(h, 8)) + h := h + j + 200041 + h := LOGAND(h, 1073741823) -- 0x3FFFFFFF + REM(h, $hashModulus) + +-- Combine two hash codes to make a new one. Must be the same as in +-- the hashCombine function in aslib/runtime.as in asharp. +hashCombine(hash1, hash2) == + MOD(ASH(LOGAND(hash2, 16777215), 6) + hash1, $hashModulus) + + +$VoidHash := hashString '"Void" + + +-- following two lines correct bad coSig properties due to SubsetCategory +--putConstructorProperty('LocalAlgebra,'coSig,'(NIL T T T)) +--putConstructorProperty('Localize,'coSig,'(NIL T T T)) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/ht-root.boot b/src/interp/ht-root.boot deleted file mode 100644 index 7325b3b8..00000000 --- a/src/interp/ht-root.boot +++ /dev/null @@ -1,289 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -$historyDisplayWidth := 120 -$newline := char 10 - -downlink page == - $saturn => downlinkSaturn page - htInitPage('"Bridge",nil) - htSay('"\replacepage{", page, '"}") - htShowPage() - -downlinkSaturn fn == - u := dbReadLines(fn) - lines := '"" - while u is [line,:u] repeat - n := MAXINDEX line - n < 1 => nil - line.0 = (char '_%) => nil - lines := STRCONC(lines,line) - issueHTSaturn lines - -dbNonEmptyPattern pattern == - null pattern => '"*" - pattern := STRINGIMAGE pattern - #pattern > 0 => pattern - '"*" - -htSystemVariables() == main where - main == - not $fullScreenSysVars => htSetVars() - classlevel := $UserLevel - $levels : local := '(compiler development interpreter) - $heading : local := nil - while classlevel ^= first $levels repeat $levels := rest $levels - table := NREVERSE fn($setOptions,nil,true) - htInitPage('"System Variables",nil) - htSay '"\beginmenu" - lastHeading := nil - for [heading,name,message,.,key,variable,options,func] in table repeat - htSay('"\newline\item ") - if heading = lastHeading then htSay '"\tab{8}" else - htSay(heading,'"\tab{8}") - lastHeading := heading - htSay('"{\em ",name,"}\tab{22}",message) - htSay('"\tab{80}") - key = 'FUNCTION => - null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] - [msg,class,var,valuesOrFunction,:.] := first options --skip first message - functionTail(name,class,var,valuesOrFunction) - for option in rest options repeat - option is ['break,:.] => 'skip - [msg,class,var,valuesOrFunction,:.] := option - htSay('"\newline\tab{22}", msg,'"\tab{80}") - functionTail(name,class,var,valuesOrFunction) - val := eval variable - displayOptions(name,key,variable,val,options) - htSay '"\endmenu" - htShowPage() - functionTail(name,class,var,valuesOrFunction) == - val := eval var - atom valuesOrFunction => - htMakePage '((domainConditions (isDomain STR (String)))) - htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] - htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] - displayOptions(name,class,var,val,valuesOrFunction) - displayOptions(name,class,variable,val,options) == - class = 'INTEGER => - htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] - htMakePage '((domainConditions (isDomain INT (Integer)))) - htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] - class = 'STRING => - htSay('"{\em ",val,'"}\space{1}") - for x in options repeat - val = x or val = true and x = 'on or null val and x = 'off => - htSay('"{\em ",x,'"}\space{1}") - htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] - fn(t,al,firstTime) == - atom t => al - if firstTime then $heading := opOf first t - fn(rest t,gn(first t,al),firstTime) - gn(t,al) == - [.,.,class,key,.,options,:.] := t - not MEMQ(class,$levels) => al - key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] - key = 'TREE => fn(options,al,false) - key = 'FUNCTION => [[$heading,:t],:al] - systemError key - -htSetSystemVariableKind(htPage,[variable,name,fun]) == - value := htpLabelInputString(htPage,name) - if STRINGP value and fun then value := FUNCALL(fun,value) ---SCM::what to do??? if not FIXP value then userError ??? - SET(variable,value) - htSystemVariables () - -htSetSystemVariable(htPage,[name,value]) == - value := - value = 'on => true - value = 'off => nil - value - SET(name,value) - htSystemVariables () - -htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) - -htGlossPage(htPage,pattern,tryAgain?) == - $wildCard: local := char '_* - pattern = '"*" => downlink 'GlossaryPage - filter := pmTransFilter pattern - grepForm := mkGrepPattern(filter,'none) - $key: local := 'none - results := applyGrep(grepForm,'gloss) - --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") - --instream := MAKE_-INSTREAM pathname - defstream := MAKE_-INSTREAM STRCONC(getEnv '"AXIOM",'"/algebra/glossdef.text") - lines := gatherGlossLines(results,defstream) - -- OBEY STRCONC('"rm -f ", pathname) - --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) - --SHUT instream - heading := - pattern = '"" => '"Glossary" - null lines => ['"No glossary items match {\em ",pattern,'"}"] - ['"Glossary items matching {\em ",pattern,'"}"] - null lines => - tryAgain? and #pattern > 0 => - (pattern.(k := MAXINDEX(pattern))) = char 's => - htGlossPage(htPage,SUBSTRING(pattern,0,k),true) - UPPER_-CASE_-P pattern.0 => - htGlossPage(htPage,DOWNCASE pattern,false) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) - htInitPageNoScroll(nil,heading) - htSay('"\beginscroll\beginmenu") - for line in lines repeat - tick := charPosition($tick,line,1) - htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) - htSay '"\endmenu " - htSay '"\endscroll\newline " - htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] - htSay '" for glossary entry matching " - htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] - htShowPageNoScroll() - -gatherGlossLines(results,defstream) == - acc := nil - for keyline in results repeat - --keyline := READLINE instream - n := charPosition($tick,keyline,0) - keyAndTick := SUBSTRING(keyline,0,n + 1) - byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) - FILE_-POSITION(defstream,byteAddress) - line := READLINE defstream - k := charPosition($tick,line,1) - pointer := SUBSTRING(line,0,k) - def := SUBSTRING(line,k + 1,nil) - xtralines := nil - while not EOFP defstream and (x := READLINE defstream) and - (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) - and (nextPointer = pointer) repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] - REVERSE acc - -htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) - -htGreekSearch(filter) == - ss := dbNonEmptyPattern filter - s := pmTransFilter ss - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := patternCheck s - names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) - for x in names repeat - superMatch?(filter,PNAME x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Greek Names",nil) - null matches => - htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) - htSay("\vspace{2}\centerline{Sorry, but no greek letters match your search string}\centerline{{\em ",ss,"}}\centerline{Click on the up-arrow to try again}") - htShowPage() - htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) - if nonmatches - then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") - else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The greek letters that {\em do not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTextSearch(filter) == - s := pmTransFilter dbNonEmptyPattern filter - s is ['error,:.] => bcErrorPage s - not s => errorPage(nil,[['"Missing search string"],nil, - '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", - '"\centerline{{\em first} enter a search key into the input area}\newline ", - '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) - filter := s - lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", - '"{{\em Sneak Sears Silas with Savings Snatch}}"] - for x in lines repeat - superMatch?(filter,x) => matches := [x,:matches] - nonmatches := [x,:nonmatches] - matches := NREVERSE matches - nonmatches := NREVERSE nonmatches - htInitPage('"Text Matches",nil) - null matches => - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") - htShowPage() - htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) - if nonmatches - then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") - else htSay('"Your search string {\em ",s,"} matches both lines:") - htSay('"{\em \table{") - for x in matches repeat htSay('"{",x,'"}") - htSay('"}}\vspace{1}") - if nonmatches then - htSay('"The line that {\em does not match} your search string:{\em \table{") - for x in nonmatches repeat htSay('"{",x,'"}") - htSay('"}}") - htShowPage() - -htTutorialSearch pattern == - s := dbNonEmptyPattern pattern or return - errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) - s := mkUnixPattern s - source := '"$AXIOM/share/hypertex/pages/ht.db" - target :='"/tmp/temp.text.$SPADNUM" - OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) - lines := dbReadLines 'temp - htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) - htSay('"\beginscroll\table{") - for line in lines repeat - [name,title,.] := dbParts(line,3,0) - htSay ['"{\downlink{",title,'"}{",name,'"}}"] - htSay '"}" - htShowPage() - -mkUnixPattern s == - u := mkUpDownPattern s - starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] - for i in starPositions repeat - u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) - if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) - else u := SUBSTRING(u,1,nil) - if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") - else u := SUBSTRING(u,0,k) - u - - diff --git a/src/interp/ht-root.boot.pamphlet b/src/interp/ht-root.boot.pamphlet new file mode 100644 index 00000000..3d8d08af --- /dev/null +++ b/src/interp/ht-root.boot.pamphlet @@ -0,0 +1,311 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp ht-root.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +$historyDisplayWidth := 120 +$newline := char 10 + +downlink page == + $saturn => downlinkSaturn page + htInitPage('"Bridge",nil) + htSay('"\replacepage{", page, '"}") + htShowPage() + +downlinkSaturn fn == + u := dbReadLines(fn) + lines := '"" + while u is [line,:u] repeat + n := MAXINDEX line + n < 1 => nil + line.0 = (char '_%) => nil + lines := STRCONC(lines,line) + issueHTSaturn lines + +dbNonEmptyPattern pattern == + null pattern => '"*" + pattern := STRINGIMAGE pattern + #pattern > 0 => pattern + '"*" + +htSystemVariables() == main where + main == + not $fullScreenSysVars => htSetVars() + classlevel := $UserLevel + $levels : local := '(compiler development interpreter) + $heading : local := nil + while classlevel ^= first $levels repeat $levels := rest $levels + table := NREVERSE fn($setOptions,nil,true) + htInitPage('"System Variables",nil) + htSay '"\beginmenu" + lastHeading := nil + for [heading,name,message,.,key,variable,options,func] in table repeat + htSay('"\newline\item ") + if heading = lastHeading then htSay '"\tab{8}" else + htSay(heading,'"\tab{8}") + lastHeading := heading + htSay('"{\em ",name,"}\tab{22}",message) + htSay('"\tab{80}") + key = 'FUNCTION => + null options => htMakePage [['bcLinks,['"reset",'"",func,nil]]] + [msg,class,var,valuesOrFunction,:.] := first options --skip first message + functionTail(name,class,var,valuesOrFunction) + for option in rest options repeat + option is ['break,:.] => 'skip + [msg,class,var,valuesOrFunction,:.] := option + htSay('"\newline\tab{22}", msg,'"\tab{80}") + functionTail(name,class,var,valuesOrFunction) + val := eval variable + displayOptions(name,key,variable,val,options) + htSay '"\endmenu" + htShowPage() + functionTail(name,class,var,valuesOrFunction) == + val := eval var + atom valuesOrFunction => + htMakePage '((domainConditions (isDomain STR (String)))) + htMakePage [['bcLinks,['"reset",'"",'htSetSystemVariableKind,[var,name,nil]]]] + htMakePage [['bcStrings,[30,STRINGIMAGE val,name,valuesOrFunction]]] + displayOptions(name,class,var,val,valuesOrFunction) + displayOptions(name,class,variable,val,options) == + class = 'INTEGER => + htMakePage [['bcLispLinks,[[['text,options.0,'"-",options.1 or '""]],'"",'htSetSystemVariableKind,[variable,name,'PARSE_-INTEGER]]]] + htMakePage '((domainConditions (isDomain INT (Integer)))) + htMakePage [['bcStrings,[5,STRINGIMAGE val,name,'INT]]] + class = 'STRING => + htSay('"{\em ",val,'"}\space{1}") + for x in options repeat + val = x or val = true and x = 'on or null val and x = 'off => + htSay('"{\em ",x,'"}\space{1}") + htMakePage [['bcLispLinks,[x,'" ",'htSetSystemVariable,[variable,x]]]] + fn(t,al,firstTime) == + atom t => al + if firstTime then $heading := opOf first t + fn(rest t,gn(first t,al),firstTime) + gn(t,al) == + [.,.,class,key,.,options,:.] := t + not MEMQ(class,$levels) => al + key = 'LITERALS or key = 'INTEGER or key = 'STRING => [[$heading,:t],:al] + key = 'TREE => fn(options,al,false) + key = 'FUNCTION => [[$heading,:t],:al] + systemError key + +htSetSystemVariableKind(htPage,[variable,name,fun]) == + value := htpLabelInputString(htPage,name) + if STRINGP value and fun then value := FUNCALL(fun,value) +--SCM::what to do??? if not FIXP value then userError ??? + SET(variable,value) + htSystemVariables () + +htSetSystemVariable(htPage,[name,value]) == + value := + value = 'on => true + value = 'off => nil + value + SET(name,value) + htSystemVariables () + +htGloss(pattern) == htGlossPage(nil,dbNonEmptyPattern pattern or '"*",true) + +htGlossPage(htPage,pattern,tryAgain?) == + $wildCard: local := char '_* + pattern = '"*" => downlink 'GlossaryPage + filter := pmTransFilter pattern + grepForm := mkGrepPattern(filter,'none) + $key: local := 'none + results := applyGrep(grepForm,'gloss) + --pathname := STRCONC('"/tmp/",PNAME resultFile,'".text.", getEnv '"SPADNUM") + --instream := MAKE_-INSTREAM pathname + defstream := MAKE_-INSTREAM STRCONC(getEnv '"AXIOM",'"/algebra/glossdef.text") + lines := gatherGlossLines(results,defstream) + -- OBEY STRCONC('"rm -f ", pathname) + --PROBE_-FILE(pathname) and DELETE_-FILE(pathname) + --SHUT instream + heading := + pattern = '"" => '"Glossary" + null lines => ['"No glossary items match {\em ",pattern,'"}"] + ['"Glossary items matching {\em ",pattern,'"}"] + null lines => + tryAgain? and #pattern > 0 => + (pattern.(k := MAXINDEX(pattern))) = char 's => + htGlossPage(htPage,SUBSTRING(pattern,0,k),true) + UPPER_-CASE_-P pattern.0 => + htGlossPage(htPage,DOWNCASE pattern,false) + errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) + errorPage(htPage,['"Sorry",nil,['"\centerline{",:heading,'"}"]]) + htInitPageNoScroll(nil,heading) + htSay('"\beginscroll\beginmenu") + for line in lines repeat + tick := charPosition($tick,line,1) + htSay('"\item{\em \menuitemstyle{}}\tab{0}{\em ",escapeString SUBSTRING(line,0,tick),'"} ",SUBSTRING(line,tick + 1,nil)) + htSay '"\endmenu " + htSay '"\endscroll\newline " + htMakePage [['bcLinks,['"Search",'"",'htGlossSearch,nil]]] + htSay '" for glossary entry matching " + htMakePage [['bcStrings, [24,'"*",'filter,'EM]]] + htShowPageNoScroll() + +gatherGlossLines(results,defstream) == + acc := nil + for keyline in results repeat + --keyline := READLINE instream + n := charPosition($tick,keyline,0) + keyAndTick := SUBSTRING(keyline,0,n + 1) + byteAddress := string2Integer SUBSTRING(keyline,n + 1,nil) + FILE_-POSITION(defstream,byteAddress) + line := READLINE defstream + k := charPosition($tick,line,1) + pointer := SUBSTRING(line,0,k) + def := SUBSTRING(line,k + 1,nil) + xtralines := nil + while not EOFP defstream and (x := READLINE defstream) and + (j := charPosition($tick,x,1)) and (nextPointer := SUBSTRING(x,0,j)) + and (nextPointer = pointer) repeat + xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] + acc := [STRCONC(keyAndTick,def, "STRCONC"/NREVERSE xtralines),:acc] + REVERSE acc + +htGlossSearch(htPage,junk) == htGloss htpLabelInputString(htPage,'filter) + +htGreekSearch(filter) == + ss := dbNonEmptyPattern filter + s := pmTransFilter ss + s is ['error,:.] => bcErrorPage s + not s => errorPage(nil,[['"Missing search string"],nil, + '"\vspace{2}\centerline{To select one of the greek letters:}\newline ", + '"\centerline{{\em first} enter a search key into the input area}\newline ", + '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) + filter := patternCheck s + names := '(alpha beta gamma delta epsilon zeta eta theta iota kappa lambda mu nu pi) + for x in names repeat + superMatch?(filter,PNAME x) => matches := [x,:matches] + nonmatches := [x,:nonmatches] + matches := NREVERSE matches + nonmatches := NREVERSE nonmatches + htInitPage('"Greek Names",nil) + null matches => + htInitPage(['"Greek names matching search string {\em ",ss,'"}"],nil) + htSay("\vspace{2}\centerline{Sorry, but no greek letters match your search string}\centerline{{\em ",ss,"}}\centerline{Click on the up-arrow to try again}") + htShowPage() + htInitPage(['"Greek letters matching search string {\em ",ss,'"}"],nil) + if nonmatches + then htSay('"The greek letters that {\em match} your search string {\em ",ss,'"}:") + else htSay('"Your search string {\em ",ss,"} matches all of the greek letters:") + htSay('"{\em \table{") + for x in matches repeat htSay('"{",x,'"}") + htSay('"}}\vspace{1}") + if nonmatches then + htSay('"The greek letters that {\em do not match} your search string:{\em \table{") + for x in nonmatches repeat htSay('"{",x,'"}") + htSay('"}}") + htShowPage() + +htTextSearch(filter) == + s := pmTransFilter dbNonEmptyPattern filter + s is ['error,:.] => bcErrorPage s + not s => errorPage(nil,[['"Missing search string"],nil, + '"\vspace{2}\centerline{To select one of the lines of text:}\newline ", + '"\centerline{{\em first} enter a search key into the input area}\newline ", + '"\centerline{{\em then } move the mouse cursor to the work {\em search} and click}"]) + filter := s + lines := ['"{{\em Fruit flies} *like* a {\em banana and califlower ears.}}", + '"{{\em Sneak Sears Silas with Savings Snatch}}"] + for x in lines repeat + superMatch?(filter,x) => matches := [x,:matches] + nonmatches := [x,:nonmatches] + matches := NREVERSE matches + nonmatches := NREVERSE nonmatches + htInitPage('"Text Matches",nil) + null matches => + htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) + htSay("\vspace{2}\centerline{Sorry, but no lines match your search string}\centerline{{\em ",s,"}}\centerline{Click on the up-arrow to try again}") + htShowPage() + htInitPage(['"Lines matching search string {\em ",s,'"}"],nil) + if nonmatches + then htSay('"The lines that {\em match} your search string {\em ",s,'"}:") + else htSay('"Your search string {\em ",s,"} matches both lines:") + htSay('"{\em \table{") + for x in matches repeat htSay('"{",x,'"}") + htSay('"}}\vspace{1}") + if nonmatches then + htSay('"The line that {\em does not match} your search string:{\em \table{") + for x in nonmatches repeat htSay('"{",x,'"}") + htSay('"}}") + htShowPage() + +htTutorialSearch pattern == + s := dbNonEmptyPattern pattern or return + errorPage(nil,['"Empty search key",nil,'"\vspace{3}\centerline{You must enter some search string"]) + s := mkUnixPattern s + source := '"$AXIOM/share/hypertex/pages/ht.db" + target :='"/tmp/temp.text.$SPADNUM" + OBEY STRCONC('"$AXIOM/lib/hthits",'" _"",s,'"_" ",source,'" > ",target) + lines := dbReadLines 'temp + htInitPageNoScroll(nil,['"Tutorial Pages mentioning {\em ",pattern,'"}"]) + htSay('"\beginscroll\table{") + for line in lines repeat + [name,title,.] := dbParts(line,3,0) + htSay ['"{\downlink{",title,'"}{",name,'"}}"] + htSay '"}" + htShowPage() + +mkUnixPattern s == + u := mkUpDownPattern s + starPositions := REVERSE [i for i in 1..(-1 + MAXINDEX u) | u.i = $wild] + for i in starPositions repeat + u := STRCONC(SUBSTRING(u,0,i),'".*",SUBSTRING(u,i + 1,nil)) + if u.0 ^= $wild then u := STRCONC('"[^a-zA-Z]",u) + else u := SUBSTRING(u,1,nil) + if u.(k := MAXINDEX u) ^= $wild then u := STRCONC(u,'"[^a-zA-Z]") + else u := SUBSTRING(u,0,k) + u + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/ht-util.boot.pamphlet b/src/interp/ht-util.boot.pamphlet new file mode 100644 index 00000000..f875959f --- /dev/null +++ b/src/interp/ht-util.boot.pamphlet @@ -0,0 +1,753 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp ht-util.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- HyperTeX Utilities for generating basic Command pages +--)package "BOOT" + +$bcParseOnly := true + +-- List of issued hypertex lines +$htLineList := nil + +-- pointer to the page we are currently defining +$curPage := nil + +-- List of currently active window named +$activePageList := nil + +htpDestroyPage(pageName) == + pageName in $activePageList => + SET(pageName, nil) + $activePageList := NREMOVE($activePageList, pageName) + +htpName htPage == +-- GENSYM whose value is the page + ELT(htPage, 0) + +htpSetName(htPage, val) == + SETELT(htPage, 0, val) + +htpDomainConditions htPage == +-- List of Domain conditions + ELT(htPage, 1) + +htpSetDomainConditions(htPage, val) == + SETELT(htPage, 1, val) + +htpDomainVariableAlist htPage == +-- alist of pattern variables and conditions + ELT(htPage, 2) + +htpSetDomainVariableAlist(htPage, val) == + SETELT(htPage, 2, val) + +htpDomainPvarSubstList htPage == +-- alist of user pattern variables to system vars + ELT(htPage, 3) + +htpSetDomainPvarSubstList(htPage, val) == + SETELT(htPage, 3, val) + +htpRadioButtonAlist htPage == +-- alist of radio button group names and labels + ELT(htPage, 4) + +htpButtonValue(htPage, groupName) == + for buttonName in LASSOC(groupName, htpRadioButtonAlist htPage) repeat + (stripSpaces htpLabelInputString(htPage, buttonName)) = '"t" => + return buttonName + +htpSetRadioButtonAlist(htPage, val) == + SETELT(htPage, 4, val) + +htpInputAreaAlist htPage == +-- Alist of input-area labels, and default values + ELT(htPage, 5) + +htpSetInputAreaAlist(htPage, val) == + SETELT(htPage, 5, val) + +htpAddInputAreaProp(htPage, label, prop) == + SETELT(htPage, 5, [[label, nil, nil, nil, :prop], :ELT(htPage, 5)]) + +htpPropertyList htPage == +-- Association list of user-defined properties + ELT(htPage, 6) + +htpProperty(htPage, propName) == + LASSOC(propName, ELT(htPage, 6)) + +htpSetProperty(htPage, propName, val) == + pair := ASSOC(propName, ELT(htPage, 6)) + pair => RPLACD(pair, val) + SETELT(htPage, 6, [[propName, :val], :ELT(htPage, 6)]) + +htpLabelInputString(htPage, label) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props and STRINGP (s := ELT(props,0)) => + s = '"" => s + trimString s + nil + +htpLabelFilteredInputString(htPage, label) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => + #props > 5 and ELT(props, 6) => + FUNCALL(SYMBOL_-FUNCTION ELT(props, 6), ELT(props, 0)) + replacePercentByDollar ELT(props, 0) + nil + +replacePercentByDollar s == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => '"" + (m := charPosition(char "%",s,i)) > n => SUBSTRING(s,i,nil) + STRCONC(SUBSTRING(s,i,m - i),'"$",fn(s,m + 1,n)) + +htpSetLabelInputString(htPage, label, val) == +------------------> OBSELETE +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 0, STRINGIMAGE val) + nil + +htpLabelSpadValue(htPage, label) == +-- Scratchpad value of parsed and evaled inputString, as (type . value) + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 1) + nil + +htpSetLabelSpadValue(htPage, label, val) == +-- value user typed as input string on page + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 1, val) + nil + +htpLabelErrorMsg(htPage, label) == +-- error message associated with input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 2) + nil + +htpSetLabelErrorMsg(htPage, label, val) == +-- error message associated with input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => SETELT(props, 2, val) + nil + +htpLabelType(htPage, label) == +-- either 'string or 'button + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 3) + nil + +htpLabelDefault(htPage, label) == +-- default value for the input area + msg := htpLabelInputString(htPage, label) => + msg = '"t" => 1 + msg = '"nil" => 0 + msg + props := LASSOC(label, htpInputAreaAlist htPage) + props => + ELT(props, 4) + nil + + +htpLabelSpadType(htPage, label) == +-- pattern variable for target domain for input area + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 5) + nil + +htpLabelFilter(htPage, label) == +-- string to string mapping applied to input area strings before parsing + props := LASSOC(label, htpInputAreaAlist htPage) + props => ELT(props, 6) + nil + +htpPageDescription htPage == +-- a list of all the commands issued to create the basic-command page + ELT(htPage, 7) + +htpSetPageDescription(htPage, pageDescription) == + SETELT(htPage, 7, pageDescription) + +htpAddToPageDescription(htPage, pageDescrip) == +-------------> OBSELETE <----------- + SETELT(htPage, 7, nconc(nreverse COPY_-LIST pageDescrip, ELT(htPage, 7))) + +iht line == +-- issue a single hyperteTeX line, or a group of lines + $newPage => nil + PAIRP line => + $htLineList := NCONC(nreverse mapStringize COPY_-LIST line, $htLineList) + $htLineList := [basicStringize line, :$htLineList] + +bcHt line == +--line = '"\##1" => harharhar() + iht line + PAIRP line => + if $newPage then htpAddToPageDescription($curPage, [['text, :line]]) + if $newPage then htpAddToPageDescription($curPage, [['text, line]]) + +bcIssueHt line == + PAIRP line => htMakePage1 line + iht line + +mapStringize l == + ATOM l => l + RPLACA(l, basicStringize CAR l) + RPLACD(l, mapStringize CDR l) + l + +basicStringize s == + STRINGP s => + s = '"\$" => '"\%" + s = '"{\em $}" => '"{\em \%}" + s + s = '_$ => '"\%" + PRINC_-TO_-STRING s + +stringize s == + STRINGP s => s + PRINC_-TO_-STRING s + +htInitPage(title, propList) == +----------------------------> OBSELETE---cannot return $curPage +-- start defining a hyperTeX page + htInitPageNoScroll(propList, title) + htSayStandard '"\beginscroll " + $curPage + + +--htInitPageNoHeading(propList) == +-----------------------> replaced by htInitPageNoScroll +-- start defining a hyperTeX page +-- $curPage := htpMakeEmptyPage(propList) +-- if $saturn then $saturnPage := htpMakeEmptyPage(propList) +-- $newPage := true +-- $htLineList := nil +-- $curPage + +htAddHeading(title) == +------------------------> OBSELETE + htNewPage title + $curPage + +htShowPage() == +-- show the page which has been computed + htSayStandard '"\endscroll" + htShowPageNoScroll() + +htShowPageNoScroll() == +------------------------> OBSELETE +-- show the page which has been computed + htSayStandard '"\autobuttons" + htpSetPageDescription($curPage, nreverse htpPageDescription $curPage) + $newPage := false + $htLineList := nil + htMakePage htpPageDescription $curPage + line := APPLY(function CONCAT, nreverse $htLineList) + issueHT line + endHTPage() + +htMakePage itemList == +------------------------> OBSELETE +-- make a page given the description in itemList + if $newPage then htpAddToPageDescription($curPage, itemList) + htMakePage1 itemList + +htMakePage1 itemList == +-- make a page given the description in itemList + for [itemType, :items] in itemList repeat + itemType = 'text => iht items + itemType = 'lispLinks => htLispLinks items + itemType = 'lispmemoLinks => htLispMemoLinks items + itemType = 'bcLinks => htBcLinks items ---> + itemType = 'bcLinksNS => htBcLinks(items,true) + itemType = 'bcLispLinks => htBcLispLinks items ---> + itemType = 'radioButtons => htRadioButtons items + itemType = 'bcRadioButtons => htBcRadioButtons items + itemType = 'inputStrings => htInputStrings items + itemType = 'domainConditions => htProcessDomainConditions items + itemType = 'bcStrings => htProcessBcStrings items + itemType = 'toggleButtons => htProcessToggleButtons items + itemType = 'bcButtons => htProcessBcButtons items + itemType = 'doneButton => htProcessDoneButton items + itemType = 'doitButton => htProcessDoitButton items + systemError ['"unknown itemType", itemType] + +htMakeErrorPage htPage == +------------------> OBSELETE + $newPage := false + $htLineList := nil + $curPage := htPage + htMakePage htpPageDescription htPage + line := APPLY(function CONCAT, nreverse $htLineList) + issueHT line + endHTPage() + +htQuote s == +-- wrap quotes around a piece of hyperTeX + iht '"_"" + iht s + iht '"_"" + +htProcessToggleButtons buttons == + iht '"\newline\indent{5}\beginitems " + for [message, info, defaultValue, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + iht ['"\item{\em\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}\space{}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + iht '"\enditems\indent{0} " + +htProcessBcButtons buttons == + for [defaultValue, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + k := htpLabelDefault($curPage,buttonName) + k = 0 => iht ['"\off{",buttonName,'"}"] + k = 1 => iht ['"\on{", buttonName,'"}"] + iht ['"\inputbox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{\htbmfile{pick}}{\htbmfile{unpick}}"] + +htProcessBcStrings strings == +---------------------> OBSELETE <------------------------ + for [numChars, default, stringName, spadType, :filter] in strings repeat + mess2 := '"" + if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then + setUpDefault(stringName, ['string, default, spadType, filter]) + if htpLabelErrorMsg($curPage, stringName) then + iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] + mess2 := CONCAT(mess2, bcSadFaces()) + htpSetLabelErrorMsg($curPage, stringName, nil) + iht ['"\inputstring{", stringName, '"}{", + numChars, '"}{", htpLabelDefault($curPage,stringName), '"} ", mess2] + +bcSadFaces() == + '"\space{1}{\em\htbitmap{error}\htbitmap{error}\htbitmap{error}}" + +htLispLinks(links,:option) == + [links,options] := beforeAfter('options,links) + indent := LASSOC('indent,options) or 5 + iht '"\newline\indent{" + iht stringize indent + iht '"}\beginitems" + for [message, info, func, :value] in links repeat + iht '"\item[" + call := (IFCAR option => '"\lispmemolink"; '"\lispdownlink") + htMakeButton(call,message, mkCurryFun(func, value)) + iht ['"]\space{}"] + bcIssueHt info + iht '"\enditems\indent{0} " + +htLispMemoLinks(links) == htLispLinks(links,true) + +htBcLinks(links,:options) == +-------------------------> OBSELETE + skipStateInfo? := IFCAR options + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + htMakeButton('"\lispdownlink",message, + mkCurryFun(func, value),skipStateInfo?) + bcIssueHt info + +htBcLispLinks links == +-------------------------> OBSELETE + [links,options] := beforeAfter('options,links) + for [message, info, func, :value] in links repeat + htMakeButton('"\lisplink",message, mkCurryFun(func, value)) + bcIssueHt info + +beforeAfter(x,u) == [[y for [y,:r] in tails u while x ^= y],r] + +mkCurryFun(fun, val) == + name := GENTEMP() + code := + ['DEFUN, name, '(arg), ['APPLY, MKQ fun, ['CONS, 'arg, MKQ val]]] + EVAL code + name + +htRadioButtons [groupName, :buttons] == + htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], + : htpRadioButtonAlist $curPage]) + boxesName := GENTEMP() + iht ['"\newline\indent{5}\radioboxes{", boxesName, + '"}{\htbmfile{pick}}{\htbmfile{unpick}}\beginitems "] + defaultValue := '"1" + for [message, info, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + defaultValue := '"0" + iht ['"\item{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{",boxesName, '"}\space{}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + iht '"\enditems\indent{0} " + +htBcRadioButtons [groupName, :buttons] == + htpSetRadioButtonAlist($curPage, [[groupName, :buttonNames buttons], + : htpRadioButtonAlist $curPage]) + boxesName := GENTEMP() + iht ['"\radioboxes{", boxesName, + '"}{\htbmfile{pick}}{\htbmfile{unpick}} "] + defaultValue := '"1" + for [message, info, buttonName] in buttons repeat + if NULL LASSOC(buttonName, htpInputAreaAlist $curPage) then + setUpDefault(buttonName, ['button, defaultValue]) + defaultValue := '"0" + iht ['"{\em\radiobox[", htpLabelDefault($curPage, buttonName), '"]{", + buttonName, '"}{",boxesName, '"}"] + bcIssueHt message + iht '"\space{}}" + bcIssueHt info + +setUpDefault(name, props) == +---------------> OBSELETE <---------------- + htpAddInputAreaProp($curPage, name, props) + +buttonNames buttons == + [buttonName for [.,., buttonName] in buttons] + +htInputStrings strings == + iht '"\newline\indent{5}\beginitems " + for [mess1, mess2, numChars, default, stringName, spadType, :filter] + in strings repeat + if NULL LASSOC(stringName, htpInputAreaAlist $curPage) then + setUpDefault(stringName, ['string, default, spadType, filter]) + if htpLabelErrorMsg($curPage, stringName) then + iht ['"\centerline{{\em ", htpLabelErrorMsg($curPage, stringName), '"}}"] + + mess2 := CONCAT(mess2, bcSadFaces()) + htpSetLabelErrorMsg($curPage, stringName, nil) + iht '"\item " + bcIssueHt mess1 + iht ['"\inputstring{", stringName, '"}{", + numChars, '"}{", htpLabelDefault($curPage,stringName), '"} "] + bcIssueHt mess2 + iht '"\enditems\indent{0}\newline " + +htProcessDomainConditions condList == + htpSetDomainConditions($curPage, renamePatternVariables condList) + htpSetDomainVariableAlist($curPage, computeDomainVariableAlist()) + +renamePatternVariables condList == + htpSetDomainPvarSubstList($curPage, + renamePatternVariables1(condList, nil, $PatternVariableList)) + substFromAlist(condList, htpDomainPvarSubstList $curPage) + +renamePatternVariables1(condList, substList, patVars) == + null condList => substList + [cond, :restConds] := condList + cond is ['isDomain, pv, pattern] or cond is ['ofCategory, pv, pattern] + or cond is ['Satisfies, pv, cond] => + if pv = $EmptyMode then nsubst := substList + else nsubst := [[pv, :car patVars], :substList] + renamePatternVariables1(restConds, nsubst, rest patVars) + substList + +substFromAlist(l, substAlist) == + for [pvar, :replace] in substAlist repeat + l := SUBST(replace, pvar, l) + l + +computeDomainVariableAlist() == + [[pvar, :pvarCondList pvar] for [., :pvar] in + htpDomainPvarSubstList $curPage] + +pvarCondList pvar == + nreverse pvarCondList1([pvar], nil, htpDomainConditions $curPage) + +pvarCondList1(pvarList, activeConds, condList) == + null condList => activeConds + [cond, : restConds] := condList + cond is [., pv, pattern] and pv in pvarList => + pvarCondList1(nconc(pvarList, pvarsOfPattern pattern), + [cond, :activeConds], restConds) + pvarCondList1(pvarList, activeConds, restConds) + +pvarsOfPattern pattern == + NULL LISTP pattern => nil + [pvar for pvar in rest pattern | pvar in $PatternVariableList] + +htMakeTemplates(templateList, numLabels) == + templateList := [templateParts template for template in templateList] + [[substLabel(i, template) for template in templateList] + for i in 1..numLabels] where substLabel(i, template) == + PAIRP template => + INTERN CONCAT(first template, PRINC_-TO_-STRING i, rest template) + template + +templateParts template == + NULL STRINGP template => template + i := SEARCH('"%l", template) + null i => template + [SUBSEQ(template, 0, i), : SUBSEQ(template, i+2)] + +htMakeDoneButton(message, func) == + bcHt '"\newline\vspace{1}\centerline{" + if message = '"Continue" then + bchtMakeButton('"\lispdownlink", "\ContinueBitmap", func) + else + bchtMakeButton('"\lispdownlink",CONCAT('"\box{", message, '"}"), func) + bcHt '"} " + +htProcessDoneButton [label , func] == + iht '"\newline\vspace{1}\centerline{" + + if label = '"Continue" then + htMakeButton('"\lispdownlink", "\ContinueBitmap", func) + else if label = '"Push to enter names" then + htMakeButton('"\lispdownlink",'"\ControlBitmap{ClickToSet}", func) + else + htMakeButton('"\lispdownlink", CONCAT('"\box{", label, '"}"), func) + + iht '"} " + +htMakeButton(htCommand, message, func,:options) == +----------> OBSELETE <---------------------------------- + skipStateInfo? := IFCAR options + iht [htCommand, '"{"] + bcIssueHt message + skipStateInfo? => + iht ['"}{(|htDoneButton| '|", func, '"| ",htpName $curPage, '")}"] + iht ['"}{(|htDoneButton| '|", func, '"| (PROGN "] + for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat + iht ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] + if type = 'string then + iht ['"_"\stringvalue{", id, '"}_""] + else + iht ['"_"\boxvalue{", id, '"}_""] + iht '") " + iht [htpName $curPage, '"))}"] + +bchtMakeButton(htCommand, message, func) == + bcHt [htCommand, '"{", message, + '"}{(|htDoneButton| '|", func, '"| (PROGN "] + for [id, ., ., ., type, :.] in htpInputAreaAlist $curPage repeat + bcHt ['"(|htpSetLabelInputString| ", htpName $curPage, '"'|", id, '"| "] + if type = 'string then + bcHt ['"_"\stringvalue{", id, '"}_""] + else + bcHt ['"_"\boxvalue{", id, '"}_""] + bcHt '") " + bcHt [htpName $curPage, '"))} "] + +htProcessDoitButton [label, command, func] == + fun := mkCurryFun(func, [command]) + iht '"\newline\vspace{1}\centerline{" + htMakeButton('"\lispcommand", CONCAT('"\box{", label, '"}"), fun) + iht '"} " + iht '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" + iht '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +htMakeDoitButton(label, command) == + -- use bitmap button if just plain old "Do It" + if label = '"Do It" then + bcHt '"\newline\vspace{1}\centerline{\lispcommand{\DoItBitmap}{(|doDoitButton| " + else + bcHt ['"\newline\vspace{1}\centerline{\lispcommand{\box{", label, + '"}}{(|doDoitButton| "] + bcHt htpName $curPage + bcHt ['" _"", htEscapeString command, '"_""] + bcHt '")}}" + + bcHt '"\vspace{2}{Select \ \UpButton{} \ to go back one page.}" + bcHt '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + +doDoitButton(htPage, command) == + executeInterpreterCommand command + +executeInterpreterCommand command == + PRINC command + TERPRI() + ncSetCurrentLine(command) + CATCH('SPAD__READER, parseAndInterpret command) + PRINC MKPROMPT() + FINISH_-OUTPUT() + +htDoneButton(func, htPage) == + typeCheckInputAreas htPage => + htMakeErrorPage htPage + NULL FBOUNDP func => + systemError ['"unknown function", func] + FUNCALL(SYMBOL_-FUNCTION func, htPage) + +typeCheckInputAreas htPage == + -- This needs to be severly beefed up + inputAlist := nil + errorCondition := false + for entry in htpInputAreaAlist htPage + | entry is [stringName, ., ., ., 'string, ., spadType, filter] repeat + condList := + LASSOC(LASSOC(spadType,htpDomainPvarSubstList htPage), + htpDomainVariableAlist htPage) + string := htpLabelFilteredInputString(htPage, stringName) + $bcParseOnly => + null ncParseFromString string => + htpSetLabelErrorMsg(htPage, '"Syntax Error", '"Syntax Error") + nil + val := checkCondition(htpLabelInputString(htPage, stringName), + string, condList) + STRINGP val => + errorCondition := true + htpSetLabelErrorMsg(htPage, stringName, val) + htpSetLabelSpadValue(htPage, stringName, val) + errorCondition + +checkCondition(s1, string, condList) == + condList is [['Satisfies, pvar, pred]] => + val := FUNCALL(pred, string) + STRINGP val => val + ['(String), :wrap s1] + condList isnt [['isDomain, pvar, pattern]] => + systemError '"currently invalid domain condition" + pattern is '(String) => ['(String), :wrap s1] + val := parseAndEval string + STRINGP val => + val = '"Syntax Error " => '"Error: Syntax Error " + condErrorMsg pattern + [type, : data] := val + newType := CATCH('SPAD__READER, resolveTM(type, pattern)) + null newType => + condErrorMsg pattern + coerceInt(val, newType) + +condErrorMsg type == + typeString := form2String type + if PAIRP typeString then typeString := APPLY(function CONCAT, typeString) + CONCAT('"Error: Could not make your input into a ", typeString) + +parseAndEval string == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + $QuietCommand:local := true + parseAndEval1 string + +parseAndEval1 string == + syntaxError := false + pform := + $useNewParser => + v := applyWithOutputToString('ncParseFromString, [string]) + CAR v => CAR v + syntaxError := true + CDR v + oldParseString string + syntaxError => + '"Syntax Error " + pform => + val := applyWithOutputToString('processInteractive, [pform, nil]) + CAR val => CAR val + '"Type Analysis Error" + nil + +oldParseString string == + tree := applyWithOutputToString('string2SpadTree, [string]) + CAR tree => parseTransform postTransform CAR tree + CDR tree + +makeSpadCommand(:l) == + opForm := CONCAT(first l, '"(") + lastArg := last l + l := rest l + argList := nil + for arg in l while arg ^= lastArg repeat + argList := [CONCAT(arg, '", "), :argList] + argList := nreverse [lastArg, :argList] + CONCAT(opForm, APPLY(function CONCAT, argList), '")") + +htMakeInputList stringList == +-- makes an input form for constructing a list + lastArg := last stringList + argList := nil + for arg in stringList while arg ^= lastArg repeat + argList := [CONCAT(arg, '", "), :argList] + argList := nreverse [lastArg, :argList] + bracketString APPLY(function CONCAT, argList) + + +-- predefined filter strings +bracketString string == CONCAT('"[",string,'"]") + +quoteString string == CONCAT('"_"", string, '"_"") + +$funnyQuote := char 127 +$funnyBacks := char 128 + +htEscapeString str == + str := SUBSTITUTE($funnyQuote, char '_", str) + SUBSTITUTE($funnyBacks, char '_\, str) + +unescapeStringsInForm form == + STRINGP form => + str := NSUBSTITUTE(char '_", $funnyQuote, form) + NSUBSTITUTE(char '_\, $funnyBacks, str) + CONSP form => + unescapeStringsInForm CAR form + unescapeStringsInForm CDR form + form + form + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/htcheck.boot b/src/interp/htcheck.boot deleted file mode 100644 index b1cdb2dd..00000000 --- a/src/interp/htcheck.boot +++ /dev/null @@ -1,127 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -$primitiveHtCommands := '( - ("\ContinueButton" . 1) - ("\andexample" . 1) - ("\autobutt" . 0) - ("\autobuttons". 0) - ("\begin" . 1) - ("\beginscroll". 0) - ("\bound" . 1) - ("\fbox" . 1) - ("\centerline" . 1) - ("\downlink" . 2) - ("\em" . 0) - ("\end" . 1) - ("\endscroll" . 0) - ("\example" . 1) - ("\free" . 1) - ("\graphpaste" . 1) - ("\helppage" . 1) - ("\htbmdir" . 0) - ("\htbmfile" . 1) - ("\indent" . 1) - ("\inputbitmap" . 1) - ("\inputstring" . 3) - ("\item" . 0) - ("\keyword" . 1) - ("\link" . 2) - ("\lispdownlink" . 2) - ("\lispmemolink" . 2) - ("\lispwindowlink" . 2) - ("\menudownlink" . 2) - ("\menuitemstyle" . 1) - ("\menulink" . 2) - ("\menulispdownlink" . 2) - ("\menulispmemolink" . 2) - ("\menulispwindowlink" . 2) - ("\menumemolink" . 2) - ("\menuwindowlink" . 2) - ("\newline" . 0) - ("\radioboxes" . 3) - ("\space" . 1) - ("\spadcommand" . 1) - ("\stringvalue" . 1) - ("\tab" . 1) - ("\table" . 1) - ("\vspace" . 1) - ("\windowlink" . 2)) - -buildHtMacroTable() == - $htMacroTable := MAKE_-HASHTABLE 'UEQUAL - fn := CONCAT(getEnv '"AXIOM", '"/share/hypertex/pages/util.ht") - if PROBE_-FILE(fn) then - instream := MAKE_-INSTREAM fn - while not EOFP instream repeat - line := READLINE instream - getHtMacroItem line is [string,:numOfArgs] => - HPUT($htMacroTable,string,numOfArgs) - for [s,:n] in $primitiveHtCommands repeat HPUT($htMacroTable,s,n) - else - sayBrightly '"Warning: macro table not found" - $htMacroTable - -getHtMacroItem line == - null stringPrefix?('"\newcommand{",line) => nil - k := charPosition(char '_},line,11) - command := SUBSTRING(line,12,k - 12) - numOfArgs := - m := #line - i := charPosition(char '_[,line,k) - i = m => 0 - j := charPosition(char '_],line,i + 1) - digitString := SUBSTRING(line,i + 1,j - i - 1) - and/[DIGITP digitString.i for i in 0..MAXINDEX digitString] - => PARSE_-INTEGER digitString - return nil - [command,:numOfArgs] - -spadSysChoose(tree,form) == --tree is ((word . tree) ..) - null form => true - null tree => false - lookupOn := - form is [key,arg] => key - form - newTree := LASSOC(lookupOn,tree) => spadSysBranch(newTree,IFCAR IFCDR form) - false - -spadSysBranch(tree,arg) == --tree is (msg kind TREEorSomethingElse ...) - null arg => true - kind := tree.2 - kind = 'TREE => spadSysChoose(tree.4,arg) - kind = 'LITERALS => member(arg,tree.4) - kind = 'INTEGER => INTEGERP arg - kind = 'FUNCTION => atom arg - systemError '"unknown tree branch" - -buildHtMacroTable() diff --git a/src/interp/htcheck.boot.pamphlet b/src/interp/htcheck.boot.pamphlet new file mode 100644 index 00000000..d2dd018c --- /dev/null +++ b/src/interp/htcheck.boot.pamphlet @@ -0,0 +1,153 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/htcheck.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +$primitiveHtCommands := '( + ("\ContinueButton" . 1) + ("\andexample" . 1) + ("\autobutt" . 0) + ("\autobuttons". 0) + ("\begin" . 1) + ("\beginscroll". 0) + ("\bound" . 1) + ("\fbox" . 1) + ("\centerline" . 1) + ("\downlink" . 2) + ("\em" . 0) + ("\end" . 1) + ("\endscroll" . 0) + ("\example" . 1) + ("\free" . 1) + ("\graphpaste" . 1) + ("\helppage" . 1) + ("\htbmdir" . 0) + ("\htbmfile" . 1) + ("\indent" . 1) + ("\inputbitmap" . 1) + ("\inputstring" . 3) + ("\item" . 0) + ("\keyword" . 1) + ("\link" . 2) + ("\lispdownlink" . 2) + ("\lispmemolink" . 2) + ("\lispwindowlink" . 2) + ("\menudownlink" . 2) + ("\menuitemstyle" . 1) + ("\menulink" . 2) + ("\menulispdownlink" . 2) + ("\menulispmemolink" . 2) + ("\menulispwindowlink" . 2) + ("\menumemolink" . 2) + ("\menuwindowlink" . 2) + ("\newline" . 0) + ("\radioboxes" . 3) + ("\space" . 1) + ("\spadcommand" . 1) + ("\stringvalue" . 1) + ("\tab" . 1) + ("\table" . 1) + ("\vspace" . 1) + ("\windowlink" . 2)) + +buildHtMacroTable() == + $htMacroTable := MAKE_-HASHTABLE 'UEQUAL + fn := CONCAT(getEnv '"AXIOM", '"/share/hypertex/pages/util.ht") + if PROBE_-FILE(fn) then + instream := MAKE_-INSTREAM fn + while not EOFP instream repeat + line := READLINE instream + getHtMacroItem line is [string,:numOfArgs] => + HPUT($htMacroTable,string,numOfArgs) + for [s,:n] in $primitiveHtCommands repeat HPUT($htMacroTable,s,n) + else + sayBrightly '"Warning: macro table not found" + $htMacroTable + +getHtMacroItem line == + null stringPrefix?('"\newcommand{",line) => nil + k := charPosition(char '_},line,11) + command := SUBSTRING(line,12,k - 12) + numOfArgs := + m := #line + i := charPosition(char '_[,line,k) + i = m => 0 + j := charPosition(char '_],line,i + 1) + digitString := SUBSTRING(line,i + 1,j - i - 1) + and/[DIGITP digitString.i for i in 0..MAXINDEX digitString] + => PARSE_-INTEGER digitString + return nil + [command,:numOfArgs] + +spadSysChoose(tree,form) == --tree is ((word . tree) ..) + null form => true + null tree => false + lookupOn := + form is [key,arg] => key + form + newTree := LASSOC(lookupOn,tree) => spadSysBranch(newTree,IFCAR IFCDR form) + false + +spadSysBranch(tree,arg) == --tree is (msg kind TREEorSomethingElse ...) + null arg => true + kind := tree.2 + kind = 'TREE => spadSysChoose(tree.4,arg) + kind = 'LITERALS => member(arg,tree.4) + kind = 'INTEGER => INTEGERP arg + kind = 'FUNCTION => atom arg + systemError '"unknown tree branch" + +buildHtMacroTable() +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot deleted file mode 100644 index 0698ec1d..00000000 --- a/src/interp/htsetvar.boot +++ /dev/null @@ -1,478 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -htsv() == - startHTPage(50) - htSetVars() - -htSetVars() == - $path := nil - $lastTree := nil - if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) - htShowSetTree($setOptions) - -htShowSetTree(setTree) == - $path := TAKE(- LASTATOM setTree,$path) - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page, 'setTree, setTree) - links := nil - maxWidth1 := maxWidth2 := 0 - for setData in setTree repeat - satisfiesUserLevel setData.setLevel => - okList := [setData,:okList] - maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) - maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) - maxWidth1 := MAX(9,maxWidth1) - maxWidth2 := MAX(41,maxWidth2) - tabset1 := STRINGIMAGE (maxWidth1) - tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) - htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") - for setData in REVERSE okList repeat - htSay '"\item" - label := STRCONC('"\menuitemstyle{",setData.setName,'"}") - links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], - 'htShowSetPage, setData.setName] - htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] - htSay '"\enditems" - htShowPage() - -htShowCount s == --# discounting {\em .. } - m := #s - m < 8 => m - 1 - i := 0 - count := 0 - while i < m - 7 repeat - s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e - and s.(i+3) = char 'm => i := i + 6 --discount {\em } - i := i + 1 - count := count + 1 - count + (m - i) - -htShowSetTreeValue(setData) == - st := setData.setType - st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") - st = 'INTEGER => object2String eval setData.setVar - st = 'STRING => object2String eval setData.setVar - st = 'LITERALS => - object2String translateTrueFalse2YesNo eval setData.setVar - st = 'TREE => '"..." - systemError() - -mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") - -listOfStrings2String u == - null u => '"" - STRCONC(listOfStrings2String rest u,'" ",stringize first u) - -htShowSetPage(htPage, branch) == - setTree := htpProperty(htPage, 'setTree) - $path := [branch,:TAKE(- LASTATOM setTree,$path)] - setData := ASSOC(branch, setTree) - null setData => - systemError('"No Set Data") - st := setData.setType - st = 'FUNCTION => htShowFunctionPage(htPage, setData) - st = 'INTEGER => htShowIntegerPage(htPage,setData) - st = 'LITERALS => htShowLiteralsPage(htPage, setData) - st = 'TREE => htShowSetTree(setData.setLeaf) - - st = 'STRING => -- have to add this - htSetNotAvailable(htPage,'")set compiler") - - systemError '"Unknown data type" - -htShowLiteralsPage(htPage, setData) == - htSetLiterals(htPage,setData.setName,setData.setLabel, - setData.setVar,setData.setLeaf,'htSetLiteral) - -htSetLiterals(htPage,name,message,variable,values,functionToCall) == - page := htInitPage('"Set Command", htpPropertyList htPage) - htpSetProperty(page, 'variable, variable) - bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - bcHt '"Select one of the following: \newline\tab{3} " - links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] - htMakePage [['bcLispLinks, :links]] - bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", - translateTrueFalse2YesNo EVAL variable, '"} "] - htShowPage() - -htSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htKill(htPage,val) - -htShowIntegerPage(htPage, setData) == - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - htpSetProperty(page, 'variable, setData.setVar) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] --- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel - message := setData.setLabel - bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] - [$htInitial,$htFinal] := setData.setLeaf - if $htFinal = $htInitial + 1 - then - bcHt '"Enter the integer {\em " - bcHt stringize $htInitial - bcHt '"} or {\em " - bcHt stringize $htFinal - bcHt '"}:" - else if null $htFinal then - bcHt '"Enter an integer greater than {\em " - bcHt stringize ($htInitial - 1) - bcHt '"}:" - else - bcHt '"Enter an integer between {\em " - bcHt stringize $htInitial - bcHt '"} and {\em " - bcHt stringize $htFinal - bcHt '"}:" - htMakePage [ - '(domainConditions (Satisfies S chkRange)), - ['bcStrings,[5,eval setData.setVar,'value,'S]]] - htSetvarDoneButton('"Select to Set Value",'htSetInteger) - htShowPage() - -htSetInteger(htPage) == - htInitPage(mkSetTitle(), nil) - val := chkRange htpLabelInputString(htPage,'value) - not INTEGERP val => - errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) - SET(htpProperty(htPage, 'variable), val) - htKill(htPage,val) - -htShowFunctionPage(htPage,setData) == - fn := setData.setDef => FUNCALL(fn,htPage) - htpSetProperty(htPage,'setData,setData) - htpSetProperty(htPage,'parts, setData.setLeaf) - htShowFunctionPageContinued(htPage) - -htShowFunctionPageContinued(htPage) == - parts := htpProperty(htPage,'parts) - setData := htpProperty(htPage,'setData) - [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts - htpSetProperty(htPage, 'variable, variable) - htpSetProperty(htPage, 'checker, checker) - htpSetProperty(htPage, 'parts, restParts) - kind = 'LITERALS => htSetLiterals(htPage,setData.setName, - phrase,variable,checker,'htFunctionSetLiteral) - page := htInitPage(mkSetTitle(), htpPropertyList htPage) - bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] - bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] - currentValue := EVAL variable - htMakePage - [ ['domainConditions, ['Satisfies,'S,checker]], - ['text,:phrase], - ['inputStrings, - [ '"", '"", 60, currentValue, 'value, 'S]]] - htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) - htShowPage() - -htSetvarDoneButton(message, func) == - bcHt '"\newline\vspace{1}\centerline{" - - if message = '"Select to Set Value" or message = '"Select to Set Values" then - bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func) - else - bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) - - bcHt '"} " - - -htFunctionSetLiteral(htPage, val) == - htInitPage('"Set Command", nil) - SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) - htSetFunCommandContinue(htPage,val) - -htSetFunCommand(htPage) == - variable := htpProperty(htPage,'variable) - checker := htpProperty(htPage,'checker) - value := htCheck(checker,htpLabelInputString(htPage,'value)) - SET(variable,value) --kill this later - htSetFunCommandContinue(htPage,value) - -htSetFunCommandContinue(htPage,value) == - parts := htpProperty(htPage,'parts) - continue := - null parts => false - parts is [['break,predicate],:restParts] => eval predicate - true - continue => - htpSetProperty(htPage,'parts,restParts) - htShowFunctionPageContinued(htPage) - htKill(htPage,value) - -htKill(htPage,value) == - htInitPage('"System Command", nil) - string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") - htMakePage [ - '(text - "{Here is the AXIOM system command you could have issued:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline\rm")) - htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" - htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htSetNotAvailable(htPage,whatToType) == - page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) - htInitPage('"Unavailable System Command", nil) - string := STRCONC('"{\em ",whatToType,'"}") - htMakePage [ - '(text "\vspace{1}\newline" - "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" - "\vspace{2}\newline\centerline{\tt"), - ['text,:string]] - htMakePage '((text . "}\vspace{1}\newline")) - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htDoNothing(htPage,command) == nil - -htCheck(checker,value) == - PAIRP checker => htCheckList(checker,parseWord value) - FUNCALL(checker,value) - -parseWord x == - STRINGP x => - and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x - INTERN x - x - -htCheckList(checker,value) == - if value in '(y ye yes Y YE YES) then value := 'yes - if value in '(n no N NO) then value := 'no - checker is [n,m] and INTEGERP n => - m = n + 1 => - value in checker => value - n - null m => - INTEGERP value and value >= n => value - n - INTEGERP m => - INTEGERP value and value >= n and value <= m => value - n - value in checker => value - first checker --- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] --- STRCONC('"Please enter one of: ",emlist) - -translateYesNoToTrueFalse x == - x = 'yes => true - x = 'no => false - x - -chkNameList x == - u := bcString2ListWords x - parsedNames := [ncParseFromString x for x in u] - and/[IDENTP x for x in parsedNames] => parsedNames - '"Please enter a list of identifiers separated by blanks" - -chkPosInteger s == - (u := parseOnly s) and INTEGERP u and u > 0 => u - '"Please enter a positive integer" - -chkOutputFileName s == - bcString2WordList s in '(CONSOLE console) => 'console - chkDirectory s - -chkDirectory s == s - -chkNonNegativeInteger s == - (u := ncParseFromString s) and INTEGERP u and u >= 0 => u - '"Please enter a non-negative integer" - -chkRange s == - (u := ncParseFromString s) and INTEGERP u - and u >= $htInitial and (NULL $htFinal or u <= $htFinal) - => u - null $htFinal => - STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) - STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", - stringize $htFinal) - -chkAllNonNegativeInteger s == - (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL - or chkNonNegativeInteger s - or '"Please enter {\em all} or a non-negative integer" - -htMakePathKey path == - null path => systemError '"path is not set" - INTERN fn(PNAME first path,rest path) where - fn(a,b) == - null b => a - fn(STRCONC(a,'".",PNAME first b),rest b) - -htMarkTree(tree,n) == - RPLACD(LASTTAIL tree,n) - for branch in tree repeat - branch.3 = 'TREE => htMarkTree(branch.5,n + 1) - -htSetHistory htPage == - msg := "when the history facility is on (yes), results of computations are saved in memory" - data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] - htShowLiteralsPage(htPage,data) - -htSetOutputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler output") - -htSetInputLibrary htPage == - htSetNotAvailable(htPage,'")set compiler input") - -htSetExpose htPage == - htSetNotAvailable(htPage,'")set expose") - -htSetKernelProtect htPage == - htSetNotAvailable(htPage,'")set kernel protect") - -htSetKernelWarn htPage == - htSetNotAvailable(htPage,'")set kernel warn") - -htSetOutputCharacters htPage == - htSetNotAvailable(htPage,'")set output characters") - -htSetLinkerArgs htPage == - htSetNotAvailable(htPage,'")set fortran calling linker") - -htSetCache(htPage,:options) == - $path := '(functions cache) - htPage := htInitPage(mkSetTitle(),nil) - $valueList := nil - htMakePage '( - (text - "Use this system command to cause the AXIOM interpreter to `remember' " - "past values of interpreter functions. " - "To remember a past value of a function, the interpreter " - "sets up a {\em cache} for that function based on argument values. " - "When a value is cached for a given argument value, its value is gotten " - "from the cache and not recomputed. Caching can often save much " - "computing time, particularly with recursive functions or functions that " - "are expensive to compute and that are called repeatedly " - "with the same argument." - "\vspace{1}\newline ") - (domainConditions (Satisfies S chkNameList)) - (text - "Enter below a list of interpreter functions you would like specially cached. " - "Use the name {\em all} to give a default setting for all " - "interpreter functions. " - "\vspace{1}\newline " - "Enter {\em all} or a list of names (separate names by blanks):") - (inputStrings ("" "" 60 "all" names S)) - (doneButton "Push to enter names" htCacheAddChoice)) - htShowPage() - -htCacheAddChoice htPage == - names := bcString2WordList htpLabelInputString(htPage,'names) - $valueList := [listOfStrings2String names,:$valueList] - null names => htCacheAddQuery() - null rest names => htCacheOne names - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "For each function, enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. " - "A cache length of {\em 0} means the function won't be cached. " - "To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline " - "For each function name, enter {\em all} or a positive integer:")) - for i in 1.. for name in names repeat htMakePage [ - ['inputStrings, - [STRCONC('"Function {\em ",name,'"} will cache"), - '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] - htSetvarDoneButton('"Select to Set Values",'htCacheSet) - htShowPage() - -htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) - -htCacheSet htPage == - names := htpProperty(htPage,'names) - for i in 1.. for name in names repeat - num := chkAllNonNegativeInteger - htpLabelInputString(htPage,htMakeLabel('"c",i)) - $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) - if (n := LASSOC('all,$cacheAlist)) then - $cacheCount := n - $cacheAlist := deleteAssoc('all,$cacheAlist) - htInitPage('"Cache Summary",nil) - bcHt '"In general, interpreter functions " - bcHt - $cacheCount = 0 => "will {\em not} be cached." - bcHt '"cache " - htAllOrNum $cacheCount - '"} values." - bcHt '"\vspace{1}\newline " - if $cacheAlist then --- bcHt '" However, \indent{3}" - for [name,:val] in $cacheAlist | val ^= $cacheCount repeat - bcHt '"\newline function {\em " - bcHt stringize name - bcHt '"} will cache " - htAllOrNum val - bcHt '"} values" - htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] - htShowPage() - -htAllOrNum val == bcHt - val = 'all => '"{\em all" - val = 0 => '"{\em no" - STRCONC('"the last {\em ",stringize val) - -htCacheOne names == - page := htInitPage(mkSetTitle(),nil) - htpSetProperty(page,'names,names) - htMakePage '( - (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) - (text - "Enter below a {\em cache length}, a positive integer. " - "This number tells how many past values will " - "be cached. To cache all past values, " - "enter {\em all}." - "\vspace{1}\newline ") - (inputStrings - ("Enter {\em all} or a positive integer:" - "" 5 10 c1 ALLPI))) - htSetvarDoneButton('"Select to Set Value",'htCacheSet) - htShowPage() - - - - - - - - diff --git a/src/interp/htsetvar.boot.pamphlet b/src/interp/htsetvar.boot.pamphlet new file mode 100644 index 00000000..0d664ff9 --- /dev/null +++ b/src/interp/htsetvar.boot.pamphlet @@ -0,0 +1,500 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp htsetvar.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +htsv() == + startHTPage(50) + htSetVars() + +htSetVars() == + $path := nil + $lastTree := nil + if 0 ^= LASTATOM $setOptions then htMarkTree($setOptions,0) + htShowSetTree($setOptions) + +htShowSetTree(setTree) == + $path := TAKE(- LASTATOM setTree,$path) + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page, 'setTree, setTree) + links := nil + maxWidth1 := maxWidth2 := 0 + for setData in setTree repeat + satisfiesUserLevel setData.setLevel => + okList := [setData,:okList] + maxWidth1 := MAX(# PNAME setData.setName,maxWidth1) + maxWidth2 := MAX(htShowCount STRINGIMAGE setData.setLabel,maxWidth2) + maxWidth1 := MAX(9,maxWidth1) + maxWidth2 := MAX(41,maxWidth2) + tabset1 := STRINGIMAGE (maxWidth1) + tabset2 := STRINGIMAGE (maxWidth2 + maxWidth1 - 1) + htSay('"\tab{2}\newline Variable\tab{",STRINGIMAGE (maxWidth1 + (maxWidth2/3)),'"}Description\tab{",STRINGIMAGE(maxWidth2 + maxWidth1 + 2),'"}Value\newline\beginitems ") + for setData in REVERSE okList repeat + htSay '"\item" + label := STRCONC('"\menuitemstyle{",setData.setName,'"}") + links := [label,[['text,'"\tab{",tabset1,'"}",setData.setLabel,'"\tab{",tabset2,'"}{\em ",htShowSetTreeValue setData,'"}"]], + 'htShowSetPage, setData.setName] + htMakePage [['bcLispLinks, links,'options,'(indent . 0)]] + htSay '"\enditems" + htShowPage() + +htShowCount s == --# discounting {\em .. } + m := #s + m < 8 => m - 1 + i := 0 + count := 0 + while i < m - 7 repeat + s.i = char '_{ and s.(i+1) = char '_\ and s.(i+2) = char 'e + and s.(i+3) = char 'm => i := i + 6 --discount {\em } + i := i + 1 + count := count + 1 + count + (m - i) + +htShowSetTreeValue(setData) == + st := setData.setType + st = 'FUNCTION => object2String FUNCALL(setData.setVar,"%display%") + st = 'INTEGER => object2String eval setData.setVar + st = 'STRING => object2String eval setData.setVar + st = 'LITERALS => + object2String translateTrueFalse2YesNo eval setData.setVar + st = 'TREE => '"..." + systemError() + +mkSetTitle() == STRCONC('"Command {\em )set ",listOfStrings2String $path,'"}") + +listOfStrings2String u == + null u => '"" + STRCONC(listOfStrings2String rest u,'" ",stringize first u) + +htShowSetPage(htPage, branch) == + setTree := htpProperty(htPage, 'setTree) + $path := [branch,:TAKE(- LASTATOM setTree,$path)] + setData := ASSOC(branch, setTree) + null setData => + systemError('"No Set Data") + st := setData.setType + st = 'FUNCTION => htShowFunctionPage(htPage, setData) + st = 'INTEGER => htShowIntegerPage(htPage,setData) + st = 'LITERALS => htShowLiteralsPage(htPage, setData) + st = 'TREE => htShowSetTree(setData.setLeaf) + + st = 'STRING => -- have to add this + htSetNotAvailable(htPage,'")set compiler") + + systemError '"Unknown data type" + +htShowLiteralsPage(htPage, setData) == + htSetLiterals(htPage,setData.setName,setData.setLabel, + setData.setVar,setData.setLeaf,'htSetLiteral) + +htSetLiterals(htPage,name,message,variable,values,functionToCall) == + page := htInitPage('"Set Command", htpPropertyList htPage) + htpSetProperty(page, 'variable, variable) + bcHt ['"\centerline{Set {\em ", name, '"}}\newline"] + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + bcHt '"Select one of the following: \newline\tab{3} " + links := [[STRCONC('"",STRINGIMAGE opt), '"\newline\tab{3}", functionToCall, opt] for opt in values] + htMakePage [['bcLispLinks, :links]] + bcHt ["\indent{0}\newline\vspace{1} The current setting is: {\em ", + translateTrueFalse2YesNo EVAL variable, '"} "] + htShowPage() + +htSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htKill(htPage,val) + +htShowIntegerPage(htPage, setData) == + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + htpSetProperty(page, 'variable, setData.setVar) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] +-- message := isKeyedMsgInDb($path,'(setvar text A)) or setData.setLabel + message := setData.setLabel + bcHt ['"{\em Description: } ", message, '"\newline\vspace{1} "] + [$htInitial,$htFinal] := setData.setLeaf + if $htFinal = $htInitial + 1 + then + bcHt '"Enter the integer {\em " + bcHt stringize $htInitial + bcHt '"} or {\em " + bcHt stringize $htFinal + bcHt '"}:" + else if null $htFinal then + bcHt '"Enter an integer greater than {\em " + bcHt stringize ($htInitial - 1) + bcHt '"}:" + else + bcHt '"Enter an integer between {\em " + bcHt stringize $htInitial + bcHt '"} and {\em " + bcHt stringize $htFinal + bcHt '"}:" + htMakePage [ + '(domainConditions (Satisfies S chkRange)), + ['bcStrings,[5,eval setData.setVar,'value,'S]]] + htSetvarDoneButton('"Select to Set Value",'htSetInteger) + htShowPage() + +htSetInteger(htPage) == + htInitPage(mkSetTitle(), nil) + val := chkRange htpLabelInputString(htPage,'value) + not INTEGERP val => + errorPage(htPage,['"Value Error",nil,'"\vspace{3}\centerline{{\em ",val,'"}}\vspace{2}\newline\centerline{Click on \UpBitmap{} to re-enter value}"]) + SET(htpProperty(htPage, 'variable), val) + htKill(htPage,val) + +htShowFunctionPage(htPage,setData) == + fn := setData.setDef => FUNCALL(fn,htPage) + htpSetProperty(htPage,'setData,setData) + htpSetProperty(htPage,'parts, setData.setLeaf) + htShowFunctionPageContinued(htPage) + +htShowFunctionPageContinued(htPage) == + parts := htpProperty(htPage,'parts) + setData := htpProperty(htPage,'setData) + [[phrase,kind,variable,checker,initValue,:.],:restParts] := parts + htpSetProperty(htPage, 'variable, variable) + htpSetProperty(htPage, 'checker, checker) + htpSetProperty(htPage, 'parts, restParts) + kind = 'LITERALS => htSetLiterals(htPage,setData.setName, + phrase,variable,checker,'htFunctionSetLiteral) + page := htInitPage(mkSetTitle(), htpPropertyList htPage) + bcHt ['"\centerline{Set {\em ", setData.setName, '"}}\newline"] + bcHt ['"{\em Description: } ", setData.setLabel, '"\newline\vspace{1} "] + currentValue := EVAL variable + htMakePage + [ ['domainConditions, ['Satisfies,'S,checker]], + ['text,:phrase], + ['inputStrings, + [ '"", '"", 60, currentValue, 'value, 'S]]] + htSetvarDoneButton('"Select To Set Value",'htSetFunCommand) + htShowPage() + +htSetvarDoneButton(message, func) == + bcHt '"\newline\vspace{1}\centerline{" + + if message = '"Select to Set Value" or message = '"Select to Set Values" then + bchtMakeButton('"\lisplink",'"\ControlBitmap{ClickToSet}", func) + else + bchtMakeButton('"\lisplink",CONCAT('"\fbox{", message, '"}"), func) + + bcHt '"} " + + +htFunctionSetLiteral(htPage, val) == + htInitPage('"Set Command", nil) + SET(htpProperty(htPage, 'variable), translateYesNo2TrueFalse val) + htSetFunCommandContinue(htPage,val) + +htSetFunCommand(htPage) == + variable := htpProperty(htPage,'variable) + checker := htpProperty(htPage,'checker) + value := htCheck(checker,htpLabelInputString(htPage,'value)) + SET(variable,value) --kill this later + htSetFunCommandContinue(htPage,value) + +htSetFunCommandContinue(htPage,value) == + parts := htpProperty(htPage,'parts) + continue := + null parts => false + parts is [['break,predicate],:restParts] => eval predicate + true + continue => + htpSetProperty(htPage,'parts,restParts) + htShowFunctionPageContinued(htPage) + htKill(htPage,value) + +htKill(htPage,value) == + htInitPage('"System Command", nil) + string := STRCONC('"{\em )set ",listOfStrings2String [value,:$path],'"}") + htMakePage [ + '(text + "{Here is the AXIOM system command you could have issued:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline\rm")) + htSay '"\vspace{2}{Select \ \UpButton{} \ to go back.}" + htSay '"\newline{Select \ \ExitButton{QuitPage} \ to remove this window.}" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htSetNotAvailable(htPage,whatToType) == + page := htInitPage('"Unavailable Set Command", htpPropertyList htPage) + htInitPage('"Unavailable System Command", nil) + string := STRCONC('"{\em ",whatToType,'"}") + htMakePage [ + '(text "\vspace{1}\newline" + "{Sorry, but this system command is not available through HyperDoc. Please directly issue this command in an AXIOM window for more information:}" + "\vspace{2}\newline\centerline{\tt"), + ['text,:string]] + htMakePage '((text . "}\vspace{1}\newline")) + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htDoNothing(htPage,command) == nil + +htCheck(checker,value) == + PAIRP checker => htCheckList(checker,parseWord value) + FUNCALL(checker,value) + +parseWord x == + STRINGP x => + and/[DIGITP x.i for i in 0..MAXINDEX x] => PARSE_-INTEGER x + INTERN x + x + +htCheckList(checker,value) == + if value in '(y ye yes Y YE YES) then value := 'yes + if value in '(n no N NO) then value := 'no + checker is [n,m] and INTEGERP n => + m = n + 1 => + value in checker => value + n + null m => + INTEGERP value and value >= n => value + n + INTEGERP m => + INTEGERP value and value >= n and value <= m => value + n + value in checker => value + first checker +-- emlist := "STRCONC"/[STRCONC('" {\em ",PNAME x,'"} ") for x in checker] +-- STRCONC('"Please enter one of: ",emlist) + +translateYesNoToTrueFalse x == + x = 'yes => true + x = 'no => false + x + +chkNameList x == + u := bcString2ListWords x + parsedNames := [ncParseFromString x for x in u] + and/[IDENTP x for x in parsedNames] => parsedNames + '"Please enter a list of identifiers separated by blanks" + +chkPosInteger s == + (u := parseOnly s) and INTEGERP u and u > 0 => u + '"Please enter a positive integer" + +chkOutputFileName s == + bcString2WordList s in '(CONSOLE console) => 'console + chkDirectory s + +chkDirectory s == s + +chkNonNegativeInteger s == + (u := ncParseFromString s) and INTEGERP u and u >= 0 => u + '"Please enter a non-negative integer" + +chkRange s == + (u := ncParseFromString s) and INTEGERP u + and u >= $htInitial and (NULL $htFinal or u <= $htFinal) + => u + null $htFinal => + STRCONC('"Please enter an integer greater than ",stringize ($htInitial - 1)) + STRCONC('"Please enter an integer between ",stringize $htInitial,'" and ", + stringize $htFinal) + +chkAllNonNegativeInteger s == + (u := ncParseFromString s) and u in '(a al all A AL ALL) and 'ALL + or chkNonNegativeInteger s + or '"Please enter {\em all} or a non-negative integer" + +htMakePathKey path == + null path => systemError '"path is not set" + INTERN fn(PNAME first path,rest path) where + fn(a,b) == + null b => a + fn(STRCONC(a,'".",PNAME first b),rest b) + +htMarkTree(tree,n) == + RPLACD(LASTTAIL tree,n) + for branch in tree repeat + branch.3 = 'TREE => htMarkTree(branch.5,n + 1) + +htSetHistory htPage == + msg := "when the history facility is on (yes), results of computations are saved in memory" + data := ['history,msg,'history,'LITERALS,'$HiFiAccess,'(on off yes no)] + htShowLiteralsPage(htPage,data) + +htSetOutputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler output") + +htSetInputLibrary htPage == + htSetNotAvailable(htPage,'")set compiler input") + +htSetExpose htPage == + htSetNotAvailable(htPage,'")set expose") + +htSetKernelProtect htPage == + htSetNotAvailable(htPage,'")set kernel protect") + +htSetKernelWarn htPage == + htSetNotAvailable(htPage,'")set kernel warn") + +htSetOutputCharacters htPage == + htSetNotAvailable(htPage,'")set output characters") + +htSetLinkerArgs htPage == + htSetNotAvailable(htPage,'")set fortran calling linker") + +htSetCache(htPage,:options) == + $path := '(functions cache) + htPage := htInitPage(mkSetTitle(),nil) + $valueList := nil + htMakePage '( + (text + "Use this system command to cause the AXIOM interpreter to `remember' " + "past values of interpreter functions. " + "To remember a past value of a function, the interpreter " + "sets up a {\em cache} for that function based on argument values. " + "When a value is cached for a given argument value, its value is gotten " + "from the cache and not recomputed. Caching can often save much " + "computing time, particularly with recursive functions or functions that " + "are expensive to compute and that are called repeatedly " + "with the same argument." + "\vspace{1}\newline ") + (domainConditions (Satisfies S chkNameList)) + (text + "Enter below a list of interpreter functions you would like specially cached. " + "Use the name {\em all} to give a default setting for all " + "interpreter functions. " + "\vspace{1}\newline " + "Enter {\em all} or a list of names (separate names by blanks):") + (inputStrings ("" "" 60 "all" names S)) + (doneButton "Push to enter names" htCacheAddChoice)) + htShowPage() + +htCacheAddChoice htPage == + names := bcString2WordList htpLabelInputString(htPage,'names) + $valueList := [listOfStrings2String names,:$valueList] + null names => htCacheAddQuery() + null rest names => htCacheOne names + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "For each function, enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. " + "A cache length of {\em 0} means the function won't be cached. " + "To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline " + "For each function name, enter {\em all} or a positive integer:")) + for i in 1.. for name in names repeat htMakePage [ + ['inputStrings, + [STRCONC('"Function {\em ",name,'"} will cache"), + '"values",5,10,htMakeLabel('"c",i),'ALLPI]]] + htSetvarDoneButton('"Select to Set Values",'htCacheSet) + htShowPage() + +htMakeLabel(prefix,i) == INTERN STRCONC(prefix,stringize i) + +htCacheSet htPage == + names := htpProperty(htPage,'names) + for i in 1.. for name in names repeat + num := chkAllNonNegativeInteger + htpLabelInputString(htPage,htMakeLabel('"c",i)) + $cacheAlist := ADDASSOC(INTERN name,num,$cacheAlist) + if (n := LASSOC('all,$cacheAlist)) then + $cacheCount := n + $cacheAlist := deleteAssoc('all,$cacheAlist) + htInitPage('"Cache Summary",nil) + bcHt '"In general, interpreter functions " + bcHt + $cacheCount = 0 => "will {\em not} be cached." + bcHt '"cache " + htAllOrNum $cacheCount + '"} values." + bcHt '"\vspace{1}\newline " + if $cacheAlist then +-- bcHt '" However, \indent{3}" + for [name,:val] in $cacheAlist | val ^= $cacheCount repeat + bcHt '"\newline function {\em " + bcHt stringize name + bcHt '"} will cache " + htAllOrNum val + bcHt '"} values" + htProcessDoitButton ['"Press to Remove Page",'"",'htDoNothing] + htShowPage() + +htAllOrNum val == bcHt + val = 'all => '"{\em all" + val = 0 => '"{\em no" + STRCONC('"the last {\em ",stringize val) + +htCacheOne names == + page := htInitPage(mkSetTitle(),nil) + htpSetProperty(page,'names,names) + htMakePage '( + (domainConditions (Satisfies ALLPI chkAllPositiveInteger)) + (text + "Enter below a {\em cache length}, a positive integer. " + "This number tells how many past values will " + "be cached. To cache all past values, " + "enter {\em all}." + "\vspace{1}\newline ") + (inputStrings + ("Enter {\em all} or a positive integer:" + "" 5 10 c1 ALLPI))) + htSetvarDoneButton('"Select to Set Value",'htCacheSet) + htShowPage() + + + + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/hypertex.boot b/src/interp/hypertex.boot deleted file mode 100644 index 00a513aa..00000000 --- a/src/interp/hypertex.boot +++ /dev/null @@ -1,120 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- HyperTex Spad interface - --- SETANDFILEQ($SendXEventToHyperTeX, 8) -SETANDFILEQ($LinkToPage, 96) -SETANDFILEQ($StartPage, 97) -SETANDFILEQ($SendLine, 98) -SETANDFILEQ($EndOfPage, 99) -SETANDFILEQ($PopUpPage, 95) -SETANDFILEQ($PopUpNamedPage, 94) -SETANDFILEQ($KillPage, 93) -SETANDFILEQ($ReplacePage, 92) -SETANDFILEQ($ReplaceNamedPage, 91) -SETANDFILEQ($SpadError, 90) -SETANDFILEQ($PageStuff, 100) - - - --- Issue a line of HyperTex -issueHT line == --- unescapeStringsInForm line - sockSendInt($MenuServer, $SendLine) - sockSendString($MenuServer, line) - -endHTPage() == - sockSendInt($MenuServer, $EndOfPage) - -testPage() == - startHTPage(50) - issueHT '"\page{TestPage}{Test Page generated from Lisp} " - issueHT '"\horizontalline\beginscroll\beginitems " - issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " - issueHT '"The misadventures of the White House bellboy. " - issueHT '"\enditems\endscroll\autobuttons " - endHTPage() - --- Replace a current hypertex page -replaceNamedHTPage(window, name) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplaceNamedPage) - sockSendInt($MenuServer, window) - sockSendString($MenuServer, name) - --- Start up a form page from spad -startHTPopUpPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpPage) - sockSendInt($MenuServer, cols) - sockGetInt($MenuServer) - --- Start a page from spad. Using the spcified number of columns -startHTPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $StartPage) - sockSendInt($MenuServer, cols) - --- Start a replace page sequence -startReplaceHTPage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplacePage) - sockSendInt($MenuServer, w) - --- Kill a page feom scratchpad -killHTPage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $KillPage) - sockSendInt($MenuServer, w) - -linkToHTPage name == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $LinkToPage) - sockSendString($MenuServer, name) - -popUpNamedHTPage(name,cols) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpNamedPage) - sockSendInt($MenuServer, cols) - sockSendString($MenuServer, name) - sockGetInt($MenuServer) - -sendHTErrorSignal() == - sockSendInt($MenuServer, $SpadError) diff --git a/src/interp/hypertex.boot.pamphlet b/src/interp/hypertex.boot.pamphlet new file mode 100644 index 00000000..430abc4e --- /dev/null +++ b/src/interp/hypertex.boot.pamphlet @@ -0,0 +1,142 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp hypertex.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- HyperTex Spad interface + +-- SETANDFILEQ($SendXEventToHyperTeX, 8) +SETANDFILEQ($LinkToPage, 96) +SETANDFILEQ($StartPage, 97) +SETANDFILEQ($SendLine, 98) +SETANDFILEQ($EndOfPage, 99) +SETANDFILEQ($PopUpPage, 95) +SETANDFILEQ($PopUpNamedPage, 94) +SETANDFILEQ($KillPage, 93) +SETANDFILEQ($ReplacePage, 92) +SETANDFILEQ($ReplaceNamedPage, 91) +SETANDFILEQ($SpadError, 90) +SETANDFILEQ($PageStuff, 100) + + + +-- Issue a line of HyperTex +issueHT line == +-- unescapeStringsInForm line + sockSendInt($MenuServer, $SendLine) + sockSendString($MenuServer, line) + +endHTPage() == + sockSendInt($MenuServer, $EndOfPage) + +testPage() == + startHTPage(50) + issueHT '"\page{TestPage}{Test Page generated from Lisp} " + issueHT '"\horizontalline\beginscroll\beginitems " + issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " + issueHT '"The misadventures of the White House bellboy. " + issueHT '"\enditems\endscroll\autobuttons " + endHTPage() + +-- Replace a current hypertex page +replaceNamedHTPage(window, name) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplaceNamedPage) + sockSendInt($MenuServer, window) + sockSendString($MenuServer, name) + +-- Start up a form page from spad +startHTPopUpPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpPage) + sockSendInt($MenuServer, cols) + sockGetInt($MenuServer) + +-- Start a page from spad. Using the spcified number of columns +startHTPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $StartPage) + sockSendInt($MenuServer, cols) + +-- Start a replace page sequence +startReplaceHTPage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplacePage) + sockSendInt($MenuServer, w) + +-- Kill a page feom scratchpad +killHTPage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $KillPage) + sockSendInt($MenuServer, w) + +linkToHTPage name == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $LinkToPage) + sockSendString($MenuServer, name) + +popUpNamedHTPage(name,cols) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpNamedPage) + sockSendInt($MenuServer, cols) + sockSendString($MenuServer, name) + sockGetInt($MenuServer) + +sendHTErrorSignal() == + sockSendInt($MenuServer, $SpadError) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot deleted file mode 100644 index 00e62a44..00000000 --- a/src/interp/i-analy.boot +++ /dev/null @@ -1,810 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Interpreter Analysis Functions - ---% Basic Object Type Identification - -getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) - -getBasicMode0(x,useIntegerSubdomain) == - -- if x is one of the basic types (Integer String Float Boolean) then - -- this function returns its type, and nil otherwise - x is nil => $EmptyMode - STRINGP x => $String - INTEGERP x => - useIntegerSubdomain => - x > 0 => $PositiveInteger - x = 0 => $NonNegativeInteger - $Integer - $Integer - FLOATP x => $DoubleFloat - (x='noBranch) or (x='noValue) => $NoValueMode - nil - -getBasicObject x == - INTEGERP x => - t := - not $useIntegerSubdomain => $Integer - x > 0 => $PositiveInteger - x = 0 => $NonNegativeInteger - $Integer - objNewWrap(x,t) - STRINGP x => objNewWrap(x,$String) - FLOATP x => objNewWrap(x,$DoubleFloat) - NIL - -getMinimalVariableTower(var,t) == - -- gets the minimal polynomial subtower of t that contains the - -- given variable. Returns NIL if none. - STRINGP(t) or IDENTP(t) => NIL - t = $Symbol => t - t is ['Variable,u] => - (u = var) => t - NIL - t is ['Polynomial,.] => t - t is ['RationalFunction,D] => ['Polynomial,D] - t is [up,t',u,.] and MEMQ(up,$univariateDomains) => - -- power series have one more arg and different ordering - u = var => t - getMinimalVariableTower(var,t') - t is [up,u,t'] and MEMQ(up,$univariateDomains) => - u = var => t - getMinimalVariableTower(var,t') - t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) => - var in u => t - getMinimalVariableTower(var,t') - null (t' := underDomainOf t) => NIL - getMinimalVariableTower(var,t') - -getMinimalVarMode(id,m) == - -- This function finds the minimum polynomial subtower type of the - -- polynomial domain tower m which id to which can be coerced - -- It includes all polys above the found level if they are - -- contiguous. - -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I - -- x and P[y] G P[x] I ---> P[x] I - m is ['Mapping, :.] => m - defaultMode := - $Symbol - null m => defaultMode - (vl := polyVarlist m) and ((id in vl) or 'all in vl) => - SUBSTQ('(Integer),$EmptyMode,m) - (um := underDomainOf m) => getMinimalVarMode(id,um) - defaultMode - -polyVarlist m == - -- If m is a polynomial type this function returns a list of its - -- top level variables, and nil otherwise - -- ignore any QuotientFields that may separate poly types - m is [=$QuotientField,op] => polyVarlist op - m is [op,a,:.] => - op in '(UnivariateTaylorSeries UnivariateLaurentSeries - UnivariatePuiseuxSeries) => - [., ., a, :.] := m - a := removeQuote a - [a] - op in '(Polynomial RationalFunction Expression) => - '(all) - a := removeQuote a - op in '(UnivariatePolynomial) => - [a] - op in $multivariateDomains => - a - nil - ---% Pushing Down Target Information - -pushDownTargetInfo(op,target,arglist) == - -- put target info on args for certain operations - target = $OutputForm => NIL - target = $Any => NIL - n := LENGTH arglist - pushDownOnArithmeticVariables(op,target,arglist) - (pdArgs := pushDownOp?(op,n)) => - for i in pdArgs repeat - x := arglist.i - if not getTarget(x) then putTarget(x,target) - nargs := #arglist - 1 = nargs => - (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - 2 = nargs => - op = "*" => -- only push down on 1st arg if not immed - if not getTarget CADR arglist then putTarget(CADR arglist,target) - getTarget(x := CAR arglist) => NIL - if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target) - op = "**" or op = "^" => -- push down on base - if not getTarget CAR arglist then putTarget(CAR arglist,target) - (op = 'equation) and (target is ['Equation,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = 'gauss) and (target is ['Gaussian,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = '_/) => - targ := - target is ['Fraction,S] => S - target - for x in arglist repeat - if not getTarget(x) then putTarget(x,targ) - (op = 'SEGMENT) and (target is ['Segment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => - for x in arglist repeat - if not getTarget(x) then putTarget(x,S) - NIL - NIL - -pushDownOnArithmeticVariables(op,target,arglist) == - -- tries to push appropriate target information onto variable - -- occurring in arithmetic expressions - PAIRP(target) and CAR(target) = 'Variable => NIL - not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL - not containsPolynomial(target) => NIL - for x in arglist for i in 1.. repeat - VECP(x) => -- leaf - transferPropsToNode(xn := getUnname(x),x) - getValue(x) or (xn = $immediateDataSymbol) => NIL - t := getMinimalVariableTower(xn,target) or target - if not getTarget(x) then putTarget(x,t) - PAIRP(x) => -- node - [op',:arglist'] := x - pushDownOnArithmeticVariables(getUnname op',target,arglist') - arglist - -pushDownOp?(op,n) == - -- determine if for op with n arguments whether for all modemaps - -- the target type is equal to one or more arguments. If so, a list - -- of the appropriate arguments is returned. - ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)] - null ops => NIL - op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)] - -- each signature has form - -- [domain of implementation, target, arg1, arg2, ...] - -- sameAsTarg is a vector that counts the number of modemaps that - -- have the corresponding argument equal to the target type - sameAsTarg := GETZEROVEC n - numMms := LENGTH ops - for [.,targ,:argl] in ops repeat - for arg in argl for i in 0.. repeat - targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i) - -- now see which args have their count = numMms - ok := NIL - for i in 0..(n-1) repeat - if numMms = sameAsTarg.i then ok := cons(i,ok) - reverse ok - ---% Bottom Up Processing - --- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for --- user function processing. - -bottomUp t == - -- bottomUp takes an attributed tree, and returns the modeSet for it. - -- As a side-effect it also evaluates the tree. - t is [op,:argl] => - tar := getTarget op - getUnname(op) ^= $immediateDataSymbol and (v := getValue op) => - om := objMode(v) - null tar => [om] - (r := resolveTM(om,tar)) => [r] - [om] - if atom op then - opName:= getUnname op - if opName in $localVars then - putModeSet(op,bottomUpIdentifier(op,opName)) - else - transferPropsToNode(opName,op) - else - opName := NIL - bottomUp op - - opVal := getValue op - - -- call a special handler if we are not being package called - dol := getAtree(op,'dollar) and (opName ^= 'construct) - - (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u - nargs := #argl - if opName then for x in argl for i in 1.. repeat - putAtree(x,'callingFunction,opName) - putAtree(x,'argumentNumber,i) - putAtree(x,'totalArgs,nargs) - - if tar then pushDownTargetInfo(opName,tar,argl) - - -- see if we are calling a declared user map - -- if so, push down the declared types as targets on the args - if opVal and (objVal opVal is ['MAP,:.]) and - (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then - for m in rest ms for x in argl repeat putTarget(x,m) - - argModeSetList:= [bottomUp x for x in argl] - - if ^tar and opName = "*" and nargs = 2 then - [[t1],[t2]] := argModeSetList - tar := computeTypeWithVariablesTarget(t1, t2) - tar => - pushDownTargetInfo(opName,tar,argl) - argModeSetList:= [bottomUp x for x in argl] - - ms := bottomUpForm(t,op,opName,argl,argModeSetList) - - -- given no target or package calling, force integer constants to - -- belong to tightest possible subdomain - - op := CAR t -- may have changed in bottomUpElt - $useIntegerSubdomain and null tar and null dol and - isEqualOrSubDomain(first ms,$Integer) => - val := objVal getValue op - isWrapped val => -- constant if wrapped - val := unwrap val - bm := getBasicMode val - putValue(op,objNewWrap(val,bm)) - putModeSet(op,[bm]) - ms - ms - m := getBasicMode t => [m] - IDENTP (id := getUnname t) => - putModeSet(t,bottomUpIdentifier(t,id)) - keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) - -computeTypeWithVariablesTarget(p, q) == - polyVarlist(p) or polyVarlist(q) => - t := resolveTT(p, q) - polyVarlist(t) => t - NIL - NIL - -bottomUpCompile t == - $genValue:local := false - ms := bottomUp t - COMP_-TRAN_-1 objVal getValue t - ms - -bottomUpUseSubdomain t == - $useIntegerSubdomain : local := true - ms := bottomUp t - ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms - null INTEGERP(num := objValUnwrap getValue t) => ms - o := getBasicObject(num) - putValue(t,o) - ms := [objMode o] - putModeSet(t,ms) - ms - -bottomUpPredicate(pred, name) == - putTarget(pred,$Boolean) - ms := bottomUp pred - $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) - ms - -bottomUpCompilePredicate(pred, name) == - $genValue:local := false - bottomUpPredicate(pred,name) - -bottomUpIdentifier(t,id) == - m := isType t => bottomUpType(t, m) - EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL) - EQ(id,'noBranch) => - keyedSystemError("S2GE0016", - ['"bottomUpIdentifier",'"trying to evaluate noBranch"]) - transferPropsToNode(id,t) - defaultType := ['Variable,id] - -- This was meant to stop building silly symbols but had some unfortunate - -- side effects, like not being able to say e:=foo in the interpreter. MCD --- defaultType := --- getModemapsFromDatabase(id,1) => --- userError ['"Cannot use operation name as a variable: ", id] --- ['Variable, id] - u := getValue t => --non-cached values MAY be re-evaluated - tar := getTarget t - expr:= objVal u - om := objMode(u) - (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) => - $genValue or GENSYMP(id) => - null tar => [om] - (r := resolveTM(om,tar)) => [r] - [om] - bottomUpDefault(t,id,defaultType,getTarget t) - interpRewriteRule(t,id,expr) or - (isMapExpr expr and [objMode(u)]) or - keyedSystemError("S2GE0016", - ['"bottomUpIdentifier",'"cannot evaluate identifier"]) - bottomUpDefault(t,id,defaultType,getTarget t) - -bottomUpDefault(t,id,defaultMode,target) == - if $genValue - then bottomUpDefaultEval(t,id,defaultMode,target,nil) - else bottomUpDefaultCompile(t,id,defaultMode,target,nil) - -bottomUpDefaultEval(t,id,defaultMode,target,isSub) == - -- try to get value case. - - -- 1. declared mode but no value case - (m := getMode t) => - m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t]) - - -- hmm, try to treat it like target mode or declared mode - if isPartialMode(m) then m := resolveTM(['Variable,id],m) - -- if there is a target, probably want it to be that way and not - -- declared mode. Like "x" in second line: - -- x : P[x] I - -- y : P[x] I - target and not isSub and - (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=> - putValue(t,val) - [target] - -- Ok, see if we can make it into declared mode from symbolic form - -- For example, (x : P[x] I; x + 1) - not target and not isSub and m and - (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) => - putValue(t,val) - [m] - -- give up - throwKeyedMsg('"S2IB0004",[id,m]) - - -- 2. no value and no mode case - val := objNewWrap(id,defaultMode) - (null target) or (defaultMode = target) => - putValue(t,val) - [defaultMode] - if isPartialMode target then - -- this hackery will go away when Symbol is not the default type - if defaultMode = $Symbol and (target is [D,x,.]) then - (D in $univariateDomains and (x = id)) or - (D in $multivariateDomains and (id in x)) => - dmode := [D,x,$Integer] - (val' := coerceInteractive(objNewWrap(id, - ['Variable,id]),dmode)) => - defaultMode := dmode - val := val' - NIL - target := resolveTM(defaultMode,target) - -- The following is experimental. SCM 10/11/90 - if target and (tm := getMinimalVarMode(id, target)) then - target := tm - (null target) or null (val' := coerceInteractive(val,target)) => - putValue(t,val) - [defaultMode] - putValue(t,val') - [target] - -bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == - tmode := getMode t - tval := getValue t - expr:= - id in $localVars => id - tmode or tval => - envMode := tmode or objMode tval - envMode is ['Variable, :.] => objVal tval - id = $immediateDataSymbol => objVal tval - ['getValueFromEnvironment,MKQ id,MKQ envMode] - wrap id - tmode and tval and (mdv := objMode tval) => - if isPartialMode tmode then - null (tmode := resolveTM(mdv,tmode)) => - keyedMsgCompFailure("S2IB0010",NIL) - putValue(t,objNew(expr,tmode)) - [tmode] - tmode or (tval and (tmode := objMode tval)) => - putValue(t,objNew(expr,tmode)) - [tmode] - obj := objNew(expr,defaultMode) - canCoerceFrom(defaultMode, target) and - (obj' := coerceInteractive(obj, target)) => - putValue(t, obj') - [target] - putValue(t,obj) - [defaultMode] - -interpRewriteRule(t,id,expr) == - null get(id,'isInterpreterRule,$e) => NIL - (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) => - ms - nil - -bottomUpForm(t,op,opName,argl,argModeSetList) == - not($inRetract) => - bottomUpForm3(t,op,opName,argl,argModeSetList) - bottomUpForm2(t,op,opName,argl,argModeSetList) - -bottomUpForm3(t,op,opName,argl,argModeSetList) == - $origArgModeSetList:local := COPY argModeSetList - bottomUpForm2(t,op,opName,argl,argModeSetList) - -bottomUpForm2(t,op,opName,argl,argModeSetList) == - not atom t and EQ(opName,"%%") => bottomUpPercent t - opVal := getValue op - - -- for things with objects in operator position, be careful before - -- we enter general modemap selection - - lookForIt := - getAtree(op,'dollar) => true - not opVal => true - opMode := objMode opVal - not (opModeTop := IFCAR opMode) => true - opModeTop in '(Record Union) => false - opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true - false - - -- get rid of Union($, "failed") except when op is "=" and all - -- modesets are the same - - $genValue and - ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and - (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u - - lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u - - -- opName can change in the call to selectMms - - (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and - (mS := evalForm(op,opName := getUnname op,argl,mmS)) => - putModeSet(op,mS) - bottomUpForm0(t,op,opName,argl,argModeSetList) - -bottomUpFormTuple(t, op, opName, args, argModeSetList) == - getAtree(op,'dollar) => NIL - null (singles := getModemapsFromDatabase(opName, 1)) => NIL - - -- see if any of the modemaps have Tuple arguments - haveTuple := false - for mm in singles while not haveTuple repeat - if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true - not haveTuple => nil - nargs := #args - nargs = 1 and getUnname first args = "Tuple" => NIL - nargs = 1 and (ms := bottomUp first args) and - (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL - - -- now make the args into a tuple - - newArg := [mkAtreeNode "Tuple",:args] - bottomUp [op, newArg] - -removeUnionsAtStart(argl,modeSets) == - null $genValue => modeSets - for arg in argl for ms in modeSets repeat - null (v := getValue arg) => nil - m := objMode(v) - m isnt ['Union,:.] => nil - val := objVal(v) - null isWrapped val => nil - val' := retract v - m' := objMode val' - putValue(arg,val') - putModeSet(arg,[m']) - RPLACA(ms,m') - modeSets - -printableArgModeSetList() == - amsl := nil - for a in reverse $origArgModeSetList repeat - b := prefix2String first a - if ATOM b then b := [b] - amsl := ['%l,:b,:amsl] - if amsl then amsl := rest amsl - amsl - -bottomUpForm0(t,op,opName,argl,argModeSetList) == - op0 := op - opName0 := opName - - m := isType t => - bottomUpType(t, m) - - opName = 'copy and argModeSetList is [[['Record,:rargs]]] => - -- this is a hack until Records go through the normal - -- modemap selection process - rtype := ['Record,:rargs] - code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs]) - - if $genValue then code := wrap timedEVALFUN code - val := objNew(code,rtype) - putValue(t,val) - putModeSet(t,[rtype]) - - m := getModeOrFirstModeSetIfThere op - m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and - member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u - m is ['Union,:.] and argModeSetList is [[['Variable,x]]] => - member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u - not $genValue => - amsl := printableArgModeSetList() - throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) - object := retract getValue op - object = 'failed => - throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) - putModeSet(op,[objMode(object)]) - putValue(op,object) - (u := bottomUpElt t) => u - bottomUpForm0(t,op,opName,argl,argModeSetList) - - (opName ^= "elt") and (opName ^= "apply") and - #argl = 1 and first first argModeSetList is ['Variable, var] - and var in '(first last rest) and - isEltable(op, argl, #argl) and (u := bottomUpElt t) => u - - $genValue and - ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u - - (opName ^= "elt") and (opName ^= "apply") and - isEltable(op, argl, #argl) and (u := bottomUpElt t) => u - - if FIXP $HTCompanionWindowID then - mkCompanionPage('operationError, t) - - amsl := printableArgModeSetList() - opName1 := - opName0 = $immediateDataSymbol => - (o := coerceInteractive(getValue op0,$OutputForm)) => - outputTran objValUnwrap o - NIL - opName0 - - if null(opName1) then - opName1 := - (o := getValue op0) => prefix2String objMode o - '"" - msgKey := - null amsl => "S2IB0013" - "S2IB0012" - else - msgKey := - null amsl => "S2IB0011" - (n := isSharpVarWithNum opName1) => - opName1 := n - "S2IB0008g" - "S2IB0008" - - sayIntelligentMessageAboutOpAvailability(opName1, #argl) - - not $genValue => - keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0) - throwKeyedMsgSP(msgKey,[opName1, amsl], op0) - -sayIntelligentMessageAboutOpAvailability(opName, nArgs) == - -- see if we can give some decent messages about the availability if - -- library messages - - NUMBERP opName => NIL - - oo := object2Identifier opOf opName - if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then - opName := "elt" - - nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL) - nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL) - - -- first see if there are ANY ops with this name - - if nAllMmsWithName = 0 then - sayKeyedMsg("S2IB0008a", [opName]) - else if nAllExposedMmsWithName = 0 then - nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName]) - sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName]) - else - -- now talk about specific arguments - nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs) - nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs) - nAllMmsWithNameAndArgs = 0 => - sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName]) - nAllExposedMmsWithNameAndArgs = 0 => - sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) - sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) - nil - -bottomUpType(t, type) == - mode := - if isPartialMode type then '(Mode) - else if categoryForm?(type) then '(SubDomain (Domain)) - else '(Domain) - val:= objNew(type,mode) - putValue(t,val) - -- have to fix the following - putModeSet(t,[mode]) - -bottomUpPercent(tree is [op,:argl]) == - -- handles a call %%(5), which means the output of step 5 - -- %%() is the same as %%(-1) - null argl => - val:= fetchOutput(-1) - putValue(op,val) - putModeSet(op,[objMode(val)]) - argl is [t] => - i:= getArgValue(t,$Integer) => - val:= fetchOutput i - putValue(op,val) - putModeSet(op,[objMode(val)]) - throwKeyedMsgSP('"S2IB0006",NIL,t) - throwKeyedMsgSP('"S2IB0006",NIL,op) - -bottomUpFormRetract(t,op,opName,argl,amsl) == - -- tries to find one argument, which can be pulled back, and calls - -- bottomUpForm again. We do not retract the first argument to a - -- setelt, because this is presumably a destructive operation and - -- the retract can create a new object. - - -- if no such operation exists in the database, don't bother - $inRetract: local := true - null getAllModemapsFromDatabase(getUnname op,#argl) => NIL - - u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u - - a := NIL - b := NIL - ms := NIL - for x in argl for m in amsl for i in 1.. repeat - -- do not retract first arg of a setelt - (i = 1) and (opName = "setelt") => - a := [x,:a] - ms := [m,:ms] - (i = 1) and (opName = "set!") => - a := [x,:a] - ms := [m,:ms] - if PAIRP(m) and CAR(m) = $EmptyMode then return NIL - object:= retract getValue x - a:= [x,:a] - EQ(object,'failed) => - putAtree(x,'retracted,nil) - ms := [m, :ms] - b:= true - RPLACA(m,objMode(object)) - ms := [COPY_-TREE m, :ms] - putAtree(x,'retracted,true) - putValue(x,object) - putModeSet(x,[objMode(object)]) - --insert pulled-back items - a := nreverse a - ms := nreverse ms - - -- check that we haven't seen these types before - typesHad := getAtree(t, 'typesHad) - if member(ms, typesHad) then b := nil - else putAtree(t, 'typesHad, cons(ms, typesHad)) - - b and bottomUpForm(t,op,opName,a,amsl) - -retractAtree atr == - object:= retract getValue atr - EQ(object,'failed) => - putAtree(atr,'retracted,nil) - nil - putAtree(atr,'retracted,true) - putValue(atr,object) - putModeSet(atr,[objMode(object)]) - true - -bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == - -- see if we have a Union - - ok := NIL - for m in amsl while not ok repeat - if atom first(m) then return NIL - first m = $Any => ok := true - (first first m = 'Union) => ok := true - not ok => NIL - - a:= NIL - b:= NIL - - for x in argl for m in amsl for i in 0.. repeat - m0 := first m - if ( (m0 = $Any) or (first m0 = 'Union) ) and - ('failed^=(object:=retract getValue x)) then - b := true - RPLACA(m,objMode(object)) - putModeSet(x,[objMode(object)]) - putValue(x,object) - a := cons(x,a) - b and bottomUpForm(t,op,opName,nreverse a,amsl) - -bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == - -- see if we have a Union with no tags, if so retract all such guys - - ok := NIL - for [m] in amsl while not ok repeat - if atom m then return NIL - if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true - not ok => NIL - - a:= NIL - b:= NIL - - for x in argl for m in amsl for i in 0.. repeat - m0 := first m - if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and - ('failed ^= (object:=retract getValue x)) then - b := true - RPLACA(m,objMode(object)) - putModeSet(x,[objMode(object)]) - putValue(x,object) - a := cons(x,a) - b and bottomUpForm(t,op,opName,nreverse a,amsl) - -bottomUpElt (form:=[op,:argl]) == - -- this transfers expressions that look like function calls into - -- forms with elt or apply. - - ms := bottomUp op - ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) => - RPLAC(CDR form, [op,:argl]) - RPLAC(CAR form, mkAtreeNode "elt") - bottomUp form - - target := getTarget form - - newOps := [mkAtreeNode "elt", mkAtreeNode "apply"] - u := nil - - while ^u for newOp in newOps repeat - newArgs := [op,:argl] - if selectMms(newOp, newArgs, target) then - RPLAC(CDR form, newArgs) - RPLAC(CAR form, newOp) - u := bottomUp form - - while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat - while ^u for newOp in newOps repeat - newArgs := [op,:argl] - if selectMms(newOp, newArgs, target) then - RPLAC(CDR form, newArgs) - RPLAC(CAR form, newOp) - u := bottomUp form - u - -isEltable(op,argl,numArgs) == - -- determines if the object might possible have an elt function - -- we exclude Mapping and Variable types explicitly - v := getValue op => - ZEROP numArgs => true - not(m := objMode(v)) => nil - m is ['Mapping, :.] => nil - objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil - true - m := getMode op => - ZEROP numArgs => true - m is ['Mapping, :.] => nil - true - numArgs ^= 1 => nil - name := getUnname op - name = 'SEQ => nil ---not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil - arg := first argl - (getUnname arg) ^= 'construct => nil - true - diff --git a/src/interp/i-analy.boot.pamphlet b/src/interp/i-analy.boot.pamphlet new file mode 100644 index 00000000..ff2d62fa --- /dev/null +++ b/src/interp/i-analy.boot.pamphlet @@ -0,0 +1,832 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-analy.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Interpreter Analysis Functions + +--% Basic Object Type Identification + +getBasicMode x == getBasicMode0(x,$useIntegerSubdomain) + +getBasicMode0(x,useIntegerSubdomain) == + -- if x is one of the basic types (Integer String Float Boolean) then + -- this function returns its type, and nil otherwise + x is nil => $EmptyMode + STRINGP x => $String + INTEGERP x => + useIntegerSubdomain => + x > 0 => $PositiveInteger + x = 0 => $NonNegativeInteger + $Integer + $Integer + FLOATP x => $DoubleFloat + (x='noBranch) or (x='noValue) => $NoValueMode + nil + +getBasicObject x == + INTEGERP x => + t := + not $useIntegerSubdomain => $Integer + x > 0 => $PositiveInteger + x = 0 => $NonNegativeInteger + $Integer + objNewWrap(x,t) + STRINGP x => objNewWrap(x,$String) + FLOATP x => objNewWrap(x,$DoubleFloat) + NIL + +getMinimalVariableTower(var,t) == + -- gets the minimal polynomial subtower of t that contains the + -- given variable. Returns NIL if none. + STRINGP(t) or IDENTP(t) => NIL + t = $Symbol => t + t is ['Variable,u] => + (u = var) => t + NIL + t is ['Polynomial,.] => t + t is ['RationalFunction,D] => ['Polynomial,D] + t is [up,t',u,.] and MEMQ(up,$univariateDomains) => + -- power series have one more arg and different ordering + u = var => t + getMinimalVariableTower(var,t') + t is [up,u,t'] and MEMQ(up,$univariateDomains) => + u = var => t + getMinimalVariableTower(var,t') + t is [mp,u,t'] and MEMQ(mp,$multivariateDomains) => + var in u => t + getMinimalVariableTower(var,t') + null (t' := underDomainOf t) => NIL + getMinimalVariableTower(var,t') + +getMinimalVarMode(id,m) == + -- This function finds the minimum polynomial subtower type of the + -- polynomial domain tower m which id to which can be coerced + -- It includes all polys above the found level if they are + -- contiguous. + -- E.g.: x and G P[y] P[x] I ---> P[y] P[x] I + -- x and P[y] G P[x] I ---> P[x] I + m is ['Mapping, :.] => m + defaultMode := + $Symbol + null m => defaultMode + (vl := polyVarlist m) and ((id in vl) or 'all in vl) => + SUBSTQ('(Integer),$EmptyMode,m) + (um := underDomainOf m) => getMinimalVarMode(id,um) + defaultMode + +polyVarlist m == + -- If m is a polynomial type this function returns a list of its + -- top level variables, and nil otherwise + -- ignore any QuotientFields that may separate poly types + m is [=$QuotientField,op] => polyVarlist op + m is [op,a,:.] => + op in '(UnivariateTaylorSeries UnivariateLaurentSeries + UnivariatePuiseuxSeries) => + [., ., a, :.] := m + a := removeQuote a + [a] + op in '(Polynomial RationalFunction Expression) => + '(all) + a := removeQuote a + op in '(UnivariatePolynomial) => + [a] + op in $multivariateDomains => + a + nil + +--% Pushing Down Target Information + +pushDownTargetInfo(op,target,arglist) == + -- put target info on args for certain operations + target = $OutputForm => NIL + target = $Any => NIL + n := LENGTH arglist + pushDownOnArithmeticVariables(op,target,arglist) + (pdArgs := pushDownOp?(op,n)) => + for i in pdArgs repeat + x := arglist.i + if not getTarget(x) then putTarget(x,target) + nargs := #arglist + 1 = nargs => + (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + 2 = nargs => + op = "*" => -- only push down on 1st arg if not immed + if not getTarget CADR arglist then putTarget(CADR arglist,target) + getTarget(x := CAR arglist) => NIL + if getUnname(x) ^= $immediateDataSymbol then putTarget(x,target) + op = "**" or op = "^" => -- push down on base + if not getTarget CAR arglist then putTarget(CAR arglist,target) + (op = 'equation) and (target is ['Equation,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = 'gauss) and (target is ['Gaussian,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = '_/) => + targ := + target is ['Fraction,S] => S + target + for x in arglist repeat + if not getTarget(x) then putTarget(x,targ) + (op = 'SEGMENT) and (target is ['Segment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + (op = 'SEGMENT) and (target is ['UniversalSegment,S]) => + for x in arglist repeat + if not getTarget(x) then putTarget(x,S) + NIL + NIL + +pushDownOnArithmeticVariables(op,target,arglist) == + -- tries to push appropriate target information onto variable + -- occurring in arithmetic expressions + PAIRP(target) and CAR(target) = 'Variable => NIL + not MEMQ(op,'(_+ _- _* _*_* _/)) => NIL + not containsPolynomial(target) => NIL + for x in arglist for i in 1.. repeat + VECP(x) => -- leaf + transferPropsToNode(xn := getUnname(x),x) + getValue(x) or (xn = $immediateDataSymbol) => NIL + t := getMinimalVariableTower(xn,target) or target + if not getTarget(x) then putTarget(x,t) + PAIRP(x) => -- node + [op',:arglist'] := x + pushDownOnArithmeticVariables(getUnname op',target,arglist') + arglist + +pushDownOp?(op,n) == + -- determine if for op with n arguments whether for all modemaps + -- the target type is equal to one or more arguments. If so, a list + -- of the appropriate arguments is returned. + ops := [sig for [sig,:.] in getModemapsFromDatabase(op,n)] + null ops => NIL + op in '(_+ _* _- _exquo) => [i for i in 0..(n-1)] + -- each signature has form + -- [domain of implementation, target, arg1, arg2, ...] + -- sameAsTarg is a vector that counts the number of modemaps that + -- have the corresponding argument equal to the target type + sameAsTarg := GETZEROVEC n + numMms := LENGTH ops + for [.,targ,:argl] in ops repeat + for arg in argl for i in 0.. repeat + targ = arg => SETELT(sameAsTarg,i,1 + sameAsTarg.i) + -- now see which args have their count = numMms + ok := NIL + for i in 0..(n-1) repeat + if numMms = sameAsTarg.i then ok := cons(i,ok) + reverse ok + +--% Bottom Up Processing + +-- Also see I-SPEC BOOT for special handlers and I-MAP BOOT for +-- user function processing. + +bottomUp t == + -- bottomUp takes an attributed tree, and returns the modeSet for it. + -- As a side-effect it also evaluates the tree. + t is [op,:argl] => + tar := getTarget op + getUnname(op) ^= $immediateDataSymbol and (v := getValue op) => + om := objMode(v) + null tar => [om] + (r := resolveTM(om,tar)) => [r] + [om] + if atom op then + opName:= getUnname op + if opName in $localVars then + putModeSet(op,bottomUpIdentifier(op,opName)) + else + transferPropsToNode(opName,op) + else + opName := NIL + bottomUp op + + opVal := getValue op + + -- call a special handler if we are not being package called + dol := getAtree(op,'dollar) and (opName ^= 'construct) + + (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u + nargs := #argl + if opName then for x in argl for i in 1.. repeat + putAtree(x,'callingFunction,opName) + putAtree(x,'argumentNumber,i) + putAtree(x,'totalArgs,nargs) + + if tar then pushDownTargetInfo(opName,tar,argl) + + -- see if we are calling a declared user map + -- if so, push down the declared types as targets on the args + if opVal and (objVal opVal is ['MAP,:.]) and + (getMode op is ['Mapping,:ms]) and (nargs + 1= #ms) then + for m in rest ms for x in argl repeat putTarget(x,m) + + argModeSetList:= [bottomUp x for x in argl] + + if ^tar and opName = "*" and nargs = 2 then + [[t1],[t2]] := argModeSetList + tar := computeTypeWithVariablesTarget(t1, t2) + tar => + pushDownTargetInfo(opName,tar,argl) + argModeSetList:= [bottomUp x for x in argl] + + ms := bottomUpForm(t,op,opName,argl,argModeSetList) + + -- given no target or package calling, force integer constants to + -- belong to tightest possible subdomain + + op := CAR t -- may have changed in bottomUpElt + $useIntegerSubdomain and null tar and null dol and + isEqualOrSubDomain(first ms,$Integer) => + val := objVal getValue op + isWrapped val => -- constant if wrapped + val := unwrap val + bm := getBasicMode val + putValue(op,objNewWrap(val,bm)) + putModeSet(op,[bm]) + ms + ms + m := getBasicMode t => [m] + IDENTP (id := getUnname t) => + putModeSet(t,bottomUpIdentifier(t,id)) + keyedSystemError("S2GE0016",['"bottomUp",'"unknown object form"]) + +computeTypeWithVariablesTarget(p, q) == + polyVarlist(p) or polyVarlist(q) => + t := resolveTT(p, q) + polyVarlist(t) => t + NIL + NIL + +bottomUpCompile t == + $genValue:local := false + ms := bottomUp t + COMP_-TRAN_-1 objVal getValue t + ms + +bottomUpUseSubdomain t == + $useIntegerSubdomain : local := true + ms := bottomUp t + ($immediateDataSymbol ^= getUnname(t)) or ($Integer ^= CAR(ms)) => ms + null INTEGERP(num := objValUnwrap getValue t) => ms + o := getBasicObject(num) + putValue(t,o) + ms := [objMode o] + putModeSet(t,ms) + ms + +bottomUpPredicate(pred, name) == + putTarget(pred,$Boolean) + ms := bottomUp pred + $Boolean ^= first ms => throwKeyedMsg('"S2IB0001",[name]) + ms + +bottomUpCompilePredicate(pred, name) == + $genValue:local := false + bottomUpPredicate(pred,name) + +bottomUpIdentifier(t,id) == + m := isType t => bottomUpType(t, m) + EQ(id,'noMapVal) => throwKeyedMsg('"S2IB0002",NIL) + EQ(id,'noBranch) => + keyedSystemError("S2GE0016", + ['"bottomUpIdentifier",'"trying to evaluate noBranch"]) + transferPropsToNode(id,t) + defaultType := ['Variable,id] + -- This was meant to stop building silly symbols but had some unfortunate + -- side effects, like not being able to say e:=foo in the interpreter. MCD +-- defaultType := +-- getModemapsFromDatabase(id,1) => +-- userError ['"Cannot use operation name as a variable: ", id] +-- ['Variable, id] + u := getValue t => --non-cached values MAY be re-evaluated + tar := getTarget t + expr:= objVal u + om := objMode(u) + (om ^= $EmptyMode) and (om isnt ['RuleCalled,.]) => + $genValue or GENSYMP(id) => + null tar => [om] + (r := resolveTM(om,tar)) => [r] + [om] + bottomUpDefault(t,id,defaultType,getTarget t) + interpRewriteRule(t,id,expr) or + (isMapExpr expr and [objMode(u)]) or + keyedSystemError("S2GE0016", + ['"bottomUpIdentifier",'"cannot evaluate identifier"]) + bottomUpDefault(t,id,defaultType,getTarget t) + +bottomUpDefault(t,id,defaultMode,target) == + if $genValue + then bottomUpDefaultEval(t,id,defaultMode,target,nil) + else bottomUpDefaultCompile(t,id,defaultMode,target,nil) + +bottomUpDefaultEval(t,id,defaultMode,target,isSub) == + -- try to get value case. + + -- 1. declared mode but no value case + (m := getMode t) => + m is ['Mapping,:.] => throwKeyedMsg('"S2IB0003",[getUnname t]) + + -- hmm, try to treat it like target mode or declared mode + if isPartialMode(m) then m := resolveTM(['Variable,id],m) + -- if there is a target, probably want it to be that way and not + -- declared mode. Like "x" in second line: + -- x : P[x] I + -- y : P[x] I + target and not isSub and + (val := coerceInteractive(objNewWrap(id,['Variable,id]),target))=> + putValue(t,val) + [target] + -- Ok, see if we can make it into declared mode from symbolic form + -- For example, (x : P[x] I; x + 1) + not target and not isSub and m and + (val := coerceInteractive(objNewWrap(id,['Variable,id]),m)) => + putValue(t,val) + [m] + -- give up + throwKeyedMsg('"S2IB0004",[id,m]) + + -- 2. no value and no mode case + val := objNewWrap(id,defaultMode) + (null target) or (defaultMode = target) => + putValue(t,val) + [defaultMode] + if isPartialMode target then + -- this hackery will go away when Symbol is not the default type + if defaultMode = $Symbol and (target is [D,x,.]) then + (D in $univariateDomains and (x = id)) or + (D in $multivariateDomains and (id in x)) => + dmode := [D,x,$Integer] + (val' := coerceInteractive(objNewWrap(id, + ['Variable,id]),dmode)) => + defaultMode := dmode + val := val' + NIL + target := resolveTM(defaultMode,target) + -- The following is experimental. SCM 10/11/90 + if target and (tm := getMinimalVarMode(id, target)) then + target := tm + (null target) or null (val' := coerceInteractive(val,target)) => + putValue(t,val) + [defaultMode] + putValue(t,val') + [target] + +bottomUpDefaultCompile(t,id,defaultMode,target,isSub) == + tmode := getMode t + tval := getValue t + expr:= + id in $localVars => id + tmode or tval => + envMode := tmode or objMode tval + envMode is ['Variable, :.] => objVal tval + id = $immediateDataSymbol => objVal tval + ['getValueFromEnvironment,MKQ id,MKQ envMode] + wrap id + tmode and tval and (mdv := objMode tval) => + if isPartialMode tmode then + null (tmode := resolveTM(mdv,tmode)) => + keyedMsgCompFailure("S2IB0010",NIL) + putValue(t,objNew(expr,tmode)) + [tmode] + tmode or (tval and (tmode := objMode tval)) => + putValue(t,objNew(expr,tmode)) + [tmode] + obj := objNew(expr,defaultMode) + canCoerceFrom(defaultMode, target) and + (obj' := coerceInteractive(obj, target)) => + putValue(t, obj') + [target] + putValue(t,obj) + [defaultMode] + +interpRewriteRule(t,id,expr) == + null get(id,'isInterpreterRule,$e) => NIL + (ms:= selectLocalMms(t,id,nil,nil)) and (ms:=evalForm(t,id,nil,ms)) => + ms + nil + +bottomUpForm(t,op,opName,argl,argModeSetList) == + not($inRetract) => + bottomUpForm3(t,op,opName,argl,argModeSetList) + bottomUpForm2(t,op,opName,argl,argModeSetList) + +bottomUpForm3(t,op,opName,argl,argModeSetList) == + $origArgModeSetList:local := COPY argModeSetList + bottomUpForm2(t,op,opName,argl,argModeSetList) + +bottomUpForm2(t,op,opName,argl,argModeSetList) == + not atom t and EQ(opName,"%%") => bottomUpPercent t + opVal := getValue op + + -- for things with objects in operator position, be careful before + -- we enter general modemap selection + + lookForIt := + getAtree(op,'dollar) => true + not opVal => true + opMode := objMode opVal + not (opModeTop := IFCAR opMode) => true + opModeTop in '(Record Union) => false + opModeTop in '(Variable Mapping FunctionCalled RuleCalled AnonymousFunction) => true + false + + -- get rid of Union($, "failed") except when op is "=" and all + -- modesets are the same + + $genValue and + ^(opName = "=" and argModeSetList is [[m],[=m]] and m is ['Union,:.]) and + (u := bottomUpFormUntaggedUnionRetract(t,op,opName,argl,argModeSetList)) => u + + lookForIt and (u := bottomUpFormTuple(t, op, opName, argl, argModeSetList)) => u + + -- opName can change in the call to selectMms + + (lookForIt and (mmS := selectMms(op,argl,getTarget op))) and + (mS := evalForm(op,opName := getUnname op,argl,mmS)) => + putModeSet(op,mS) + bottomUpForm0(t,op,opName,argl,argModeSetList) + +bottomUpFormTuple(t, op, opName, args, argModeSetList) == + getAtree(op,'dollar) => NIL + null (singles := getModemapsFromDatabase(opName, 1)) => NIL + + -- see if any of the modemaps have Tuple arguments + haveTuple := false + for mm in singles while not haveTuple repeat + if getFirstArgTypeFromMm(mm) is ["Tuple",.] then haveTuple := true + not haveTuple => nil + nargs := #args + nargs = 1 and getUnname first args = "Tuple" => NIL + nargs = 1 and (ms := bottomUp first args) and + (ms is [["Tuple",.]] or ms is [["List",.]]) => NIL + + -- now make the args into a tuple + + newArg := [mkAtreeNode "Tuple",:args] + bottomUp [op, newArg] + +removeUnionsAtStart(argl,modeSets) == + null $genValue => modeSets + for arg in argl for ms in modeSets repeat + null (v := getValue arg) => nil + m := objMode(v) + m isnt ['Union,:.] => nil + val := objVal(v) + null isWrapped val => nil + val' := retract v + m' := objMode val' + putValue(arg,val') + putModeSet(arg,[m']) + RPLACA(ms,m') + modeSets + +printableArgModeSetList() == + amsl := nil + for a in reverse $origArgModeSetList repeat + b := prefix2String first a + if ATOM b then b := [b] + amsl := ['%l,:b,:amsl] + if amsl then amsl := rest amsl + amsl + +bottomUpForm0(t,op,opName,argl,argModeSetList) == + op0 := op + opName0 := opName + + m := isType t => + bottomUpType(t, m) + + opName = 'copy and argModeSetList is [[['Record,:rargs]]] => + -- this is a hack until Records go through the normal + -- modemap selection process + rtype := ['Record,:rargs] + code := optRECORDCOPY(['RECORDCOPY,getArgValue(CAR argl, rtype),#rargs]) + + if $genValue then code := wrap timedEVALFUN code + val := objNew(code,rtype) + putValue(t,val) + putModeSet(t,[rtype]) + + m := getModeOrFirstModeSetIfThere op + m is ['Record,:.] and argModeSetList is [[['Variable,x]]] and + member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u + m is ['Union,:.] and argModeSetList is [[['Variable,x]]] => + member(x,getUnionOrRecordTags m) and (u := bottomUpElt t) => u + not $genValue => + amsl := printableArgModeSetList() + throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) + object := retract getValue op + object = 'failed => + throwKeyedMsgSP("S2IB0008",['"the union object",amsl], op) + putModeSet(op,[objMode(object)]) + putValue(op,object) + (u := bottomUpElt t) => u + bottomUpForm0(t,op,opName,argl,argModeSetList) + + (opName ^= "elt") and (opName ^= "apply") and + #argl = 1 and first first argModeSetList is ['Variable, var] + and var in '(first last rest) and + isEltable(op, argl, #argl) and (u := bottomUpElt t) => u + + $genValue and + ( u:= bottomUpFormRetract(t,op,opName,argl,argModeSetList) ) => u + + (opName ^= "elt") and (opName ^= "apply") and + isEltable(op, argl, #argl) and (u := bottomUpElt t) => u + + if FIXP $HTCompanionWindowID then + mkCompanionPage('operationError, t) + + amsl := printableArgModeSetList() + opName1 := + opName0 = $immediateDataSymbol => + (o := coerceInteractive(getValue op0,$OutputForm)) => + outputTran objValUnwrap o + NIL + opName0 + + if null(opName1) then + opName1 := + (o := getValue op0) => prefix2String objMode o + '"" + msgKey := + null amsl => "S2IB0013" + "S2IB0012" + else + msgKey := + null amsl => "S2IB0011" + (n := isSharpVarWithNum opName1) => + opName1 := n + "S2IB0008g" + "S2IB0008" + + sayIntelligentMessageAboutOpAvailability(opName1, #argl) + + not $genValue => + keyedMsgCompFailureSP(msgKey,[opName1, amsl], op0) + throwKeyedMsgSP(msgKey,[opName1, amsl], op0) + +sayIntelligentMessageAboutOpAvailability(opName, nArgs) == + -- see if we can give some decent messages about the availability if + -- library messages + + NUMBERP opName => NIL + + oo := object2Identifier opOf opName + if ( oo = "%" ) or ( oo = "Domain" ) or ( domainForm? opName ) then + opName := "elt" + + nAllExposedMmsWithName := #getModemapsFromDatabase(opName, NIL) + nAllMmsWithName := #getAllModemapsFromDatabase(opName, NIL) + + -- first see if there are ANY ops with this name + + if nAllMmsWithName = 0 then + sayKeyedMsg("S2IB0008a", [opName]) + else if nAllExposedMmsWithName = 0 then + nAllMmsWithName = 1 => sayKeyedMsg("S2IB0008b", [opName]) + sayKeyedMsg("S2IB0008c", [opName, nAllMmsWithName]) + else + -- now talk about specific arguments + nAllExposedMmsWithNameAndArgs := #getModemapsFromDatabase(opName, nArgs) + nAllMmsWithNameAndArgs := #getAllModemapsFromDatabase(opName, nArgs) + nAllMmsWithNameAndArgs = 0 => + sayKeyedMsg("S2IB0008d", [opName, nArgs, nAllExposedMmsWithName, nAllMmsWithName - nAllExposedMmsWithName]) + nAllExposedMmsWithNameAndArgs = 0 => + sayKeyedMsg("S2IB0008e", [opName, nArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) + sayKeyedMsg("S2IB0008f", [opName, nArgs, nAllExposedMmsWithNameAndArgs, nAllMmsWithNameAndArgs - nAllExposedMmsWithNameAndArgs]) + nil + +bottomUpType(t, type) == + mode := + if isPartialMode type then '(Mode) + else if categoryForm?(type) then '(SubDomain (Domain)) + else '(Domain) + val:= objNew(type,mode) + putValue(t,val) + -- have to fix the following + putModeSet(t,[mode]) + +bottomUpPercent(tree is [op,:argl]) == + -- handles a call %%(5), which means the output of step 5 + -- %%() is the same as %%(-1) + null argl => + val:= fetchOutput(-1) + putValue(op,val) + putModeSet(op,[objMode(val)]) + argl is [t] => + i:= getArgValue(t,$Integer) => + val:= fetchOutput i + putValue(op,val) + putModeSet(op,[objMode(val)]) + throwKeyedMsgSP('"S2IB0006",NIL,t) + throwKeyedMsgSP('"S2IB0006",NIL,op) + +bottomUpFormRetract(t,op,opName,argl,amsl) == + -- tries to find one argument, which can be pulled back, and calls + -- bottomUpForm again. We do not retract the first argument to a + -- setelt, because this is presumably a destructive operation and + -- the retract can create a new object. + + -- if no such operation exists in the database, don't bother + $inRetract: local := true + null getAllModemapsFromDatabase(getUnname op,#argl) => NIL + + u := bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) => u + + a := NIL + b := NIL + ms := NIL + for x in argl for m in amsl for i in 1.. repeat + -- do not retract first arg of a setelt + (i = 1) and (opName = "setelt") => + a := [x,:a] + ms := [m,:ms] + (i = 1) and (opName = "set!") => + a := [x,:a] + ms := [m,:ms] + if PAIRP(m) and CAR(m) = $EmptyMode then return NIL + object:= retract getValue x + a:= [x,:a] + EQ(object,'failed) => + putAtree(x,'retracted,nil) + ms := [m, :ms] + b:= true + RPLACA(m,objMode(object)) + ms := [COPY_-TREE m, :ms] + putAtree(x,'retracted,true) + putValue(x,object) + putModeSet(x,[objMode(object)]) + --insert pulled-back items + a := nreverse a + ms := nreverse ms + + -- check that we haven't seen these types before + typesHad := getAtree(t, 'typesHad) + if member(ms, typesHad) then b := nil + else putAtree(t, 'typesHad, cons(ms, typesHad)) + + b and bottomUpForm(t,op,opName,a,amsl) + +retractAtree atr == + object:= retract getValue atr + EQ(object,'failed) => + putAtree(atr,'retracted,nil) + nil + putAtree(atr,'retracted,true) + putValue(atr,object) + putModeSet(atr,[objMode(object)]) + true + +bottomUpFormAnyUnionRetract(t,op,opName,argl,amsl) == + -- see if we have a Union + + ok := NIL + for m in amsl while not ok repeat + if atom first(m) then return NIL + first m = $Any => ok := true + (first first m = 'Union) => ok := true + not ok => NIL + + a:= NIL + b:= NIL + + for x in argl for m in amsl for i in 0.. repeat + m0 := first m + if ( (m0 = $Any) or (first m0 = 'Union) ) and + ('failed^=(object:=retract getValue x)) then + b := true + RPLACA(m,objMode(object)) + putModeSet(x,[objMode(object)]) + putValue(x,object) + a := cons(x,a) + b and bottomUpForm(t,op,opName,nreverse a,amsl) + +bottomUpFormUntaggedUnionRetract(t,op,opName,argl,amsl) == + -- see if we have a Union with no tags, if so retract all such guys + + ok := NIL + for [m] in amsl while not ok repeat + if atom m then return NIL + if m is ['Union, :.] and null getUnionOrRecordTags m then ok := true + not ok => NIL + + a:= NIL + b:= NIL + + for x in argl for m in amsl for i in 0.. repeat + m0 := first m + if (m0 is ['Union, :.] and null getUnionOrRecordTags m0) and + ('failed ^= (object:=retract getValue x)) then + b := true + RPLACA(m,objMode(object)) + putModeSet(x,[objMode(object)]) + putValue(x,object) + a := cons(x,a) + b and bottomUpForm(t,op,opName,nreverse a,amsl) + +bottomUpElt (form:=[op,:argl]) == + -- this transfers expressions that look like function calls into + -- forms with elt or apply. + + ms := bottomUp op + ms and (ms is [['Union,:.]] or ms is [['Record,:.]]) => + RPLAC(CDR form, [op,:argl]) + RPLAC(CAR form, mkAtreeNode "elt") + bottomUp form + + target := getTarget form + + newOps := [mkAtreeNode "elt", mkAtreeNode "apply"] + u := nil + + while ^u for newOp in newOps repeat + newArgs := [op,:argl] + if selectMms(newOp, newArgs, target) then + RPLAC(CDR form, newArgs) + RPLAC(CAR form, newOp) + u := bottomUp form + + while ^u and ( "and"/[retractAtree(a) for a in newArgs] ) repeat + while ^u for newOp in newOps repeat + newArgs := [op,:argl] + if selectMms(newOp, newArgs, target) then + RPLAC(CDR form, newArgs) + RPLAC(CAR form, newOp) + u := bottomUp form + u + +isEltable(op,argl,numArgs) == + -- determines if the object might possible have an elt function + -- we exclude Mapping and Variable types explicitly + v := getValue op => + ZEROP numArgs => true + not(m := objMode(v)) => nil + m is ['Mapping, :.] => nil + objVal(v) is ['MAP, :mapDef] and numMapArgs(mapDef) > 0 => nil + true + m := getMode op => + ZEROP numArgs => true + m is ['Mapping, :.] => nil + true + numArgs ^= 1 => nil + name := getUnname op + name = 'SEQ => nil +--not (name in '(a e h s)) and getAllModemapsFromDatabase(name, nil) => nil + arg := first argl + (getUnname arg) ^= 'construct => nil + true + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/i-code.boot b/src/interp/i-code.boot deleted file mode 100644 index 667186ce..00000000 --- a/src/interp/i-code.boot +++ /dev/null @@ -1,142 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Interpreter Code Generation Routines - ---Modified by JHD 9/9/93 to fix a problem with coerces inside ---interpreter functions being used as mappings. They were being ---handled with $useCoerceOrCroak being NIL, and therefore internal ---coercions were not correctly handled. Fix: remove dependence ---on $useCoerceOrCroak, and test explicitly for Mapping types. - ---% COERCE - -intCodeGenCOERCE(triple,t2) == - -- NOTE: returns a triple - t1 := objMode triple - t1 = $EmptyMode => NIL - t1 = t2 => triple - val := objVal triple - - -- if request is for a coerce to t2 from a coerce from - -- to to t1, and t1 = Void or canCoerce(t0,t2), then optimize - - (val is ['coerceOrCroak,trip,t1', .]) and - (t0 := objCodeMode trip) and ([.,val0] := objCodeVal trip) and - ( (t1 = $Void) or canCoerceFrom(removeQuote t0,t2) ) => - -- just generate code for coercion, don't coerce constants - -- might be too big - intCodeGenCOERCE(objNew(val0, removeQuote t0), t2) - - val is ['THROW,label,code] => - if label is ['QUOTE, l] then label := l - null($compilingMap) or (label ^= mapCatchName($mapName)) => - objNew(['THROW,label,wrapped2Quote objVal - intCodeGenCOERCE(objNew(code,t1),t2)],t2) - -- we have a return statement. just send it back as is - objNew(val,t2) - - val is ['PROGN,:code,lastCode] => - objNew(['PROGN,:code,wrapped2Quote objVal - intCodeGenCOERCE(objNew(lastCode,t1),t2)],t2) - - val is ['COND,:conds] => - objNew(['COND, - :[[p,wrapped2Quote objVal intCodeGenCOERCE(objNew(v,t1),t2)] - for [p,v] in conds]],t2) - - -- specially handle subdomain - absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) - - -- specially handle coerce to Any - t2 = '(Any) => objNew(['CONS,MKQ t1,val],t2) - - -- optimize coerces from Any - (t1 = '(Any)) and (val is [ ='CONS,t1',val']) => - intCodeGenCOERCE(objNew(val',removeQuote t1'),t2) - - -- specially handle coerce from Equation to Boolean - (t1 is ['Equation,:.]) and (t2 = $Boolean) => - coerceByFunction(triple,t2) - - -- next is hack for if-then-elses - (t1 = '$NoValueMode) and (val is ['COND,pred]) => - code := - ['COND,pred, - [MKQ true,['throwKeyedMsg,MKQ "S2IM0016",MKQ $mapName]]] - objNew(code,t2) - - -- optimize coerces to Expression - t2 = $OutputForm => - coerceByFunction(triple,t2) - - isSubDomain(t1, $Integer) => - intCodeGenCOERCE(objNew(val, $Integer), t2) - - -- generate code - -- 1. See if the coercion will go through (absolutely) - -- Must be careful about variables or else things like - -- P I --> P[x] P I might not have the x in the original polynomial - -- put in the correct place - - (not containsVariables(t2)) and canCoerceByFunction(t1,t2) => - -- try coerceByFunction - (not canCoerceByMap(t1,t2)) and - (code := coerceByFunction(triple,t2)) => code - intCodeGenCoerce1(val,t1,t2) - - -- 2. Set up a failure point otherwise - - intCodeGenCoerce1(val,t1,t2) - -intCodeGenCoerce1(val,t1,t2) == - -- Internal function to previous one - -- designed to ensure that we don't use coerceOrCroak on mappings ---(t2 is ['Mapping,:.]) => THROW('coerceOrCroaker, 'croaked) - objNew(['coerceOrCroak,mkObjCode(['wrap,val],t1), - MKQ t2, MKQ $mapName],t2) - ---% Map components - -wrapMapBodyWithCatch body == - -- places a CATCH around the map body - -- note that we will someday have to fix up the catch identifier - -- to use the generated internal map name - $mapThrowCount = 0 => body - if body is ['failCheck,['coerceOrFail,trip,targ,mapn]] - then - trip is ['LIST,v,m,e] => - ['failCheck,['coerceOrFail, - ['LIST,['CATCH,MKQ mapCatchName $mapName, v],m,e],targ,mapn]] - keyedSystemError("S2GE0016",['"wrapMapBodyWithCatch", - '"bad CATCH for in function form"]) - else ['CATCH,MKQ mapCatchName $mapName,body] diff --git a/src/interp/i-code.boot.pamphlet b/src/interp/i-code.boot.pamphlet new file mode 100644 index 00000000..c58ff15e --- /dev/null +++ b/src/interp/i-code.boot.pamphlet @@ -0,0 +1,164 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-code.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Interpreter Code Generation Routines + +--Modified by JHD 9/9/93 to fix a problem with coerces inside +--interpreter functions being used as mappings. They were being +--handled with $useCoerceOrCroak being NIL, and therefore internal +--coercions were not correctly handled. Fix: remove dependence +--on $useCoerceOrCroak, and test explicitly for Mapping types. + +--% COERCE + +intCodeGenCOERCE(triple,t2) == + -- NOTE: returns a triple + t1 := objMode triple + t1 = $EmptyMode => NIL + t1 = t2 => triple + val := objVal triple + + -- if request is for a coerce to t2 from a coerce from + -- to to t1, and t1 = Void or canCoerce(t0,t2), then optimize + + (val is ['coerceOrCroak,trip,t1', .]) and + (t0 := objCodeMode trip) and ([.,val0] := objCodeVal trip) and + ( (t1 = $Void) or canCoerceFrom(removeQuote t0,t2) ) => + -- just generate code for coercion, don't coerce constants + -- might be too big + intCodeGenCOERCE(objNew(val0, removeQuote t0), t2) + + val is ['THROW,label,code] => + if label is ['QUOTE, l] then label := l + null($compilingMap) or (label ^= mapCatchName($mapName)) => + objNew(['THROW,label,wrapped2Quote objVal + intCodeGenCOERCE(objNew(code,t1),t2)],t2) + -- we have a return statement. just send it back as is + objNew(val,t2) + + val is ['PROGN,:code,lastCode] => + objNew(['PROGN,:code,wrapped2Quote objVal + intCodeGenCOERCE(objNew(lastCode,t1),t2)],t2) + + val is ['COND,:conds] => + objNew(['COND, + :[[p,wrapped2Quote objVal intCodeGenCOERCE(objNew(v,t1),t2)] + for [p,v] in conds]],t2) + + -- specially handle subdomain + absolutelyCanCoerceByCheating(t1,t2) => objNew(val,t2) + + -- specially handle coerce to Any + t2 = '(Any) => objNew(['CONS,MKQ t1,val],t2) + + -- optimize coerces from Any + (t1 = '(Any)) and (val is [ ='CONS,t1',val']) => + intCodeGenCOERCE(objNew(val',removeQuote t1'),t2) + + -- specially handle coerce from Equation to Boolean + (t1 is ['Equation,:.]) and (t2 = $Boolean) => + coerceByFunction(triple,t2) + + -- next is hack for if-then-elses + (t1 = '$NoValueMode) and (val is ['COND,pred]) => + code := + ['COND,pred, + [MKQ true,['throwKeyedMsg,MKQ "S2IM0016",MKQ $mapName]]] + objNew(code,t2) + + -- optimize coerces to Expression + t2 = $OutputForm => + coerceByFunction(triple,t2) + + isSubDomain(t1, $Integer) => + intCodeGenCOERCE(objNew(val, $Integer), t2) + + -- generate code + -- 1. See if the coercion will go through (absolutely) + -- Must be careful about variables or else things like + -- P I --> P[x] P I might not have the x in the original polynomial + -- put in the correct place + + (not containsVariables(t2)) and canCoerceByFunction(t1,t2) => + -- try coerceByFunction + (not canCoerceByMap(t1,t2)) and + (code := coerceByFunction(triple,t2)) => code + intCodeGenCoerce1(val,t1,t2) + + -- 2. Set up a failure point otherwise + + intCodeGenCoerce1(val,t1,t2) + +intCodeGenCoerce1(val,t1,t2) == + -- Internal function to previous one + -- designed to ensure that we don't use coerceOrCroak on mappings +--(t2 is ['Mapping,:.]) => THROW('coerceOrCroaker, 'croaked) + objNew(['coerceOrCroak,mkObjCode(['wrap,val],t1), + MKQ t2, MKQ $mapName],t2) + +--% Map components + +wrapMapBodyWithCatch body == + -- places a CATCH around the map body + -- note that we will someday have to fix up the catch identifier + -- to use the generated internal map name + $mapThrowCount = 0 => body + if body is ['failCheck,['coerceOrFail,trip,targ,mapn]] + then + trip is ['LIST,v,m,e] => + ['failCheck,['coerceOrFail, + ['LIST,['CATCH,MKQ mapCatchName $mapName, v],m,e],targ,mapn]] + keyedSystemError("S2GE0016",['"wrapMapBodyWithCatch", + '"bad CATCH for in function form"]) + else ['CATCH,MKQ mapCatchName $mapName,body] +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/i-eval.boot b/src/interp/i-eval.boot deleted file mode 100644 index 673ff85d..00000000 --- a/src/interp/i-eval.boot +++ /dev/null @@ -1,452 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Constructor Evaluation - -$noEvalTypeMsg := nil - -evalDomain form == - if $evalDomain then - sayMSG concat('" instantiating","%b",prefix2String form,"%d") - startTimingProcess 'instantiation - newType? form => form - result := eval mkEvalable form - stopTimingProcess 'instantiation - result - -mkEvalable form == - form is [op,:argl] => - op="QUOTE" => form - op="WRAPPED" => mkEvalable devaluate argl - op="Record" => mkEvalableRecord form - op="Union" => mkEvalableUnion form - op="Mapping"=> mkEvalableMapping form - op="Enumeration" => form - loadIfNecessary op - kind:= GETDATABASE(op,'CONSTRUCTORKIND) - cosig := GETDATABASE(op, 'COSIG) => - [op,:[val for x in argl for typeFlag in rest cosig]] where val == - typeFlag => - kind = 'category => MKQ x - VECP x => MKQ x - loadIfNecessary x - mkEvalable x - x is ['QUOTE,:.] => x - x is ['_#,y] => ['SIZE,MKQ y] - MKQ x - [op,:[mkEvalable x for x in argl]] - form=$EmptyMode => $Integer - IDENTP form and constructor?(form) => [form] - FBPIP form => BPINAME form - form - -mkEvalableMapping form == - [first form,:[mkEvalable d for d in rest form]] - -mkEvalableRecord form == - [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] - -mkEvalableUnion form == - isTaggedUnion form => - [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] - [first form,:[mkEvalable d for d in rest form]] - -evaluateType0 form == - -- Takes a parsed, unabbreviated type and evaluates it, replacing - -- type valued variables with their values, and calling bottomUp - -- on non-type valued arguemnts to the constructor - -- and finally checking to see whether the type satisfies the - -- conditions of its modemap - -- However, the input might be an attribute, not a type - -- $noEvalTypeMsg: fluid := true - domain:= isDomainValuedVariable form => domain - form = $EmptyMode => form - form = "?" => $EmptyMode - STRINGP form => form - form = "$" => form - $expandSegments : local := nil - form is ['typeOf,.] => - form' := mkAtree form - bottomUp form' - objVal getValue(form') - form is [op,:argl] => - op='CATEGORY => - argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] - form - op in '(Join Mapping) => - [op,:[evaluateType arg for arg in argl]] - op='Union => - argl and first argl is [x,.,.] and member(x,'(_: Declare)) => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - [op,:[evaluateType arg for arg in argl]] - op='Record => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - op='Enumeration => form - constructor? op => evaluateType1 form - NIL - constructor? form => - ATOM form => evaluateType [form] - throwEvalTypeMsg("S2IE0003",[form,form]) - -evaluateType form == - -- Takes a parsed, unabbreviated type and evaluates it, replacing - -- type valued variables with their values, and calling bottomUp - -- on non-type valued arguemnts to the constructor - -- and finally checking to see whether the type satisfies the - -- conditions of its modemap - domain:= isDomainValuedVariable form => domain - form = $EmptyMode => form - form = "?" => $EmptyMode - STRINGP form => form - form = "$" => form - $expandSegments : local := nil - form is ['typeOf,.] => - form' := mkAtree form - bottomUp form' - objVal getValue(form') - form is [op,:argl] => - op='CATEGORY => - argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] - form - op in '(Join Mapping) => - [op,:[evaluateType arg for arg in argl]] - op='Union => - argl and first argl is [x,.,.] and member(x,'(_: Declare)) => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - [op,:[evaluateType arg for arg in argl]] - op='Record => - [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] - op='Enumeration => form - evaluateType1 form - constructor? form => - ATOM form => evaluateType [form] - throwEvalTypeMsg("S2IE0003",[form,form]) - throwEvalTypeMsg("S2IE0004",[form]) - -evaluateType1 form == - --evaluates the arguments passed to a constructor - [op,:argl]:= form - constructor? op => - null (sig := getConstructorSignature form) => - throwEvalTypeMsg("S2IE0005",[form]) - [.,:ml] := sig - ml := replaceSharps(ml,form) - # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) - for x in argl for m in ml for argnum in 1.. repeat - typeList := [v,:typeList] where v == - categoryForm?(m) => - m := evaluateType MSUBSTQ(x,'_$,m) - evalCategory(x' := (evaluateType x), m) => x' - throwEvalTypeMsg("S2IE0004",[form]) - m := evaluateType m - GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and - (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => - [zt,:zv]:= z1:= getAndEvalConstructorArgument tree - (v:= coerceOrRetract(z1,m)) => objValUnwrap v - throwKeyedMsgCannotCoerceWithValue(zv,zt,m) - if x = $EmptyMode then x := $quadSymbol - throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) - [op,:NREVERSE typeList] - throwEvalTypeMsg("S2IE0007",[op]) - -throwEvalTypeMsg(msg, args) == - $noEvalTypeMsg => spadThrow() - throwKeyedMsg(msg, args) - -makeOrdinal i == - ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) - -evaluateSignature sig == - -- calls evaluateType on a signature - sig is [ ='SIGNATURE,fun,sigl] => - ['SIGNATURE,fun, - [(t = '_$ => t; evaluateType(t)) for t in sigl]] - sig - ---% Code Evaluation - --- This code generates, then evaluates code during the bottom up phase --- of interpretation - -splitIntoBlocksOf200 a == - null a => nil - [[first (r:=x) for x in tails a for i in 1..200], - :splitIntoBlocksOf200 rest r] - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -evalForm(op,opName,argl,mmS) == - -- applies the first applicable function - - for mm in mmS until form repeat - [sig,fun,cond]:= mm - (CAR sig) = 'interpOnly => form := CAR sig - #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 - form:= - $genValue or null cond => - [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig] - [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig for c in cond] - form or null argl => - dc:= CAR sig - form := - dc='local => --[fun,:form] - atom fun => - fun in $localVars => ['SPADCALL,:form,fun] - [fun,:form,NIL] - ['SPADCALL,:form,fun] - dc is ["__FreeFunction__",:freeFun] => - ['SPADCALL,:form,freeFun] - fun is ['XLAM,xargs,:xbody] => - rec := first form - xbody is [['RECORDELT,.,ind,len]] => - optRECORDELT([CAAR xbody,rec,ind,len]) - xbody is [['SETRECORDELT,.,ind,len,.]] => - optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) - xbody is [['RECORDCOPY,.,len]] => - optRECORDCOPY([CAAR xbody,rec,len]) - ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] - dcVector := evalDomain dc - fun0 := - newType? CAAR mm => - mm' := first ncSigTransform mm - ncGetFunction(opName, first mm', rest mm') - NRTcompileEvalForm(opName,rest sig,dcVector) - null fun0 => throwKeyedMsg("S2IE0008",[opName]) - [bpi,:domain] := fun0 - EQ(bpi,function Undef) => - sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) - NIL - if $NRTmonitorIfTrue = true then - sayBrightlyNT ['"Applying ",first fun0,'" to:"] - pp [devaluateDeeply x for x in form] - _$:fluid := domain - ['SPADCALL, :form, fun0] - not form => nil --- not form => throwKeyedMsg("S2IE0008",[opName]) - form='interpOnly => rewriteMap(op,opName,argl) - targetType := CADR sig - if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType - evalFormMkValue(op,form,targetType) - -sideEffectedArg?(t,sig,opName) == - opString := SYMBOL_-NAME opName - (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil - dc := first sig - t = dc - -getArgValue(a, t) == - atom a and not VECP a => - t' := coerceOrRetract(getBasicObject a,t) - t' and wrapped2Quote objVal t' - v := getArgValue1(a, t) => v - alt := altTypeOf(objMode getValue a, a, nil) => - t' := coerceInt(getValue a, alt) - t' := coerceOrRetract(t',t) - t' and wrapped2Quote objVal t' - nil - -getArgValue1(a,t) == - -- creates a value for a, coercing to t - t' := getValue(a) => - (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and - objValUnwrap(t') is ['MAP,:.] => - getMappingArgValue(a,t,m) - t' := coerceOrRetract(t',t) - t' and wrapped2Quote objVal t' - systemErrorHere '"getArgValue" - -getArgValue2(a,t,se?,opName) == - se? and (objMode(getValue a) ^= t) => - throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) - getArgValue(a,t) - -getArgValueOrThrow(x, type) == - getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) - -getMappingArgValue(a,t,m is ['Mapping,:ml]) == - (una := getUnname a) in $localVars => - $genValue => - name := get(una,'name,$env) - a.0 := name - mmS := selectLocalMms(a,name,rest ml, nil) - or/[mm for mm in mmS | - (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] - NIL - una - mmS := selectLocalMms(a,una,rest ml, nil) - or/[mm for mm in mmS | - (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] - NIL - -getArgValueComp2(arg, type, cond, se?, opName) == - se? and (objMode(getValue arg) ^= type) => - throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) - getArgValueComp(arg, type, cond) - -getArgValueComp(arg,type,cond) == - -- getArgValue for compiled case. if there is a condition then - -- v must be data to verify that coerceInteractive succeeds. - v:= getArgValue(arg,type) - null v => nil - null cond => v - v is ['QUOTE,:.] or getBasicMode v => v - n := getUnnameIfCan arg - if num := isSharpVarWithNum n then - not $compilingMap => n := 'unknownVar - alias := get($mapName,'alias,$e) - n := alias.(num - 1) - keyedMsgCompFailure("S2IE0010",[n]) - -evalFormMkValue(op,form,tm) == - val:= - u:= - $genValue => wrap timedEVALFUN form - form - objNew(u,tm) ---+ - if $NRTmonitorIfTrue = true then - sayBrightlyNT ['"Value of ",op.0,'" ===> "] - pp unwrap u - putValue(op,val) - [tm] - -failCheck x == - x = '"failed" => - stopTimingProcess peekTimedName() - THROW('interpreter,objNewWrap('"failed",$String)) - x = $coerceFailure => - NIL - x - ---% Some Antique Comments About the Interpreter - ---EVAL BOOT contains the top level interface to the Scratchhpad-II ---interpreter. The Entry point into the interpreter from the parser is ---processInteractive. ---The type analysis algorithm is contained in the file BOTMUP BOOT, ---and MODSEL boot, ---the map handling routines are in MAP BOOT and NEWMAP BOOT, and ---the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. --- ---Conventions: --- All spad values in the interpreter are passed around in triples. --- These are lists of three items: [value,mode,environment]. The value --- may be wrapped (this is a pair whose CAR is the atom WRAPPED and --- whose CDR is the value), which indicates that it is a real value, --- or unwrapped in which case it needs to be EVALed to produce the --- proper value. The mode is the type of value, and should always be --- completely specified (not contain $EmptyMode). The environment --- is always empty, and is included for historical reasons. --- ---Modemaps: --- Modemaps are descriptions of compiled Spad function which the --- interpreter uses to perform type analysis. They consist of patterns --- of types for the arguments, and conditions the types must satisfy --- for the function to apply. For each function name there is a list --- of modemaps in file MODEMAP DATABASE for each distinct function with --- that name. The following is the list of the modemaps for "*" --- (multiplication. The first modemap (the one with the labels) is for --- module mltiplication which is multiplication of an element of a --- module by a member of its scalar domain. --- --- This is the signature pattern for the modemap, it is of the form: --- (DomainOfComputation TargetType ) --- | --- | This is the predicate that needs to be --- | satisfied for the modemap to apply --- | | --- V | --- /-----------/ | --- ( ( (*1 *1 *2 *1) V --- /-----------------------------------------------------------/ --- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) --- . CATDEF) <-- This is the file where the function was defined --- ( (*1 *1 *2 *1) --- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) --- . CATDEF) --- ( (*1 *1 *2 *1) --- ( (AND --- (isDomain *2 (NonNegativeInteger)) --- (ofCategory *1 (AbelianMonoid))) ) --- . CATDEF) --- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) --- ) --- ---Environments: --- Environments associate properties with atoms. --- (see CUTIL BOOT for the exact structure of environments). --- Some common properties are: --- modeSet: --- During interpretation we build a modeSet property for each node in --- the expression. This is (in theory) a list of all the types --- possible for the node. In the current implementation these --- modeSets always contain a single type. --- value: --- Value properties are always triples. This is where the values of --- variables are stored. We also build value properties for internal --- nodes during the bottom up phase. --- mode: --- This is the declared type of an identifier. --- --- There are several different environments used in the interpreter: --- $InteractiveFrame : this is the environment where the user --- values are stored. Any side effects of evaluation of a top-level --- expression are stored in this environment. It is always used as --- the starting environment for interpretation. --- $e : This is the name used for $InteractiveFrame while interpreting. --- $env : This is local environment used by the interpreter. --- Only temporary information (such as types of local variables is --- stored in $env. --- It is thrown away after evaluation of each expression. --- ---Frequently used global variables: --- $genValue : if true then evaluate generated code, otherwise leave --- code unevaluated. If $genValue is false then we are compiling. --- $op: name of the top level operator (unused except in map printing) --- $mapList: list of maps being type analyzed, used in recursive --- map type anlysis. --- $compilingMap: true when compiling a map, used to detect where to --- THROW when interpret-only is invoked --- $compilingLoop: true when compiling a loop body, used to control --- nesting level of interp-only loop CATCH points --- $interpOnly: true when in interpret only mode, used to call --- alternate forms of COLLECT and REPEAT. --- $inCOLLECT: true when compiling a COLLECT, used only for hacked --- stream compiler. --- $StreamFrame: used in printing streams, it is the environment --- where local stream variables are stored --- $declaredMode: Weak type propagation for symbols, set in upCOERCE --- and upLET. This variable is used to determine --- the alternate polynomial types of Symbols. --- $localVars: list of local variables in a map body --- $MapArgumentTypeList: hack for stream compilation diff --git a/src/interp/i-eval.boot.pamphlet b/src/interp/i-eval.boot.pamphlet new file mode 100644 index 00000000..0803bae7 --- /dev/null +++ b/src/interp/i-eval.boot.pamphlet @@ -0,0 +1,474 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp i-eval.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Constructor Evaluation + +$noEvalTypeMsg := nil + +evalDomain form == + if $evalDomain then + sayMSG concat('" instantiating","%b",prefix2String form,"%d") + startTimingProcess 'instantiation + newType? form => form + result := eval mkEvalable form + stopTimingProcess 'instantiation + result + +mkEvalable form == + form is [op,:argl] => + op="QUOTE" => form + op="WRAPPED" => mkEvalable devaluate argl + op="Record" => mkEvalableRecord form + op="Union" => mkEvalableUnion form + op="Mapping"=> mkEvalableMapping form + op="Enumeration" => form + loadIfNecessary op + kind:= GETDATABASE(op,'CONSTRUCTORKIND) + cosig := GETDATABASE(op, 'COSIG) => + [op,:[val for x in argl for typeFlag in rest cosig]] where val == + typeFlag => + kind = 'category => MKQ x + VECP x => MKQ x + loadIfNecessary x + mkEvalable x + x is ['QUOTE,:.] => x + x is ['_#,y] => ['SIZE,MKQ y] + MKQ x + [op,:[mkEvalable x for x in argl]] + form=$EmptyMode => $Integer + IDENTP form and constructor?(form) => [form] + FBPIP form => BPINAME form + form + +mkEvalableMapping form == + [first form,:[mkEvalable d for d in rest form]] + +mkEvalableRecord form == + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + +mkEvalableUnion form == + isTaggedUnion form => + [first form,:[[":",n,mkEvalable d] for [":",n,d] in rest form]] + [first form,:[mkEvalable d for d in rest form]] + +evaluateType0 form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + -- However, the input might be an attribute, not a type + -- $noEvalTypeMsg: fluid := true + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + constructor? op => evaluateType1 form + NIL + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + +evaluateType form == + -- Takes a parsed, unabbreviated type and evaluates it, replacing + -- type valued variables with their values, and calling bottomUp + -- on non-type valued arguemnts to the constructor + -- and finally checking to see whether the type satisfies the + -- conditions of its modemap + domain:= isDomainValuedVariable form => domain + form = $EmptyMode => form + form = "?" => $EmptyMode + STRINGP form => form + form = "$" => form + $expandSegments : local := nil + form is ['typeOf,.] => + form' := mkAtree form + bottomUp form' + objVal getValue(form') + form is [op,:argl] => + op='CATEGORY => + argl is [x,:sigs] => [op,x,:[evaluateSignature(s) for s in sigs]] + form + op in '(Join Mapping) => + [op,:[evaluateType arg for arg in argl]] + op='Union => + argl and first argl is [x,.,.] and member(x,'(_: Declare)) => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + [op,:[evaluateType arg for arg in argl]] + op='Record => + [op,:[['_:,sel,evaluateType type] for ['_:,sel,type] in argl]] + op='Enumeration => form + evaluateType1 form + constructor? form => + ATOM form => evaluateType [form] + throwEvalTypeMsg("S2IE0003",[form,form]) + throwEvalTypeMsg("S2IE0004",[form]) + +evaluateType1 form == + --evaluates the arguments passed to a constructor + [op,:argl]:= form + constructor? op => + null (sig := getConstructorSignature form) => + throwEvalTypeMsg("S2IE0005",[form]) + [.,:ml] := sig + ml := replaceSharps(ml,form) + # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) + for x in argl for m in ml for argnum in 1.. repeat + typeList := [v,:typeList] where v == + categoryForm?(m) => + m := evaluateType MSUBSTQ(x,'_$,m) + evalCategory(x' := (evaluateType x), m) => x' + throwEvalTypeMsg("S2IE0004",[form]) + m := evaluateType m + GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and + (tree := mkAtree x) and putTarget(tree,m) and ((bottomUp tree) is [m1]) => + [zt,:zv]:= z1:= getAndEvalConstructorArgument tree + (v:= coerceOrRetract(z1,m)) => objValUnwrap v + throwKeyedMsgCannotCoerceWithValue(zv,zt,m) + if x = $EmptyMode then x := $quadSymbol + throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) + [op,:NREVERSE typeList] + throwEvalTypeMsg("S2IE0007",[op]) + +throwEvalTypeMsg(msg, args) == + $noEvalTypeMsg => spadThrow() + throwKeyedMsg(msg, args) + +makeOrdinal i == + ('(first second third fourth fifth sixth seventh eighth ninth tenth)).(i-1) + +evaluateSignature sig == + -- calls evaluateType on a signature + sig is [ ='SIGNATURE,fun,sigl] => + ['SIGNATURE,fun, + [(t = '_$ => t; evaluateType(t)) for t in sigl]] + sig + +--% Code Evaluation + +-- This code generates, then evaluates code during the bottom up phase +-- of interpretation + +splitIntoBlocksOf200 a == + null a => nil + [[first (r:=x) for x in tails a for i in 1..200], + :splitIntoBlocksOf200 rest r] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +evalForm(op,opName,argl,mmS) == + -- applies the first applicable function + + for mm in mmS until form repeat + [sig,fun,cond]:= mm + (CAR sig) = 'interpOnly => form := CAR sig + #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 + form:= + $genValue or null cond => + [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig] + [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig for c in cond] + form or null argl => + dc:= CAR sig + form := + dc='local => --[fun,:form] + atom fun => + fun in $localVars => ['SPADCALL,:form,fun] + [fun,:form,NIL] + ['SPADCALL,:form,fun] + dc is ["__FreeFunction__",:freeFun] => + ['SPADCALL,:form,freeFun] + fun is ['XLAM,xargs,:xbody] => + rec := first form + xbody is [['RECORDELT,.,ind,len]] => + optRECORDELT([CAAR xbody,rec,ind,len]) + xbody is [['SETRECORDELT,.,ind,len,.]] => + optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) + xbody is [['RECORDCOPY,.,len]] => + optRECORDCOPY([CAAR xbody,rec,len]) + ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] + dcVector := evalDomain dc + fun0 := + newType? CAAR mm => + mm' := first ncSigTransform mm + ncGetFunction(opName, first mm', rest mm') + NRTcompileEvalForm(opName,rest sig,dcVector) + null fun0 => throwKeyedMsg("S2IE0008",[opName]) + [bpi,:domain] := fun0 + EQ(bpi,function Undef) => + sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) + NIL + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Applying ",first fun0,'" to:"] + pp [devaluateDeeply x for x in form] + _$:fluid := domain + ['SPADCALL, :form, fun0] + not form => nil +-- not form => throwKeyedMsg("S2IE0008",[opName]) + form='interpOnly => rewriteMap(op,opName,argl) + targetType := CADR sig + if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType + evalFormMkValue(op,form,targetType) + +sideEffectedArg?(t,sig,opName) == + opString := SYMBOL_-NAME opName + (opName ^= 'setelt) and (ELT(opString, #opString-1) ^= char '_!) => nil + dc := first sig + t = dc + +getArgValue(a, t) == + atom a and not VECP a => + t' := coerceOrRetract(getBasicObject a,t) + t' and wrapped2Quote objVal t' + v := getArgValue1(a, t) => v + alt := altTypeOf(objMode getValue a, a, nil) => + t' := coerceInt(getValue a, alt) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + nil + +getArgValue1(a,t) == + -- creates a value for a, coercing to t + t' := getValue(a) => + (m := getMode a) and (m is ['Mapping,:ml]) and (m = t) and + objValUnwrap(t') is ['MAP,:.] => + getMappingArgValue(a,t,m) + t' := coerceOrRetract(t',t) + t' and wrapped2Quote objVal t' + systemErrorHere '"getArgValue" + +getArgValue2(a,t,se?,opName) == + se? and (objMode(getValue a) ^= t) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue a), t]) + getArgValue(a,t) + +getArgValueOrThrow(x, type) == + getArgValue(x,type) or throwKeyedMsg("S2IC0007",[type]) + +getMappingArgValue(a,t,m is ['Mapping,:ml]) == + (una := getUnname a) in $localVars => + $genValue => + name := get(una,'name,$env) + a.0 := name + mmS := selectLocalMms(a,name,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + una + mmS := selectLocalMms(a,una,rest ml, nil) + or/[mm for mm in mmS | + (mm is [[., :ml1],oldName,:.] and ml=ml1)] => MKQ [oldName] + NIL + +getArgValueComp2(arg, type, cond, se?, opName) == + se? and (objMode(getValue arg) ^= type) => + throwKeyedMsg("S2IE0013", [opName, objMode(getValue arg), type]) + getArgValueComp(arg, type, cond) + +getArgValueComp(arg,type,cond) == + -- getArgValue for compiled case. if there is a condition then + -- v must be data to verify that coerceInteractive succeeds. + v:= getArgValue(arg,type) + null v => nil + null cond => v + v is ['QUOTE,:.] or getBasicMode v => v + n := getUnnameIfCan arg + if num := isSharpVarWithNum n then + not $compilingMap => n := 'unknownVar + alias := get($mapName,'alias,$e) + n := alias.(num - 1) + keyedMsgCompFailure("S2IE0010",[n]) + +evalFormMkValue(op,form,tm) == + val:= + u:= + $genValue => wrap timedEVALFUN form + form + objNew(u,tm) +--+ + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Value of ",op.0,'" ===> "] + pp unwrap u + putValue(op,val) + [tm] + +failCheck x == + x = '"failed" => + stopTimingProcess peekTimedName() + THROW('interpreter,objNewWrap('"failed",$String)) + x = $coerceFailure => + NIL + x + +--% Some Antique Comments About the Interpreter + +--EVAL BOOT contains the top level interface to the Scratchhpad-II +--interpreter. The Entry point into the interpreter from the parser is +--processInteractive. +--The type analysis algorithm is contained in the file BOTMUP BOOT, +--and MODSEL boot, +--the map handling routines are in MAP BOOT and NEWMAP BOOT, and +--the interactive coerce routines are in COERCE BOOT and COERCEFN BOOT. +-- +--Conventions: +-- All spad values in the interpreter are passed around in triples. +-- These are lists of three items: [value,mode,environment]. The value +-- may be wrapped (this is a pair whose CAR is the atom WRAPPED and +-- whose CDR is the value), which indicates that it is a real value, +-- or unwrapped in which case it needs to be EVALed to produce the +-- proper value. The mode is the type of value, and should always be +-- completely specified (not contain $EmptyMode). The environment +-- is always empty, and is included for historical reasons. +-- +--Modemaps: +-- Modemaps are descriptions of compiled Spad function which the +-- interpreter uses to perform type analysis. They consist of patterns +-- of types for the arguments, and conditions the types must satisfy +-- for the function to apply. For each function name there is a list +-- of modemaps in file MODEMAP DATABASE for each distinct function with +-- that name. The following is the list of the modemaps for "*" +-- (multiplication. The first modemap (the one with the labels) is for +-- module mltiplication which is multiplication of an element of a +-- module by a member of its scalar domain. +-- +-- This is the signature pattern for the modemap, it is of the form: +-- (DomainOfComputation TargetType ) +-- | +-- | This is the predicate that needs to be +-- | satisfied for the modemap to apply +-- | | +-- V | +-- /-----------/ | +-- ( ( (*1 *1 *2 *1) V +-- /-----------------------------------------------------------/ +-- ( (AND (ofCategory *1 (Module *2)) (ofCategory *2 (SimpleRing))) ) +-- . CATDEF) <-- This is the file where the function was defined +-- ( (*1 *1 *2 *1) +-- ( (AND (isDomain *2 (Integer)) (ofCategory *1 (AbelianGroup))) ) +-- . CATDEF) +-- ( (*1 *1 *2 *1) +-- ( (AND +-- (isDomain *2 (NonNegativeInteger)) +-- (ofCategory *1 (AbelianMonoid))) ) +-- . CATDEF) +-- ((*1 *1 *1 *1) ((ofCategory *1 (SemiGroup)) ) . CATDEF) +-- ) +-- +--Environments: +-- Environments associate properties with atoms. +-- (see CUTIL BOOT for the exact structure of environments). +-- Some common properties are: +-- modeSet: +-- During interpretation we build a modeSet property for each node in +-- the expression. This is (in theory) a list of all the types +-- possible for the node. In the current implementation these +-- modeSets always contain a single type. +-- value: +-- Value properties are always triples. This is where the values of +-- variables are stored. We also build value properties for internal +-- nodes during the bottom up phase. +-- mode: +-- This is the declared type of an identifier. +-- +-- There are several different environments used in the interpreter: +-- $InteractiveFrame : this is the environment where the user +-- values are stored. Any side effects of evaluation of a top-level +-- expression are stored in this environment. It is always used as +-- the starting environment for interpretation. +-- $e : This is the name used for $InteractiveFrame while interpreting. +-- $env : This is local environment used by the interpreter. +-- Only temporary information (such as types of local variables is +-- stored in $env. +-- It is thrown away after evaluation of each expression. +-- +--Frequently used global variables: +-- $genValue : if true then evaluate generated code, otherwise leave +-- code unevaluated. If $genValue is false then we are compiling. +-- $op: name of the top level operator (unused except in map printing) +-- $mapList: list of maps being type analyzed, used in recursive +-- map type anlysis. +-- $compilingMap: true when compiling a map, used to detect where to +-- THROW when interpret-only is invoked +-- $compilingLoop: true when compiling a loop body, used to control +-- nesting level of interp-only loop CATCH points +-- $interpOnly: true when in interpret only mode, used to call +-- alternate forms of COLLECT and REPEAT. +-- $inCOLLECT: true when compiling a COLLECT, used only for hacked +-- stream compiler. +-- $StreamFrame: used in printing streams, it is the environment +-- where local stream variables are stored +-- $declaredMode: Weak type propagation for symbols, set in upCOERCE +-- and upLET. This variable is used to determine +-- the alternate polynomial types of Symbols. +-- $localVars: list of local variables in a map body +-- $MapArgumentTypeList: hack for stream compilation +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot deleted file mode 100644 index 429123a5..00000000 --- a/src/interp/i-map.boot +++ /dev/null @@ -1,1159 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% User Function Creation and Analysis Code - -SETANDFILEQ($mapTarget,nil) -SETANDFILEQ($mapReturnTypes,nil) -SETANDFILEQ($mapName,'noMapName) -SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map -SETANDFILEQ($compilingMap, NIL) -SETANDFILEQ($definingMap, NIL) - ---% Generating internal names for functions - -SETANDFILEQ($specialMapNameSuffix, NIL) - -makeInternalMapName(userName,numArgs,numMms,extraPart) == - name := CONCAT('"*",STRINGIMAGE numArgs,'";", - object2String userName,'";",STRINGIMAGE numMms,'";", - object2String frameName first $interpreterFrameRing ) - if extraPart then name := CONCAT(name,'";",extraPart) - if $specialMapNameSuffix then - name := CONCAT(name,'";",$specialMapNameSuffix) - INTERN name - -isInternalMapName name == - -- this only returns true or false as a "best guess" - (not IDENTP(name)) or (name = "*") or (name = "**") => false - sz := SIZE (name' := PNAME name) - (sz < 7) or (char("*") ^= name'.0) => false - null DIGITP name'.1 => false - null STRPOS('"_;",name',1,NIL) => false - -- good enough - true - -makeInternalMapMinivectorName(name) == - STRINGP name => - INTERN STRCONC(name,'";MV") - INTERN STRCONC(PNAME name,'";MV") - -mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") - -mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") - ---% Adding a function definition - -isMapExpr x == x is ['MAP,:.] - -isMap x == - y := get(x,'value,$InteractiveFrame) => - objVal y is ['MAP,:.] => x - -addDefMap(['DEF,lhs,mapsig,.,rhs],pred) == - -- Create a new map, add to an existing one, or define a variable - -- compute the dependencies for a map - - -- next check is for bad forms on the lhs of the ==, such as - -- numbers, constants. - if not PAIRP lhs then - op := lhs - putHist(op,'isInterpreterRule,true,$e) - putHist(op,'isInterpreterFunction,false,$e) - lhs := [lhs] - else - -- this is a function definition. If it has been declared - -- previously, make sure it is Mapping. - op := first lhs - (oldMode := get(op,'mode,$e)) and oldMode isnt ['Mapping,:.] => - throwKeyedMsg("S2IM0001",[op,oldMode]) - putHist(op,'isInterpreterRule,false,$e) - putHist(op,'isInterpreterFunction,true,$e) - - (NUMBERP(op) or op in '(true false nil % %%)) => - throwKeyedMsg("S2IM0002",[lhs]) - - -- verify a constructor abbreviation is not used on the lhs - op ^= (op' := unabbrev op) => throwKeyedMsg("S2IM0003",[op,op']) - - -- get the formal parameters. These should only be atomic symbols - -- that are not numbers. - parameters := [p for p in rest lhs | IDENTP(p)] - - -- see if a signature has been given. if anything in mapsig is NIL, - -- then declaration was omitted. - someDecs := nil - allDecs := true - mapmode := ['Mapping] - $env:local := [[NIL]] - $eval:local := true --generate code-- don't just type analyze - $genValue:local := true --evaluate all generated code - for d in mapsig repeat - if d then - someDecs := true - d' := evaluateType unabbrev d - isPartialMode d' => throwKeyedMsg("S2IM0004",NIL) --- tree := mkAtree d' --- null (d' := isType tree) => throwKeyedMsg("S2IM0005",[d]) - mapmode := [d',:mapmode] - else allDecs := false - if allDecs then - mapmode := nreverse mapmode - putHist(op,'mode,mapmode,$e) - sayKeyedMsg("S2IM0006",[formatOpSignature(op,rest mapmode)]) - else if someDecs then throwKeyedMsg("S2IM0007",[op]) - - -- if map is declared, check that signature arg count is the - -- same as what is given. - if get(op,'mode,$e) is ['Mapping,.,:mapargs] then - EQCAR(rhs,'rules) => - 0 ^= (numargs := # rest lhs) => - throwKeyedMsg("S2IM0027",[numargs,op]) - # rest lhs ^= # mapargs => throwKeyedMsg("S2IM0008",[op]) - --get all the user variables in the map definition. This is a multi - --step process as this should not include recursive calls to the map - --itself, or the formal parameters - userVariables1 := getUserIdentifiersIn rhs - $freeVars: local := NIL - $localVars: local := NIL - for parm in parameters repeat mkLocalVar($mapName,parm) - userVariables2 := setDifference(userVariables1,findLocalVars(op,rhs)) - userVariables3 := setDifference(userVariables2, parameters) - userVariables4 := REMDUP setDifference (userVariables3, [op]) - - --figure out the new dependencies for the new map (what it depends on) - newDependencies := makeNewDependencies (op, userVariables4) - putDependencies (op, newDependencies) - clearDependencies(op,'T) - addMap(lhs,rhs,pred) - -addMap(lhs,rhs,pred) == - [op,:argl] := lhs - $sl: local:= nil - formalArgList:= [mkFormalArg(makeArgumentIntoNumber x,s) - for x in argl for s in $FormalMapVariableList] - argList:= - [fn for x in formalArgList] where - fn == - if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s) - x - mkMapAlias(op,argl) - argPredList:= NREVERSE predList - finalPred := --- handle g(a,T)==a+T confusion between pred=T and T variable - MKPF((pred and (pred ^= 'T) => [:argPredList,SUBLISNQ($sl,pred)]; argPredList),"and") - body:= SUBLISNQ($sl,rhs) - oldMap := - (obj := get(op,'value,$InteractiveFrame)) => objVal obj - NIL - newMap := augmentMap(op,argList,finalPred,body,oldMap) - null newMap => - sayRemoveFunctionOrValue op - putHist(op,'alias,nil,$e) - " " -- clears value--- see return from addDefMap in tree2Atree1 - if get(op,'isInterpreterRule,$e) then type := ['RuleCalled,op] - else type := ['FunctionCalled,op] - recursive := - depthOfRecursion(op,newMap) = 0 => false - true - putHist(op,'recursive,recursive,$e) - objNew(newMap,type) - -augmentMap(op,args,pred,body,oldMap) == - pattern:= makePattern(args,pred) - newMap:=deleteMap(op,pattern,oldMap) - body=" " => - if newMap=oldMap then - sayMSG ['" Cannot find part of",:bright op,'"to delete."] - newMap --just delete rule if body is - entry:= [pattern,:body] - resultMap:= - newMap is ["MAP",:tail] => ["MAP",:tail,entry] - ["MAP",entry] - resultMap - -deleteMap(op,pattern,map) == - map is ["MAP",:tail] => - newMap:= ['MAP,:[x for x in tail | w]] where w == - x is [=pattern,:replacement] => sayDroppingFunctions(op,[x]) - true - null rest newMap => nil - newMap - NIL - -getUserIdentifiersIn body == - null body => nil - IDENTP body => - isSharpVarWithNum body => nil - body=" " => nil - [body] - body is ["WRAPPED",:.] => nil - (body is ["COLLECT",:itl,body1]) or (body is ['REPEAT,:itl,body1]) => - userIds := - S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1) - S_-(userIds,getIteratorIds itl) - body is [op,:l] => - argIdList:= "append"/[getUserIdentifiersIn y for y in l] - bodyIdList := - CONSP op or not (GET(op,'Nud) or GET(op,'Led) or GET(op,'up))=> - NCONC(getUserIdentifiersIn op, argIdList) - argIdList - REMDUP bodyIdList - -getUserIdentifiersInIterators itl == - for x in itl repeat - x is ["STEP",i,:l] => - varList:= [:"append"/[getUserIdentifiersIn y for y in l],:varList] - x is ["IN",.,y] => varList:= [:getUserIdentifiersIn y,:varList] - x is ["ON",.,y] => varList:= [:getUserIdentifiersIn y,:varList] - x is [op,a] and op in '(_| WHILE UNTIL) => - varList:= [:getUserIdentifiersIn a,:varList] - keyedSystemError("S2GE0016",['"getUserIdentifiersInIterators", - '"unknown iterator construct"]) - REMDUP varList - -getIteratorIds itl == - for x in itl repeat - x is ["STEP",i,:.] => varList:= [i,:varList] - x is ["IN",y,:.] => varList:= [y,:varList] - x is ["ON",y,:.] => varList:= [y,:varList] - nil - varList - -makeArgumentIntoNumber x == - x=$Zero => 0 - x=$One => 1 - atom x => x - x is ["-",n] and NUMBERP n => -n - [removeZeroOne first x,:removeZeroOne rest x] - -mkMapAlias(op,argl) == - u:= mkAliasList argl - newAlias := - alias:= get(op,"alias",$e) => [(y => y; x) for x in alias for y in u] - u - $e:= putHist(op,"alias",newAlias,$e) - -mkAliasList l == fn(l,nil) where fn(l,acc) == - null l => NREVERSE acc - not IDENTP first l or first l in acc => fn(rest l,[nil,:acc]) - fn(rest l,[first l,:acc]) - -args2Tuple args == - args is [first,:rest] => - null rest => first - ["Tuple",:args] - nil - -makePattern(args,pred) == - nargs:= #args - nargs = 1 => - pred is ["=","#1",n] => n - addPatternPred("#1",pred) - u:= canMakeTuple(nargs,pred) => u - addPatternPred(["Tuple",:TAKE(nargs,$FormalMapVariableList)],pred) - -addPatternPred(arg,pred) == - pred=true => arg - ["|",arg,pred] - -canMakeTuple(nargs,pred) == - pred is ["and",:l] and nargs=#l and - (u:= [(x is ["=",=y,a] => a; return nil) - for y in $FormalMapVariableList for x in orderList l]) => - ["Tuple",:u] - -sayRemoveFunctionOrValue x == - (obj := getValue x) and (md := objMode obj) => - md = $EmptyMode => - sayMessage ['" ",:bright x,'"now has no function parts."] - sayMessage ['" value for",:bright x,'"has been removed."] - sayMessage ['" ",:bright x,'"has no value so this does nothing."] - -sayDroppingFunctions(op,l) == - sayKeyedMsg("S2IM0017",[#l,op]) - if $displayDroppedMap then - for [pattern,:replacement] in l repeat - displaySingleRule(op,pattern,replacement) - nil - -makeRuleForm(op,pattern)== - pattern is ["Tuple",:l] => [op,:l] - [op,:pattern] - -mkFormalArg(x,s) == - isConstantArgument x => ["SUCHTHAT",s,["=",s,x]] - isPatternArgument x => ["SUCHTHAT",s,["is",s,x]] - IDENTP x => - y:= LASSOC(x,$sl) => ["SUCHTHAT",s,["=",s,y]] - $sl:= [[x,:s],:$sl] - s - ['SUCHTHAT,s,["=",s,x]] - -isConstantArgument x == - NUMBERP x => x - x is ["QUOTE",.] => x - -isPatternArgument x == x is ["construct",:.] - ---% Map dependencies - -makeNewDependencies (op, userVariables) == - null userVariables => nil - --add the new dependencies - [[(first userVariables),op], - :makeNewDependencies (op, rest userVariables)] - -putDependencies (op, dependencies) == - oldDependencies := getFlag "$dependencies" - --remove the obsolete dependencies: all those that applied to the - --old definition, but may not apply here. If they do, they'll be - --in the list of new dependencies anyway - oldDependencies := removeObsoleteDependencies (op, oldDependencies) where - removeObsoleteDependencies (op, oldDep) == - null oldDep => nil - op = rest first oldDep => - removeObsoleteDependencies (op, rest oldDep) - [first oldDep,:removeObsoleteDependencies (op, rest oldDep)] - --Create the list of dependencies to output. This will be all the - --old dependencies that are still applicable, and all the new ones - --that have just been generated. Remember that the list of - --dependencies does not just include those for the map just being - --defined, but includes those for all maps and variables that exist - newDependencies := union (dependencies, oldDependencies) - putFlag ("$dependencies", newDependencies) - -clearDependencies(x,clearLocalModemapsIfTrue) == - $dependencies: local:= COPY getFlag "$dependencies" - clearDep1(x,nil,nil,$dependencies) - -clearDep1(x,toDoList,doneList,depList) == - x in doneList => nil - clearCache x - newDone:= [x,:doneList] - until null a repeat - a:= ASSQ(x,depList) - a => - depList:= delete(a,depList) - toDoList:= setUnion(toDoList, - setDifference(CDR a,doneList)) - toDoList is [a,:res] => clearDep1(a,res,newDone,depList) - 'done - ---% Formatting and displaying maps - -displayRule(op,rule) == - null rule => nil - mathprint ["CONCAT","Definition: ", rule] - nil - -outputFormat(x,m) == - -- this is largely junk and is being phased out - IDENTP m => x - m=$OutputForm or m=$EmptyMode => x - categoryForm?(m) => x - isMapExpr x => x - containsVars x => x - atom(x) and CAR(m) = 'List => x - (x is ['construct,:.]) and m = '(List (Expression)) => x - T:= coerceInteractive(objNewWrap(x,maximalSuperType(m)), - $OutputForm) or return x - objValUnwrap T - -displaySingleRule($op,pattern,replacement) == - mathprint ['MAP,[pattern,:replacement]] - -displayMap(headingIfTrue,$op,map) == - mathprint - headingIfTrue => ['CONCAT,PNAME "value: ",map] - map - -simplifyMapPattern (x,alias) == - for a in alias - for m in $FormalMapVariableList | a and ^CONTAINED(a,x) repeat - x:= substitute(a,m,x) - [lhs,:rhs]:= x - rhs := simplifyMapConstructorRefs rhs - x := [lhs,:rhs] - lhs is ["|",y,pred] => - pred:= predTran pred - sl:= getEqualSublis pred => - y':= SUBLIS(sl,y) - pred:= unTrivialize SUBLIS(sl,pred) where unTrivialize x == - x is [op,:l] and op in '(_and _or) => - MKPF([unTrivialize y for y in l],op) - x is [op,a,=a] and op in '(_= is)=> true - x - rhs':= SUBLIS(sl,rhs) - pred=true => [y',:rhs'] - [["PAREN",["|",y',pred]],:rhs'] - pred=true => [y,:rhs] - [["PAREN",["|",y,pred]],:rhs] - lhs=true => ["true",:rhs] - x - -simplifyMapConstructorRefs form == - -- try to linear format constructor names - ATOM form => form - [op,:args] := form - op in '(exit SEQ) => - [op,:[simplifyMapConstructorRefs a for a in args]] - op in '(REPEAT) => - [op,first args,:[simplifyMapConstructorRefs a for a in rest args]] - op in '(_: _:_: _@) => - args is [obj,dom] => - dom' := prefix2String dom - --if ATOM dom' then dom' := [dom'] - --[op,obj,APPLY('CONCAT,dom')] - dom'' := - ATOM dom' => dom' - NULL CDR dom' => CAR dom' - APPLY('CONCAT, dom') - [op,obj, dom''] - form - form - -predTran x == - x is ["IF",a,b,c] => - c = "false" => MKPF([predTran a,predTran b],"and") - b = "true" => MKPF([predTran a,predTran c],"or") - b = "false" and c = "true" => ["not",predTran a] - x - x - -getEqualSublis pred == fn(pred,nil) where fn(x,sl) == - (x:= SUBLIS(sl,x)) is [op,:l] and op in '(_and _or) => - for y in l repeat sl:= fn(y,sl) - sl - x is ["is",a,b] => [[a,:b],:sl] - x is ["=",a,b] => - IDENTP a and not CONTAINED(a,b) => [[a,:b],:sl] - IDENTP b and not CONTAINED(b,a) => [[b,:a],:sl] - sl - sl - ---% User function analysis - -mapCatchName mapname == - INTERN STRCONC('"$",STRINGIMAGE mapname,'"CatchMapIdentifier$") - -analyzeMap(op,argTypes,mapDef, tar) == - -- Top level enty point for map type analysis. Sets up catch point - -- for interpret-code mode. - $compilingMap:local := true - $definingMap:local := true - $minivector : local := nil -- later becomes value of $minivectorName - $mapThrowCount : local := 0 -- number of "return"s encountered - $mapReturnTypes : local := nil -- list of types from returns - $repeatLabel : local := nil -- for loops; see upREPEAT - $breakCount : local := 0 -- breaks from loops; ditto - $mapTarget : local := tar - $interpOnly: local := NIL - $mapName : local := op.0 - if get($mapName,'recursive,$e) then - argTypes := [f t for t in argTypes] where - f x == - isEqualOrSubDomain(x,$Integer) => $Integer - x - mapAndArgTypes := [$mapName,:argTypes] - member(mapAndArgTypes,$analyzingMapList) => - -- if the map is declared, return the target type - (getMode op) is ['Mapping,target,:.] => target - throwKeyedMsg("S2IM0009", - [$mapName,['" ", map for [map,:.] in $analyzingMapList]]) - PUSH(mapAndArgTypes,$analyzingMapList) - mapDef := mapDefsWithCorrectArgCount(#argTypes, mapDef) - null mapDef => (POP $analyzingMapList; nil) - - UNWIND_-PROTECT(x:=CATCH('mapCompiler,analyzeMap0(op,argTypes,mapDef)), - POP $analyzingMapList) - x='tryInterpOnly => - opName:=getUnname op - fun := mkInterpFun(op,opName,argTypes) - if getMode op isnt ['Mapping,:sig] then - sig := [nil,:[nil for type in argTypes]] - $e:=putHist(opName,'localModemap, - [[['interpOnly,:sig],fun,NIL]],$e) - x - -analyzeMap0(op,argTypes,mapDef) == - -- Type analyze and compile a map. Returns the target type of the map. - -- only called if there is no applicable compiled map - $MapArgumentTypeList:local:= argTypes - numMapArgs mapDef ^= #argTypes => nil - ((m:=getMode op) is ['Mapping,:sig]) or (m and (sig:=[m])) => - -- op has mapping property only if user has declared the signature - analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) - analyzeUndeclaredMap(getUnname op,argTypes,mapDef,$mapList) - -compFailure msg == - -- Called when compilation fails in such a way that interpret-code - -- mode might be of some use. - not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) - if $reportInterpOnly then - sayMSG msg - sayMSG '" We will attempt to interpret the code." - null $compilingMap => THROW('loopCompiler,'tryInterpOnly) - THROW('mapCompiler,'tryInterpOnly) - -mkInterpFun(op,opName,argTypes) == - -- creates a function form to put in fun slot of interp-only - -- local modemaps - getMode op isnt ['Mapping,:sig] => nil - parms := [var for type in argTypes for var in $FormalMapVariableList] - arglCode := ['LIST,:[argCode for type in argTypes - for argName in parms]] where argCode == - ['putValueValue,['mkAtreeNode,MKQ argName], - objNewCode(['wrap,argName],type)] - funName := GENSYM() - body:=['rewriteMap1,MKQ opName,arglCode,MKQ sig] - putMapCode(opName,body,sig,funName,parms,false) - genMapCode(opName,body,sig,funName,parms,false) - funName - -rewriteMap(op,opName,argl) == - -- interpret-code handler for maps. Recursively calls the interpreter - -- on the body of the map. - not $genValue => - get(opName,'mode,$e) isnt ['Mapping,:sig] => - compFailure ['" Cannot compile map:",:bright opName] - arglCode := ['LIST,:[argCode for arg in argl for argName in - $FormalMapVariableList]] where argCode == - ['putValueValue,['mkAtreeNode,MKQ argName], - objNewCode(['wrap,wrapped2Quote(objVal getValue arg)], - getMode arg)] - putValue(op,objNew(['rewriteMap1,MKQ opName,arglCode,MKQ sig], - CAR sig)) - putModeSet(op,[CAR sig]) - rewriteMap0(op,opName,argl) - -putBodyInEnv(opName, numArgs) == - val := get(opName, 'value, $e) - val is [.,'MAP, :bod] => - $e := putHist(opName, 'mapBody, combineMapParts - mapDefsWithCorrectArgCount(numArgs, bod), $e) - 'failed - -removeBodyFromEnv(opName) == - $e := putHist(opName, 'mapBody, nil, $e) - - -rewriteMap0(op,opName,argl) == - -- $genValue case of map rewriting - putBodyInEnv(opName, #argl) - if (s := get(opName,'mode,$e)) then - tar := CADR s - argTypes := CDDR s - else - tar:= nil - argTypes:= nil - get(opName,'mode,$e) is ['Mapping,tar,:argTypes] - $env: local := [[NIL]] - for arg in argl - for var in $FormalMapVariableList repeat - if argTypes then - t := CAR argTypes - argTypes:= CDR argTypes - val := - t is ['Mapping,:.] => getValue arg - coerceInteractive(getValue arg,t) - else - val:= getValue arg - $env:=put(var,'value,val,$env) - if VECP arg then $env := put(var,'name,getUnname arg,$env) - (m := getMode arg) => $env := put(var,'mode,m,$env) - null (val:= interpMap(opName,tar)) => - throwKeyedMsg("S2IM0010",[opName]) - putValue(op,val) - removeBodyFromEnv(opName) - ms := putModeSet(op,[objMode val]) - -rewriteMap1(opName,argl,sig) == - -- compiled case of map rewriting - putBodyInEnv(opName, #argl) - if sig then - tar:= CAR sig - argTypes:= CDR sig - else - tar:= nil - argTypes:= nil - evArgl := NIL - for arg in reverse argl repeat - v := getValue arg - evArgl := [objNew(objVal v, objMode v),:evArgl] - $env : local := [[NIL]] - for arg in argl for evArg in evArgl - for var in $FormalMapVariableList repeat - if argTypes then - t:=CAR argTypes - argTypes:= CDR argTypes - val := - t is ['Mapping,:.] => evArg - coerceInteractive(evArg,t) - else - val:= evArg - $env:=put(var,'value,val,$env) - if VECP arg then $env := put(var,'name,getUnname arg,$env) - (m := getMode arg) => $env := put(var,'mode,m,$env) - val:= interpMap(opName,tar) - removeBodyFromEnv(opName) - objValUnwrap(val) - -interpMap(opName,tar) == - -- call the interpreter recursively on map body - $genValue : local:= true - $interpMapTag : local := nil - $interpOnly : local := true - $localVars : local := NIL - for lvar in get(opName,'localVars,$e) repeat mkLocalVar(opName,lvar) - $mapName : local := opName - $mapTarget : local := tar - body:= get(opName,'mapBody,$e) - savedTimerStack := COPY $timedNameStack - catchName := mapCatchName $mapName - c := CATCH(catchName, interpret1(body,tar,nil)) --- $interpMapTag and $interpMapTag ^= mapCatchName $mapName => --- THROW($interpMapTag,c) - while savedTimerStack ^= $timedNameStack repeat - stopTimingProcess peekTimedName() - c -- better be a triple - -analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) == - -- analyzes and compiles maps with declared signatures. argTypes - -- is a list of types of the arguments, sig is the declared signature - -- mapDef is the stored form of the map body. - opName := getUnname op - $mapList:=[opName,:$mapList] - $mapTarget := CAR sig - (mmS:= get(opName,'localModemap,$e)) and - (mm:= or/[mm for (mm:=[[.,:mmSig],:.]) in mmS | mmSig=sig]) => - compileCoerceMap(opName,argTypes,mm) - -- The declared map needs to be compiled - compileDeclaredMap(opName,sig,mapDef) - argTypes ^= CDR sig => - analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) - CAR sig - -compileDeclaredMap(op,sig,mapDef) == - -- Type analyzes and compiles a map with a declared signature. - -- creates a local modemap and puts it into the environment - $localVars: local := nil - $freeVars: local := nil - $env:local:= [[NIL]] - parms:=[var for var in $FormalMapVariableList for m in CDR sig] - for m in CDR sig for var in parms repeat - $env:= put(var,'mode,m,$env) - body:= getMapBody(op,mapDef) - for lvar in parms repeat mkLocalVar($mapName,lvar) - for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) - name := makeLocalModemap(op,sig) - val := compileBody(body,CAR sig) - isRecursive := (depthOfRecursion(op,body) > 0) - putMapCode(op,objVal val,sig,name,parms,isRecursive) - genMapCode(op,objVal val,sig,name,parms,isRecursive) - CAR sig - -putMapCode(op,code,sig,name,parms,isRecursive) == - -- saves the generated code and some other information about the - -- function - codeInfo := VECTOR(op,code,sig,name,parms,isRecursive) - allCode := [codeInfo,:get(op,'generatedCode,$e)] - $e := putHist(op,'generatedCode,allCode,$e) - op - -makeLocalModemap(op,sig) == - -- create a local modemap for op with sig, and put it into $e - if (currentMms := get(op,'localModemap,$e)) then - untraceMapSubNames [CADAR currentMms] - newName := makeInternalMapName(op,#sig-1,1+#currentMms,NIL) - newMm := [['local,:sig],newName,nil] - mms := [newMm,:currentMms] - $e := putHist(op,'localModemap,mms,$e) - newName - -genMapCode(op,body,sig,fnName,parms,isRecursive) == - -- calls the lisp compiler on the body of a map - if lmm:= get(op,'localModemap,$InteractiveFrame) then - untraceMapSubNames [CADAR lmm] - op0 := - ( n := isSharpVarWithNum op ) => STRCONC('"") - op - if get(op,'isInterpreterRule,$e) then - sayKeyedMsg("S2IM0014",[op0,(PAIRP sig =>prefix2String CAR sig;'"?")]) - else sayKeyedMsg("S2IM0015",[op0,formatSignature sig]) - $whereCacheList := [op,:$whereCacheList] - - -- RSS: 6-21-94 - -- The following code ensures that local variables really are local - -- to a function. We will unnecessarily generate preliminary LETs for - -- loop variables and variables that do have LET expressions, but that - -- can be finessed later. - - locals := SETDIFFERENCE(COPY $localVars, parms) - if locals then - lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals] - body := ['PROGN, :lets, body] - - reportFunctionCompilation(op,fnName,parms, - wrapMapBodyWithCatch flattenCOND body,isRecursive) - -compileBody(body,target) == - -- recursively calls the interpreter on the map body - -- returns a triple with the LISP code for body in the value cell - $insideCompileBodyIfTrue: local := true - $genValue: local := false - $declaredMode:local := target - $eval:local:= true - r := interpret1(body,target,nil) - -compileCoerceMap(op,argTypes,mm) == - -- compiles call to user-declared map where the arguments need - -- to be coerced. mm is the modemap for the declared map. - $insideCompileBodyIfTrue: local := true - $genValue: local := false - [[.,:sig],imp,.]:= mm - parms:= [var for var in $FormalMapVariableList for t in CDR sig] - name:= makeLocalModemap(op,[CAR sig,:argTypes]) - argCode := [objVal(coerceInteractive(objNew(arg,t1),t2) or - throwKeyedMsg("S2IC0001",[arg,$mapName,t1,t2])) - for t1 in argTypes for t2 in CDR sig for arg in parms] - $insideCompileBodyIfTrue := false - parms:= [:parms,'envArg] - body := ['SPADCALL,:argCode,['LIST,['function,imp]]] - minivectorName := makeInternalMapMinivectorName(name) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - compileInteractive [name,['LAMBDA,parms,body]] - CAR sig - -depthOfRecursion(opName,body) == - -- returns the "depth" of recursive calls of opName in body - mapRecurDepth(opName,nil,body) - -mapRecurDepth(opName,opList,body) == - -- walks over the map body counting depth of recursive calls - -- expanding the bodies of maps called in body - atom body => 0 - body is [op,:argl] => - argc:= - atom argl => 0 - argl => "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] - 0 - op in opList => argc - op=opName => 1 + argc - (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => - mapRecurDepth(opName,[op,:opList],getMapBody(op,mapDef)) - + argc - argc - keyedSystemError("S2GE0016",['"mapRecurDepth", - '"unknown function form"]) - -analyzeUndeclaredMap(op,argTypes,mapDef,$mapList) == - -- Computes the signature of the map named op, and compiles the body - $freeVars:local := NIL - $localVars: local := NIL - $env:local:= [[NIL]] - $mapList := [op,:$mapList] - parms:=[var for var in $FormalMapVariableList for m in argTypes] - for m in argTypes for var in parms repeat - put(var,'autoDeclare,'T,$env) - put(var,'mode,m,$env) - body:= getMapBody(op,mapDef) - for lvar in parms repeat mkLocalVar($mapName,lvar) - for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) - (n:= depthOfRecursion(op,body)) = 0 => - analyzeNonRecursiveMap(op,argTypes,body,parms) - analyzeRecursiveMap(op,argTypes,body,parms,n) - -analyzeNonRecursiveMap(op,argTypes,body,parms) == - -- analyze and compile a non-recursive map definition - T := compileBody(body,$mapTarget) - if $mapThrowCount > 0 then - t := objMode T - b := and/[(t = rt) for rt in $mapReturnTypes] - not b => - t := resolveTypeListAny [t,:$mapReturnTypes] - if not $mapTarget then $mapTarget := t - T := compileBody(body,$mapTarget) - sig := [objMode T,:argTypes] - name:= makeLocalModemap(op,sig) - putMapCode(op,objVal T,sig,name,parms,false) - genMapCode(op,objVal T,sig,name,parms,false) - objMode(T) - -analyzeRecursiveMap(op,argTypes,body,parms,n) == - -- analyze and compile a non-recursive map definition - -- makes guess at signature by analyzing non-recursive part of body - -- then re-analyzes the entire body until the signature doesn't change - localMapInfo := saveDependentMapInfo(op, CDR $mapList) - tar := CATCH('interpreter,analyzeNonRecur(op,body,$localVars)) - for i in 0..n until not sigChanged repeat - sigChanged:= false - name := makeLocalModemap(op,sig:=[tar,:argTypes]) - code := compileBody(body,$mapTarget) - objMode(code) ^= tar => - sigChanged:= true - tar := objMode(code) - restoreDependentMapInfo(op, CDR $mapList, localMapInfo) - sigChanged => throwKeyedMsg("S2IM0011",[op]) - putMapCode(op,objVal code,sig,name,parms,true) - genMapCode(op,objVal code,sig,name,parms,true) - tar - -saveDependentMapInfo(op,opList) == - not (op in opList) => - lmml := [[op, :get(op, 'localModemap, $e)]] - gcl := [[op, :get(op, 'generatedCode, $e)]] - for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat - [lmml', :gcl'] := saveDependentMapInfo(dep2, [op, :opList]) - lmms := nconc(lmml', lmml) - gcl := nconc(gcl', gcl) - [lmms, :gcl] - nil - -restoreDependentMapInfo(op, opList, [lmml,:gcl]) == - not (op in opList) => - clearDependentMaps(op,opList) - for [op, :lmm] in lmml repeat - $e := putHist(op,'localModemap,lmm,$e) - for [op, :gc] in gcl repeat - $e := putHist(op,'generatedCode,gc,$e) - -clearDependentMaps(op,opList) == - -- clears the local modemaps of all the maps that depend on op - not (op in opList) => - $e := putHist(op,'localModemap,nil,$e) - $e := putHist(op,'generatedCode,nil,$e) - for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat - clearDependentMaps(dep2,[op,:opList]) - -analyzeNonRecur(op,body,$localVars) == - -- type analyze the non-recursive part of a map body - nrp := nonRecursivePart(op,body) - for lvar in findLocalVars(op,nrp) repeat mkLocalVar($mapName,lvar) - objMode(compileBody(nrp,$mapTarget)) - -nonRecursivePart(opName, funBody) == - -- takes funBody, which is the parse tree of the definition of - -- a function, and returns a list of the parts - -- of the function which are not recursive in the name opName - body:= expandRecursiveBody([opName], funBody) - ((nrp:=nonRecursivePart1(opName, body)) ^= 'noMapVal) => nrp - throwKeyedMsg("S2IM0012",[opName]) - -expandRecursiveBody(alreadyExpanded, body) == - -- replaces calls to other maps with their bodies - atom body => - (obj := get(body,'value,$e)) and objVal obj is ['MAP,:mapDef] and - ((numMapArgs mapDef) = 0) => getMapBody(body,mapDef) - body - body is [op,:argl] => - not (op in alreadyExpanded) => - (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => - newBody:= getMapBody(op,mapDef) - for arg in argl for var in $FormalMapVariableList repeat - newBody:=MSUBST(arg,var,newBody) - expandRecursiveBody([op,:alreadyExpanded],newBody) - [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] - [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] - keyedSystemError("S2GE0016",['"expandRecursiveBody", - '"unknown form of function body"]) - -nonRecursivePart1(opName, funBody) == - -- returns a function body which contains only the parts of funBody - -- which do not call the function opName - funBody is ['IF,a,b,c] => - nra:=nonRecursivePart1(opName,a) - nra = 'noMapVal => 'noMapVal - nrb:=nonRecursivePart1(opName,b) - nrc:=nonRecursivePart1(opName,c) - not (nrb in '(noMapVal noBranch)) => ['IF,nra,nrb,nrc] - not (nrc in '(noMapVal noBranch)) => ['IF,['not,nra],nrc,nrb] - 'noMapVal - not containsOp(funBody,'IF) => - notCalled(opName,funBody) => funBody - 'noMapVal - funBody is [op,:argl] => - op=opName => 'noMapVal - args:= [nonRecursivePart1(opName,arg) for arg in argl] - MEMQ('noMapVal,args) => 'noMapVal - [op,:args] - funBody - -containsOp(body,op) == - -- true IFF body contains an op statement - body is [ =op,:.] => true - body is [.,:argl] => or/[containsOp(arg,op) for arg in argl] - false - -notCalled(opName,form) == - -- returns true if opName is not called in the form - atom form => true - form is [op,:argl] => - op=opName => false - and/[notCalled(opName,x) for x in argl] - keyedSystemError("S2GE0016",['"notCalled", - '"unknown form of function body"]) - -mapDefsWithCorrectArgCount(n, mapDef) == - [def for def in mapDef | (numArgs CAR def) = n] - -numMapArgs(mapDef is [[args,:.],:.]) == - -- returns the number of arguemnts to the map whose body is mapDef - numArgs args - -numArgs args == - args is ['_|,a,:.] => numArgs a - args is ['Tuple,:argl] => #argl - null args => 0 - 1 - -combineMapParts(mapTail) == - -- transforms a piece-wise function definition into an if-then-else - -- statement. Uses noBranch to indicate undefined branch - null mapTail => 'noMapVal - mapTail is [[cond,:part],:restMap] => - isSharpVarWithNum cond or (cond is ['Tuple,:args] and - and/[isSharpVarWithNum arg for arg in args]) or (null cond) => part - ['IF,mkMapPred cond,part,combineMapParts restMap] - keyedSystemError("S2GE0016",['"combineMapParts", - '"unknown function form"]) - -mkMapPred cond == - -- create the predicate on map arguments, derived from "when" clauses - cond is ['_|,args,pred] => mapPredTran pred - cond is ['Tuple,:vals] => - mkValueCheck(vals,1) - mkValCheck(cond,1) - -mkValueCheck(vals,i) == - -- creates predicate for specific value check (i.e f 1 == 1) - vals is [val] => mkValCheck(val,i) - ['and,mkValCheck(first vals,i),mkValueCheck(rest vals,i+1)] - -mkValCheck(val,i) == - -- create equality check for map predicates - isSharpVarWithNum val => 'true - ['_=,mkSharpVar i,val] - -mkSharpVar i == - -- create #i - INTERN CONCAT('"#",STRINGIMAGE i) - -mapPredTran pred == - -- transforms "x in i..j" to "x>=i and x<=j" - pred is ['in,var,['SEGMENT,lb]] => mkLessOrEqual(lb,var) - pred is ['in,var,['SEGMENT,lb,ub]] => - null ub => mkLessOrEqual(lb,var) - ['and,mkLessOrEqual(lb,var),mkLessOrEqual(var,ub)] - pred - -findLocalVars(op,form) == - -- analyzes form for local and free variables, and returns the list - -- of locals - findLocalVars1(op,form) - $localVars - -findLocalVars1(op,form) == - -- sets the two lists $localVars and $freeVars - atom form => - not IDENTP form or isSharpVarWithNum form => nil - isLocalVar(form) or isFreeVar(form) => nil - mkFreeVar($mapName,form) - form is ['local, :vars] => - for x in vars repeat - ATOM x => mkLocalVar(op, x) - form is ['free, :vars] => - for x in vars repeat - ATOM x => mkFreeVar(op, x) - form is ['LET,a,b] => - (a is ['Tuple,:vars]) and (b is ['Tuple,:vals]) => - for var in vars for val in vals repeat - findLocalVars1(op,['LET,var,val]) - a is ['construct,:pat] => - for var in listOfVariables pat repeat mkLocalVar(op,var) - findLocalVars1(op,b) - (atom a) or (a is ['_:,a,.]) => - mkLocalVar(op,a) - findLocalVars1(op,b) - findLocalVars(op,b) - for x in a repeat findLocalVars1(op,x) - form is ['_:,a,.] => - mkLocalVar(op,a) - form is ['is,l,pattern] => - findLocalVars1(op,l) - for var in listOfVariables CDR pattern repeat mkLocalVar(op,var) - form is [oper,:itrl,body] and MEMQ(oper,'(REPEAT COLLECT)) => - findLocalsInLoop(op,itrl,body) - form is [y,:argl] => - y is 'Record => nil - for x in argl repeat findLocalVars1(op,x) - keyedSystemError("S2IM0020",[op]) - -findLocalsInLoop(op,itrl,body) == - for it in itrl repeat - it is ['STEP,index,lower,step,:upperList] => - mkLocalVar(op,index) - findLocalVars1(op,lower) - for up in upperList repeat findLocalVars1(op,up) - it is ['IN,index,s] => - mkLocalVar(op,index) ; findLocalVars1(op,s) - it is ['WHILE,b] => - findLocalVars1(op,b) - it is ['_|,pred] => - findLocalVars1(op,pred) - findLocalVars1(op,body) - for it in itrl repeat - it is [op,b] and (op in '(UNTIL)) => - findLocalVars1(op,b) - -isLocalVar(var) == member(var,$localVars) - -mkLocalVar(op,var) == - -- add var to the local variable list - isFreeVar(var) => $localVars - $localVars:= insert(var,$localVars) - -isFreeVar(var) == member(var,$freeVars) - -mkFreeVar(op,var) == - -- op here for symmetry with mkLocalVar - $freeVars:= insert(var,$freeVars) - -listOfVariables pat == - -- return a list of the variables in pat, which is an "is" pattern - IDENTP pat => (pat='_. => nil ; [pat]) - pat is ['_:,var] or pat is ['_=,var] => - (var='_. => NIL ; [var]) - PAIRP pat => REMDUP [:listOfVariables p for p in pat] - nil - -getMapBody(op,mapDef) == - -- looks in $e for a map body; if not found it computes then stores it - get(op,'mapBody,$e) or - combineMapParts mapDef --- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) --- body - -getLocalVars(op,body) == - -- looks in $e for local vars; if not found, computes then stores them - get(op,'localVars,$e) or - $e:= putHist(op,'localVars,lv:=findLocalVars(op,body),$e) - lv - --- DO NOT BELIEVE ALL OF THE FOLLOWING (IT IS OLD) - --- VARIABLES. Variables may or may not have a mode property. If --- present, any value which is assigned or generated by that variable --- is first coerced to that mode before being assigned or returned. --- --- --- Variables are given a triple [val,m,e] as a "value" property on --- its property list in the environment. The expression val has the --- forms: --- --- (WRAPPED . y) --value of x is y (don't re-evaluate) --- y --anything else --value of x is obtained by evaluating y --- --- A wrapped expression is created by an assignment. In the second --- case, y can never contain embedded wrapped expressions. The mode --- part m of the triple is the type of y in the wrapped case and is --- consistent with the declared mode if given. The mode part of an --- unwrapped value is always $EmptyMode. The e part is usually NIL --- but may be used to hold a partial closure. --- --- Effect of changes. A rule can be built up for a variable by --- successive rules involving conditional expressions. However, once --- a value is assigned to the variable or an unconditional definition --- is given, any existing value is replaced by the new entry. When --- the mode of a variable is declared, an wrapped value is coerced to --- the new mode; if this is not possible, the user is notified that --- the current value is discarded and why. When the mode is --- redeclared and an upwrapped value is present, the value is --- retained; the only other effect is to coerce any cached values --- from the old mode to the new one. --- --- Caches. When a variable x is evaluated and re-evaluation occurs, --- the triple produced by that evaluation is stored under "cache" on --- the property list of x. This cached triple is cleared whenever any --- of the variables which x's value depend upon change. Dependencies --- are stored on $dependencies whose value has the form [[a b ..] ..] --- to indicate that when a is changed, b .. must have all cached --- values destroyed. In the case of parameterized forms which are --- represented by maps, we currently can cache values only when the --- compiler option is turned on by )on c s meaning "on compiler with --- the save option". When f is compiled as f;1, it then has an alist --- f;1;AL which records these values. If f depends globally on a's --- value, all cached values of all local functions defined for f have --- to be declared. If a's mode should change, then all compilations --- of f must be thrown away. --- --- PARAMETERIZED FORMS. These always have values [val,m,e] where val --- are "maps". --- --- The structure of maps: --- (MAP (pattern . rewrite) ...) where --- pattern has forms: arg-pattern --- (Tuple arg-pattern ...) --- rewrite has forms: (WRAPPED . value) --don't re-evaluate --- computational object --don't (bother to) --- re-evaluate --- anything else --yes, re-evaluate --- --- When assigning values to a map, each new value must have a type --- which is consistent with those already assigned. Initially, type --- of MAP is $EmptyMode. When the map is first assigned a value, the --- type of the MAP is RPLACDed to be (Mapping target source ..). --- When the map is next assigned, the type of both source and target --- is upgraded to be consistent with those values already computed. --- Of course, if new and old source and target are identical, nothing --- need happen to existing entries. However, if the new and old are --- different, all existing entries of the map are coerce to the new --- data type. --- --- Mode analysis. This is done on the bottomUp phase of the process. --- If a function has been given a mapping declaration, this map is --- placed in as the mode of the map under the "value" property of the --- variable. Of course, these modes may be partial types in case a --- mode analysis is still necessary. If no mapping declaration, a --- total mode analysis of the function, given its input arguments, is --- done. This will result a signature involving types only. --- --- If the compiler is on, the function is then compiled given this --- signature involving types. If the map is value of a variable f, a --- function is given name f;1, f is given a "localModemap" property --- with modemap ((dummy target source ..) (T f;1)) so that the next --- time f is applied to arguments which coerce to the source --- arguments of this local modemap, f;1 will be invoked. diff --git a/src/interp/i-map.boot.pamphlet b/src/interp/i-map.boot.pamphlet new file mode 100644 index 00000000..b66f02b9 --- /dev/null +++ b/src/interp/i-map.boot.pamphlet @@ -0,0 +1,1185 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/i-map.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% User Function Creation and Analysis Code + +SETANDFILEQ($mapTarget,nil) +SETANDFILEQ($mapReturnTypes,nil) +SETANDFILEQ($mapName,'noMapName) +SETANDFILEQ($mapThrowCount, 0) -- times a "return" occurs in map +SETANDFILEQ($compilingMap, NIL) +SETANDFILEQ($definingMap, NIL) + +--% Generating internal names for functions + +SETANDFILEQ($specialMapNameSuffix, NIL) + +makeInternalMapName(userName,numArgs,numMms,extraPart) == + name := CONCAT('"*",STRINGIMAGE numArgs,'";", + object2String userName,'";",STRINGIMAGE numMms,'";", + object2String frameName first $interpreterFrameRing ) + if extraPart then name := CONCAT(name,'";",extraPart) + if $specialMapNameSuffix then + name := CONCAT(name,'";",$specialMapNameSuffix) + INTERN name + +isInternalMapName name == + -- this only returns true or false as a "best guess" + (not IDENTP(name)) or (name = "*") or (name = "**") => false + sz := SIZE (name' := PNAME name) + (sz < 7) or (char("*") ^= name'.0) => false + null DIGITP name'.1 => false + null STRPOS('"_;",name',1,NIL) => false + -- good enough + true + +makeInternalMapMinivectorName(name) == + STRINGP name => + INTERN STRCONC(name,'";MV") + INTERN STRCONC(PNAME name,'";MV") + +mkCacheName(name) == INTERNL(STRINGIMAGE name,'";AL") + +mkAuxiliaryName(name) == INTERNL(STRINGIMAGE name,'";AUX") + +--% Adding a function definition + +isMapExpr x == x is ['MAP,:.] + +isMap x == + y := get(x,'value,$InteractiveFrame) => + objVal y is ['MAP,:.] => x + +addDefMap(['DEF,lhs,mapsig,.,rhs],pred) == + -- Create a new map, add to an existing one, or define a variable + -- compute the dependencies for a map + + -- next check is for bad forms on the lhs of the ==, such as + -- numbers, constants. + if not PAIRP lhs then + op := lhs + putHist(op,'isInterpreterRule,true,$e) + putHist(op,'isInterpreterFunction,false,$e) + lhs := [lhs] + else + -- this is a function definition. If it has been declared + -- previously, make sure it is Mapping. + op := first lhs + (oldMode := get(op,'mode,$e)) and oldMode isnt ['Mapping,:.] => + throwKeyedMsg("S2IM0001",[op,oldMode]) + putHist(op,'isInterpreterRule,false,$e) + putHist(op,'isInterpreterFunction,true,$e) + + (NUMBERP(op) or op in '(true false nil % %%)) => + throwKeyedMsg("S2IM0002",[lhs]) + + -- verify a constructor abbreviation is not used on the lhs + op ^= (op' := unabbrev op) => throwKeyedMsg("S2IM0003",[op,op']) + + -- get the formal parameters. These should only be atomic symbols + -- that are not numbers. + parameters := [p for p in rest lhs | IDENTP(p)] + + -- see if a signature has been given. if anything in mapsig is NIL, + -- then declaration was omitted. + someDecs := nil + allDecs := true + mapmode := ['Mapping] + $env:local := [[NIL]] + $eval:local := true --generate code-- don't just type analyze + $genValue:local := true --evaluate all generated code + for d in mapsig repeat + if d then + someDecs := true + d' := evaluateType unabbrev d + isPartialMode d' => throwKeyedMsg("S2IM0004",NIL) +-- tree := mkAtree d' +-- null (d' := isType tree) => throwKeyedMsg("S2IM0005",[d]) + mapmode := [d',:mapmode] + else allDecs := false + if allDecs then + mapmode := nreverse mapmode + putHist(op,'mode,mapmode,$e) + sayKeyedMsg("S2IM0006",[formatOpSignature(op,rest mapmode)]) + else if someDecs then throwKeyedMsg("S2IM0007",[op]) + + -- if map is declared, check that signature arg count is the + -- same as what is given. + if get(op,'mode,$e) is ['Mapping,.,:mapargs] then + EQCAR(rhs,'rules) => + 0 ^= (numargs := # rest lhs) => + throwKeyedMsg("S2IM0027",[numargs,op]) + # rest lhs ^= # mapargs => throwKeyedMsg("S2IM0008",[op]) + --get all the user variables in the map definition. This is a multi + --step process as this should not include recursive calls to the map + --itself, or the formal parameters + userVariables1 := getUserIdentifiersIn rhs + $freeVars: local := NIL + $localVars: local := NIL + for parm in parameters repeat mkLocalVar($mapName,parm) + userVariables2 := setDifference(userVariables1,findLocalVars(op,rhs)) + userVariables3 := setDifference(userVariables2, parameters) + userVariables4 := REMDUP setDifference (userVariables3, [op]) + + --figure out the new dependencies for the new map (what it depends on) + newDependencies := makeNewDependencies (op, userVariables4) + putDependencies (op, newDependencies) + clearDependencies(op,'T) + addMap(lhs,rhs,pred) + +addMap(lhs,rhs,pred) == + [op,:argl] := lhs + $sl: local:= nil + formalArgList:= [mkFormalArg(makeArgumentIntoNumber x,s) + for x in argl for s in $FormalMapVariableList] + argList:= + [fn for x in formalArgList] where + fn == + if x is ["SUCHTHAT",s,p] then (predList:= [p,:predList]; x:= s) + x + mkMapAlias(op,argl) + argPredList:= NREVERSE predList + finalPred := +-- handle g(a,T)==a+T confusion between pred=T and T variable + MKPF((pred and (pred ^= 'T) => [:argPredList,SUBLISNQ($sl,pred)]; argPredList),"and") + body:= SUBLISNQ($sl,rhs) + oldMap := + (obj := get(op,'value,$InteractiveFrame)) => objVal obj + NIL + newMap := augmentMap(op,argList,finalPred,body,oldMap) + null newMap => + sayRemoveFunctionOrValue op + putHist(op,'alias,nil,$e) + " " -- clears value--- see return from addDefMap in tree2Atree1 + if get(op,'isInterpreterRule,$e) then type := ['RuleCalled,op] + else type := ['FunctionCalled,op] + recursive := + depthOfRecursion(op,newMap) = 0 => false + true + putHist(op,'recursive,recursive,$e) + objNew(newMap,type) + +augmentMap(op,args,pred,body,oldMap) == + pattern:= makePattern(args,pred) + newMap:=deleteMap(op,pattern,oldMap) + body=" " => + if newMap=oldMap then + sayMSG ['" Cannot find part of",:bright op,'"to delete."] + newMap --just delete rule if body is + entry:= [pattern,:body] + resultMap:= + newMap is ["MAP",:tail] => ["MAP",:tail,entry] + ["MAP",entry] + resultMap + +deleteMap(op,pattern,map) == + map is ["MAP",:tail] => + newMap:= ['MAP,:[x for x in tail | w]] where w == + x is [=pattern,:replacement] => sayDroppingFunctions(op,[x]) + true + null rest newMap => nil + newMap + NIL + +getUserIdentifiersIn body == + null body => nil + IDENTP body => + isSharpVarWithNum body => nil + body=" " => nil + [body] + body is ["WRAPPED",:.] => nil + (body is ["COLLECT",:itl,body1]) or (body is ['REPEAT,:itl,body1]) => + userIds := + S_+(getUserIdentifiersInIterators itl,getUserIdentifiersIn body1) + S_-(userIds,getIteratorIds itl) + body is [op,:l] => + argIdList:= "append"/[getUserIdentifiersIn y for y in l] + bodyIdList := + CONSP op or not (GET(op,'Nud) or GET(op,'Led) or GET(op,'up))=> + NCONC(getUserIdentifiersIn op, argIdList) + argIdList + REMDUP bodyIdList + +getUserIdentifiersInIterators itl == + for x in itl repeat + x is ["STEP",i,:l] => + varList:= [:"append"/[getUserIdentifiersIn y for y in l],:varList] + x is ["IN",.,y] => varList:= [:getUserIdentifiersIn y,:varList] + x is ["ON",.,y] => varList:= [:getUserIdentifiersIn y,:varList] + x is [op,a] and op in '(_| WHILE UNTIL) => + varList:= [:getUserIdentifiersIn a,:varList] + keyedSystemError("S2GE0016",['"getUserIdentifiersInIterators", + '"unknown iterator construct"]) + REMDUP varList + +getIteratorIds itl == + for x in itl repeat + x is ["STEP",i,:.] => varList:= [i,:varList] + x is ["IN",y,:.] => varList:= [y,:varList] + x is ["ON",y,:.] => varList:= [y,:varList] + nil + varList + +makeArgumentIntoNumber x == + x=$Zero => 0 + x=$One => 1 + atom x => x + x is ["-",n] and NUMBERP n => -n + [removeZeroOne first x,:removeZeroOne rest x] + +mkMapAlias(op,argl) == + u:= mkAliasList argl + newAlias := + alias:= get(op,"alias",$e) => [(y => y; x) for x in alias for y in u] + u + $e:= putHist(op,"alias",newAlias,$e) + +mkAliasList l == fn(l,nil) where fn(l,acc) == + null l => NREVERSE acc + not IDENTP first l or first l in acc => fn(rest l,[nil,:acc]) + fn(rest l,[first l,:acc]) + +args2Tuple args == + args is [first,:rest] => + null rest => first + ["Tuple",:args] + nil + +makePattern(args,pred) == + nargs:= #args + nargs = 1 => + pred is ["=","#1",n] => n + addPatternPred("#1",pred) + u:= canMakeTuple(nargs,pred) => u + addPatternPred(["Tuple",:TAKE(nargs,$FormalMapVariableList)],pred) + +addPatternPred(arg,pred) == + pred=true => arg + ["|",arg,pred] + +canMakeTuple(nargs,pred) == + pred is ["and",:l] and nargs=#l and + (u:= [(x is ["=",=y,a] => a; return nil) + for y in $FormalMapVariableList for x in orderList l]) => + ["Tuple",:u] + +sayRemoveFunctionOrValue x == + (obj := getValue x) and (md := objMode obj) => + md = $EmptyMode => + sayMessage ['" ",:bright x,'"now has no function parts."] + sayMessage ['" value for",:bright x,'"has been removed."] + sayMessage ['" ",:bright x,'"has no value so this does nothing."] + +sayDroppingFunctions(op,l) == + sayKeyedMsg("S2IM0017",[#l,op]) + if $displayDroppedMap then + for [pattern,:replacement] in l repeat + displaySingleRule(op,pattern,replacement) + nil + +makeRuleForm(op,pattern)== + pattern is ["Tuple",:l] => [op,:l] + [op,:pattern] + +mkFormalArg(x,s) == + isConstantArgument x => ["SUCHTHAT",s,["=",s,x]] + isPatternArgument x => ["SUCHTHAT",s,["is",s,x]] + IDENTP x => + y:= LASSOC(x,$sl) => ["SUCHTHAT",s,["=",s,y]] + $sl:= [[x,:s],:$sl] + s + ['SUCHTHAT,s,["=",s,x]] + +isConstantArgument x == + NUMBERP x => x + x is ["QUOTE",.] => x + +isPatternArgument x == x is ["construct",:.] + +--% Map dependencies + +makeNewDependencies (op, userVariables) == + null userVariables => nil + --add the new dependencies + [[(first userVariables),op], + :makeNewDependencies (op, rest userVariables)] + +putDependencies (op, dependencies) == + oldDependencies := getFlag "$dependencies" + --remove the obsolete dependencies: all those that applied to the + --old definition, but may not apply here. If they do, they'll be + --in the list of new dependencies anyway + oldDependencies := removeObsoleteDependencies (op, oldDependencies) where + removeObsoleteDependencies (op, oldDep) == + null oldDep => nil + op = rest first oldDep => + removeObsoleteDependencies (op, rest oldDep) + [first oldDep,:removeObsoleteDependencies (op, rest oldDep)] + --Create the list of dependencies to output. This will be all the + --old dependencies that are still applicable, and all the new ones + --that have just been generated. Remember that the list of + --dependencies does not just include those for the map just being + --defined, but includes those for all maps and variables that exist + newDependencies := union (dependencies, oldDependencies) + putFlag ("$dependencies", newDependencies) + +clearDependencies(x,clearLocalModemapsIfTrue) == + $dependencies: local:= COPY getFlag "$dependencies" + clearDep1(x,nil,nil,$dependencies) + +clearDep1(x,toDoList,doneList,depList) == + x in doneList => nil + clearCache x + newDone:= [x,:doneList] + until null a repeat + a:= ASSQ(x,depList) + a => + depList:= delete(a,depList) + toDoList:= setUnion(toDoList, + setDifference(CDR a,doneList)) + toDoList is [a,:res] => clearDep1(a,res,newDone,depList) + 'done + +--% Formatting and displaying maps + +displayRule(op,rule) == + null rule => nil + mathprint ["CONCAT","Definition: ", rule] + nil + +outputFormat(x,m) == + -- this is largely junk and is being phased out + IDENTP m => x + m=$OutputForm or m=$EmptyMode => x + categoryForm?(m) => x + isMapExpr x => x + containsVars x => x + atom(x) and CAR(m) = 'List => x + (x is ['construct,:.]) and m = '(List (Expression)) => x + T:= coerceInteractive(objNewWrap(x,maximalSuperType(m)), + $OutputForm) or return x + objValUnwrap T + +displaySingleRule($op,pattern,replacement) == + mathprint ['MAP,[pattern,:replacement]] + +displayMap(headingIfTrue,$op,map) == + mathprint + headingIfTrue => ['CONCAT,PNAME "value: ",map] + map + +simplifyMapPattern (x,alias) == + for a in alias + for m in $FormalMapVariableList | a and ^CONTAINED(a,x) repeat + x:= substitute(a,m,x) + [lhs,:rhs]:= x + rhs := simplifyMapConstructorRefs rhs + x := [lhs,:rhs] + lhs is ["|",y,pred] => + pred:= predTran pred + sl:= getEqualSublis pred => + y':= SUBLIS(sl,y) + pred:= unTrivialize SUBLIS(sl,pred) where unTrivialize x == + x is [op,:l] and op in '(_and _or) => + MKPF([unTrivialize y for y in l],op) + x is [op,a,=a] and op in '(_= is)=> true + x + rhs':= SUBLIS(sl,rhs) + pred=true => [y',:rhs'] + [["PAREN",["|",y',pred]],:rhs'] + pred=true => [y,:rhs] + [["PAREN",["|",y,pred]],:rhs] + lhs=true => ["true",:rhs] + x + +simplifyMapConstructorRefs form == + -- try to linear format constructor names + ATOM form => form + [op,:args] := form + op in '(exit SEQ) => + [op,:[simplifyMapConstructorRefs a for a in args]] + op in '(REPEAT) => + [op,first args,:[simplifyMapConstructorRefs a for a in rest args]] + op in '(_: _:_: _@) => + args is [obj,dom] => + dom' := prefix2String dom + --if ATOM dom' then dom' := [dom'] + --[op,obj,APPLY('CONCAT,dom')] + dom'' := + ATOM dom' => dom' + NULL CDR dom' => CAR dom' + APPLY('CONCAT, dom') + [op,obj, dom''] + form + form + +predTran x == + x is ["IF",a,b,c] => + c = "false" => MKPF([predTran a,predTran b],"and") + b = "true" => MKPF([predTran a,predTran c],"or") + b = "false" and c = "true" => ["not",predTran a] + x + x + +getEqualSublis pred == fn(pred,nil) where fn(x,sl) == + (x:= SUBLIS(sl,x)) is [op,:l] and op in '(_and _or) => + for y in l repeat sl:= fn(y,sl) + sl + x is ["is",a,b] => [[a,:b],:sl] + x is ["=",a,b] => + IDENTP a and not CONTAINED(a,b) => [[a,:b],:sl] + IDENTP b and not CONTAINED(b,a) => [[b,:a],:sl] + sl + sl + +--% User function analysis + +mapCatchName mapname == + INTERN STRCONC('"$",STRINGIMAGE mapname,'"CatchMapIdentifier$") + +analyzeMap(op,argTypes,mapDef, tar) == + -- Top level enty point for map type analysis. Sets up catch point + -- for interpret-code mode. + $compilingMap:local := true + $definingMap:local := true + $minivector : local := nil -- later becomes value of $minivectorName + $mapThrowCount : local := 0 -- number of "return"s encountered + $mapReturnTypes : local := nil -- list of types from returns + $repeatLabel : local := nil -- for loops; see upREPEAT + $breakCount : local := 0 -- breaks from loops; ditto + $mapTarget : local := tar + $interpOnly: local := NIL + $mapName : local := op.0 + if get($mapName,'recursive,$e) then + argTypes := [f t for t in argTypes] where + f x == + isEqualOrSubDomain(x,$Integer) => $Integer + x + mapAndArgTypes := [$mapName,:argTypes] + member(mapAndArgTypes,$analyzingMapList) => + -- if the map is declared, return the target type + (getMode op) is ['Mapping,target,:.] => target + throwKeyedMsg("S2IM0009", + [$mapName,['" ", map for [map,:.] in $analyzingMapList]]) + PUSH(mapAndArgTypes,$analyzingMapList) + mapDef := mapDefsWithCorrectArgCount(#argTypes, mapDef) + null mapDef => (POP $analyzingMapList; nil) + + UNWIND_-PROTECT(x:=CATCH('mapCompiler,analyzeMap0(op,argTypes,mapDef)), + POP $analyzingMapList) + x='tryInterpOnly => + opName:=getUnname op + fun := mkInterpFun(op,opName,argTypes) + if getMode op isnt ['Mapping,:sig] then + sig := [nil,:[nil for type in argTypes]] + $e:=putHist(opName,'localModemap, + [[['interpOnly,:sig],fun,NIL]],$e) + x + +analyzeMap0(op,argTypes,mapDef) == + -- Type analyze and compile a map. Returns the target type of the map. + -- only called if there is no applicable compiled map + $MapArgumentTypeList:local:= argTypes + numMapArgs mapDef ^= #argTypes => nil + ((m:=getMode op) is ['Mapping,:sig]) or (m and (sig:=[m])) => + -- op has mapping property only if user has declared the signature + analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) + analyzeUndeclaredMap(getUnname op,argTypes,mapDef,$mapList) + +compFailure msg == + -- Called when compilation fails in such a way that interpret-code + -- mode might be of some use. + not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) + if $reportInterpOnly then + sayMSG msg + sayMSG '" We will attempt to interpret the code." + null $compilingMap => THROW('loopCompiler,'tryInterpOnly) + THROW('mapCompiler,'tryInterpOnly) + +mkInterpFun(op,opName,argTypes) == + -- creates a function form to put in fun slot of interp-only + -- local modemaps + getMode op isnt ['Mapping,:sig] => nil + parms := [var for type in argTypes for var in $FormalMapVariableList] + arglCode := ['LIST,:[argCode for type in argTypes + for argName in parms]] where argCode == + ['putValueValue,['mkAtreeNode,MKQ argName], + objNewCode(['wrap,argName],type)] + funName := GENSYM() + body:=['rewriteMap1,MKQ opName,arglCode,MKQ sig] + putMapCode(opName,body,sig,funName,parms,false) + genMapCode(opName,body,sig,funName,parms,false) + funName + +rewriteMap(op,opName,argl) == + -- interpret-code handler for maps. Recursively calls the interpreter + -- on the body of the map. + not $genValue => + get(opName,'mode,$e) isnt ['Mapping,:sig] => + compFailure ['" Cannot compile map:",:bright opName] + arglCode := ['LIST,:[argCode for arg in argl for argName in + $FormalMapVariableList]] where argCode == + ['putValueValue,['mkAtreeNode,MKQ argName], + objNewCode(['wrap,wrapped2Quote(objVal getValue arg)], + getMode arg)] + putValue(op,objNew(['rewriteMap1,MKQ opName,arglCode,MKQ sig], + CAR sig)) + putModeSet(op,[CAR sig]) + rewriteMap0(op,opName,argl) + +putBodyInEnv(opName, numArgs) == + val := get(opName, 'value, $e) + val is [.,'MAP, :bod] => + $e := putHist(opName, 'mapBody, combineMapParts + mapDefsWithCorrectArgCount(numArgs, bod), $e) + 'failed + +removeBodyFromEnv(opName) == + $e := putHist(opName, 'mapBody, nil, $e) + + +rewriteMap0(op,opName,argl) == + -- $genValue case of map rewriting + putBodyInEnv(opName, #argl) + if (s := get(opName,'mode,$e)) then + tar := CADR s + argTypes := CDDR s + else + tar:= nil + argTypes:= nil + get(opName,'mode,$e) is ['Mapping,tar,:argTypes] + $env: local := [[NIL]] + for arg in argl + for var in $FormalMapVariableList repeat + if argTypes then + t := CAR argTypes + argTypes:= CDR argTypes + val := + t is ['Mapping,:.] => getValue arg + coerceInteractive(getValue arg,t) + else + val:= getValue arg + $env:=put(var,'value,val,$env) + if VECP arg then $env := put(var,'name,getUnname arg,$env) + (m := getMode arg) => $env := put(var,'mode,m,$env) + null (val:= interpMap(opName,tar)) => + throwKeyedMsg("S2IM0010",[opName]) + putValue(op,val) + removeBodyFromEnv(opName) + ms := putModeSet(op,[objMode val]) + +rewriteMap1(opName,argl,sig) == + -- compiled case of map rewriting + putBodyInEnv(opName, #argl) + if sig then + tar:= CAR sig + argTypes:= CDR sig + else + tar:= nil + argTypes:= nil + evArgl := NIL + for arg in reverse argl repeat + v := getValue arg + evArgl := [objNew(objVal v, objMode v),:evArgl] + $env : local := [[NIL]] + for arg in argl for evArg in evArgl + for var in $FormalMapVariableList repeat + if argTypes then + t:=CAR argTypes + argTypes:= CDR argTypes + val := + t is ['Mapping,:.] => evArg + coerceInteractive(evArg,t) + else + val:= evArg + $env:=put(var,'value,val,$env) + if VECP arg then $env := put(var,'name,getUnname arg,$env) + (m := getMode arg) => $env := put(var,'mode,m,$env) + val:= interpMap(opName,tar) + removeBodyFromEnv(opName) + objValUnwrap(val) + +interpMap(opName,tar) == + -- call the interpreter recursively on map body + $genValue : local:= true + $interpMapTag : local := nil + $interpOnly : local := true + $localVars : local := NIL + for lvar in get(opName,'localVars,$e) repeat mkLocalVar(opName,lvar) + $mapName : local := opName + $mapTarget : local := tar + body:= get(opName,'mapBody,$e) + savedTimerStack := COPY $timedNameStack + catchName := mapCatchName $mapName + c := CATCH(catchName, interpret1(body,tar,nil)) +-- $interpMapTag and $interpMapTag ^= mapCatchName $mapName => +-- THROW($interpMapTag,c) + while savedTimerStack ^= $timedNameStack repeat + stopTimingProcess peekTimedName() + c -- better be a triple + +analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) == + -- analyzes and compiles maps with declared signatures. argTypes + -- is a list of types of the arguments, sig is the declared signature + -- mapDef is the stored form of the map body. + opName := getUnname op + $mapList:=[opName,:$mapList] + $mapTarget := CAR sig + (mmS:= get(opName,'localModemap,$e)) and + (mm:= or/[mm for (mm:=[[.,:mmSig],:.]) in mmS | mmSig=sig]) => + compileCoerceMap(opName,argTypes,mm) + -- The declared map needs to be compiled + compileDeclaredMap(opName,sig,mapDef) + argTypes ^= CDR sig => + analyzeDeclaredMap(op,argTypes,sig,mapDef,$mapList) + CAR sig + +compileDeclaredMap(op,sig,mapDef) == + -- Type analyzes and compiles a map with a declared signature. + -- creates a local modemap and puts it into the environment + $localVars: local := nil + $freeVars: local := nil + $env:local:= [[NIL]] + parms:=[var for var in $FormalMapVariableList for m in CDR sig] + for m in CDR sig for var in parms repeat + $env:= put(var,'mode,m,$env) + body:= getMapBody(op,mapDef) + for lvar in parms repeat mkLocalVar($mapName,lvar) + for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) + name := makeLocalModemap(op,sig) + val := compileBody(body,CAR sig) + isRecursive := (depthOfRecursion(op,body) > 0) + putMapCode(op,objVal val,sig,name,parms,isRecursive) + genMapCode(op,objVal val,sig,name,parms,isRecursive) + CAR sig + +putMapCode(op,code,sig,name,parms,isRecursive) == + -- saves the generated code and some other information about the + -- function + codeInfo := VECTOR(op,code,sig,name,parms,isRecursive) + allCode := [codeInfo,:get(op,'generatedCode,$e)] + $e := putHist(op,'generatedCode,allCode,$e) + op + +makeLocalModemap(op,sig) == + -- create a local modemap for op with sig, and put it into $e + if (currentMms := get(op,'localModemap,$e)) then + untraceMapSubNames [CADAR currentMms] + newName := makeInternalMapName(op,#sig-1,1+#currentMms,NIL) + newMm := [['local,:sig],newName,nil] + mms := [newMm,:currentMms] + $e := putHist(op,'localModemap,mms,$e) + newName + +genMapCode(op,body,sig,fnName,parms,isRecursive) == + -- calls the lisp compiler on the body of a map + if lmm:= get(op,'localModemap,$InteractiveFrame) then + untraceMapSubNames [CADAR lmm] + op0 := + ( n := isSharpVarWithNum op ) => STRCONC('"") + op + if get(op,'isInterpreterRule,$e) then + sayKeyedMsg("S2IM0014",[op0,(PAIRP sig =>prefix2String CAR sig;'"?")]) + else sayKeyedMsg("S2IM0015",[op0,formatSignature sig]) + $whereCacheList := [op,:$whereCacheList] + + -- RSS: 6-21-94 + -- The following code ensures that local variables really are local + -- to a function. We will unnecessarily generate preliminary LETs for + -- loop variables and variables that do have LET expressions, but that + -- can be finessed later. + + locals := SETDIFFERENCE(COPY $localVars, parms) + if locals then + lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals] + body := ['PROGN, :lets, body] + + reportFunctionCompilation(op,fnName,parms, + wrapMapBodyWithCatch flattenCOND body,isRecursive) + +compileBody(body,target) == + -- recursively calls the interpreter on the map body + -- returns a triple with the LISP code for body in the value cell + $insideCompileBodyIfTrue: local := true + $genValue: local := false + $declaredMode:local := target + $eval:local:= true + r := interpret1(body,target,nil) + +compileCoerceMap(op,argTypes,mm) == + -- compiles call to user-declared map where the arguments need + -- to be coerced. mm is the modemap for the declared map. + $insideCompileBodyIfTrue: local := true + $genValue: local := false + [[.,:sig],imp,.]:= mm + parms:= [var for var in $FormalMapVariableList for t in CDR sig] + name:= makeLocalModemap(op,[CAR sig,:argTypes]) + argCode := [objVal(coerceInteractive(objNew(arg,t1),t2) or + throwKeyedMsg("S2IC0001",[arg,$mapName,t1,t2])) + for t1 in argTypes for t2 in CDR sig for arg in parms] + $insideCompileBodyIfTrue := false + parms:= [:parms,'envArg] + body := ['SPADCALL,:argCode,['LIST,['function,imp]]] + minivectorName := makeInternalMapMinivectorName(name) + $minivectorNames := [[op,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + compileInteractive [name,['LAMBDA,parms,body]] + CAR sig + +depthOfRecursion(opName,body) == + -- returns the "depth" of recursive calls of opName in body + mapRecurDepth(opName,nil,body) + +mapRecurDepth(opName,opList,body) == + -- walks over the map body counting depth of recursive calls + -- expanding the bodies of maps called in body + atom body => 0 + body is [op,:argl] => + argc:= + atom argl => 0 + argl => "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] + 0 + op in opList => argc + op=opName => 1 + argc + (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => + mapRecurDepth(opName,[op,:opList],getMapBody(op,mapDef)) + + argc + argc + keyedSystemError("S2GE0016",['"mapRecurDepth", + '"unknown function form"]) + +analyzeUndeclaredMap(op,argTypes,mapDef,$mapList) == + -- Computes the signature of the map named op, and compiles the body + $freeVars:local := NIL + $localVars: local := NIL + $env:local:= [[NIL]] + $mapList := [op,:$mapList] + parms:=[var for var in $FormalMapVariableList for m in argTypes] + for m in argTypes for var in parms repeat + put(var,'autoDeclare,'T,$env) + put(var,'mode,m,$env) + body:= getMapBody(op,mapDef) + for lvar in parms repeat mkLocalVar($mapName,lvar) + for lvar in getLocalVars(op,body) repeat mkLocalVar($mapName,lvar) + (n:= depthOfRecursion(op,body)) = 0 => + analyzeNonRecursiveMap(op,argTypes,body,parms) + analyzeRecursiveMap(op,argTypes,body,parms,n) + +analyzeNonRecursiveMap(op,argTypes,body,parms) == + -- analyze and compile a non-recursive map definition + T := compileBody(body,$mapTarget) + if $mapThrowCount > 0 then + t := objMode T + b := and/[(t = rt) for rt in $mapReturnTypes] + not b => + t := resolveTypeListAny [t,:$mapReturnTypes] + if not $mapTarget then $mapTarget := t + T := compileBody(body,$mapTarget) + sig := [objMode T,:argTypes] + name:= makeLocalModemap(op,sig) + putMapCode(op,objVal T,sig,name,parms,false) + genMapCode(op,objVal T,sig,name,parms,false) + objMode(T) + +analyzeRecursiveMap(op,argTypes,body,parms,n) == + -- analyze and compile a non-recursive map definition + -- makes guess at signature by analyzing non-recursive part of body + -- then re-analyzes the entire body until the signature doesn't change + localMapInfo := saveDependentMapInfo(op, CDR $mapList) + tar := CATCH('interpreter,analyzeNonRecur(op,body,$localVars)) + for i in 0..n until not sigChanged repeat + sigChanged:= false + name := makeLocalModemap(op,sig:=[tar,:argTypes]) + code := compileBody(body,$mapTarget) + objMode(code) ^= tar => + sigChanged:= true + tar := objMode(code) + restoreDependentMapInfo(op, CDR $mapList, localMapInfo) + sigChanged => throwKeyedMsg("S2IM0011",[op]) + putMapCode(op,objVal code,sig,name,parms,true) + genMapCode(op,objVal code,sig,name,parms,true) + tar + +saveDependentMapInfo(op,opList) == + not (op in opList) => + lmml := [[op, :get(op, 'localModemap, $e)]] + gcl := [[op, :get(op, 'generatedCode, $e)]] + for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat + [lmml', :gcl'] := saveDependentMapInfo(dep2, [op, :opList]) + lmms := nconc(lmml', lmml) + gcl := nconc(gcl', gcl) + [lmms, :gcl] + nil + +restoreDependentMapInfo(op, opList, [lmml,:gcl]) == + not (op in opList) => + clearDependentMaps(op,opList) + for [op, :lmm] in lmml repeat + $e := putHist(op,'localModemap,lmm,$e) + for [op, :gc] in gcl repeat + $e := putHist(op,'generatedCode,gc,$e) + +clearDependentMaps(op,opList) == + -- clears the local modemaps of all the maps that depend on op + not (op in opList) => + $e := putHist(op,'localModemap,nil,$e) + $e := putHist(op,'generatedCode,nil,$e) + for [dep1,dep2] in getFlag("$dependencies") | dep1=op repeat + clearDependentMaps(dep2,[op,:opList]) + +analyzeNonRecur(op,body,$localVars) == + -- type analyze the non-recursive part of a map body + nrp := nonRecursivePart(op,body) + for lvar in findLocalVars(op,nrp) repeat mkLocalVar($mapName,lvar) + objMode(compileBody(nrp,$mapTarget)) + +nonRecursivePart(opName, funBody) == + -- takes funBody, which is the parse tree of the definition of + -- a function, and returns a list of the parts + -- of the function which are not recursive in the name opName + body:= expandRecursiveBody([opName], funBody) + ((nrp:=nonRecursivePart1(opName, body)) ^= 'noMapVal) => nrp + throwKeyedMsg("S2IM0012",[opName]) + +expandRecursiveBody(alreadyExpanded, body) == + -- replaces calls to other maps with their bodies + atom body => + (obj := get(body,'value,$e)) and objVal obj is ['MAP,:mapDef] and + ((numMapArgs mapDef) = 0) => getMapBody(body,mapDef) + body + body is [op,:argl] => + not (op in alreadyExpanded) => + (obj := get(op,'value,$e)) and objVal obj is ['MAP,:mapDef] => + newBody:= getMapBody(op,mapDef) + for arg in argl for var in $FormalMapVariableList repeat + newBody:=MSUBST(arg,var,newBody) + expandRecursiveBody([op,:alreadyExpanded],newBody) + [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] + [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] + keyedSystemError("S2GE0016",['"expandRecursiveBody", + '"unknown form of function body"]) + +nonRecursivePart1(opName, funBody) == + -- returns a function body which contains only the parts of funBody + -- which do not call the function opName + funBody is ['IF,a,b,c] => + nra:=nonRecursivePart1(opName,a) + nra = 'noMapVal => 'noMapVal + nrb:=nonRecursivePart1(opName,b) + nrc:=nonRecursivePart1(opName,c) + not (nrb in '(noMapVal noBranch)) => ['IF,nra,nrb,nrc] + not (nrc in '(noMapVal noBranch)) => ['IF,['not,nra],nrc,nrb] + 'noMapVal + not containsOp(funBody,'IF) => + notCalled(opName,funBody) => funBody + 'noMapVal + funBody is [op,:argl] => + op=opName => 'noMapVal + args:= [nonRecursivePart1(opName,arg) for arg in argl] + MEMQ('noMapVal,args) => 'noMapVal + [op,:args] + funBody + +containsOp(body,op) == + -- true IFF body contains an op statement + body is [ =op,:.] => true + body is [.,:argl] => or/[containsOp(arg,op) for arg in argl] + false + +notCalled(opName,form) == + -- returns true if opName is not called in the form + atom form => true + form is [op,:argl] => + op=opName => false + and/[notCalled(opName,x) for x in argl] + keyedSystemError("S2GE0016",['"notCalled", + '"unknown form of function body"]) + +mapDefsWithCorrectArgCount(n, mapDef) == + [def for def in mapDef | (numArgs CAR def) = n] + +numMapArgs(mapDef is [[args,:.],:.]) == + -- returns the number of arguemnts to the map whose body is mapDef + numArgs args + +numArgs args == + args is ['_|,a,:.] => numArgs a + args is ['Tuple,:argl] => #argl + null args => 0 + 1 + +combineMapParts(mapTail) == + -- transforms a piece-wise function definition into an if-then-else + -- statement. Uses noBranch to indicate undefined branch + null mapTail => 'noMapVal + mapTail is [[cond,:part],:restMap] => + isSharpVarWithNum cond or (cond is ['Tuple,:args] and + and/[isSharpVarWithNum arg for arg in args]) or (null cond) => part + ['IF,mkMapPred cond,part,combineMapParts restMap] + keyedSystemError("S2GE0016",['"combineMapParts", + '"unknown function form"]) + +mkMapPred cond == + -- create the predicate on map arguments, derived from "when" clauses + cond is ['_|,args,pred] => mapPredTran pred + cond is ['Tuple,:vals] => + mkValueCheck(vals,1) + mkValCheck(cond,1) + +mkValueCheck(vals,i) == + -- creates predicate for specific value check (i.e f 1 == 1) + vals is [val] => mkValCheck(val,i) + ['and,mkValCheck(first vals,i),mkValueCheck(rest vals,i+1)] + +mkValCheck(val,i) == + -- create equality check for map predicates + isSharpVarWithNum val => 'true + ['_=,mkSharpVar i,val] + +mkSharpVar i == + -- create #i + INTERN CONCAT('"#",STRINGIMAGE i) + +mapPredTran pred == + -- transforms "x in i..j" to "x>=i and x<=j" + pred is ['in,var,['SEGMENT,lb]] => mkLessOrEqual(lb,var) + pred is ['in,var,['SEGMENT,lb,ub]] => + null ub => mkLessOrEqual(lb,var) + ['and,mkLessOrEqual(lb,var),mkLessOrEqual(var,ub)] + pred + +findLocalVars(op,form) == + -- analyzes form for local and free variables, and returns the list + -- of locals + findLocalVars1(op,form) + $localVars + +findLocalVars1(op,form) == + -- sets the two lists $localVars and $freeVars + atom form => + not IDENTP form or isSharpVarWithNum form => nil + isLocalVar(form) or isFreeVar(form) => nil + mkFreeVar($mapName,form) + form is ['local, :vars] => + for x in vars repeat + ATOM x => mkLocalVar(op, x) + form is ['free, :vars] => + for x in vars repeat + ATOM x => mkFreeVar(op, x) + form is ['LET,a,b] => + (a is ['Tuple,:vars]) and (b is ['Tuple,:vals]) => + for var in vars for val in vals repeat + findLocalVars1(op,['LET,var,val]) + a is ['construct,:pat] => + for var in listOfVariables pat repeat mkLocalVar(op,var) + findLocalVars1(op,b) + (atom a) or (a is ['_:,a,.]) => + mkLocalVar(op,a) + findLocalVars1(op,b) + findLocalVars(op,b) + for x in a repeat findLocalVars1(op,x) + form is ['_:,a,.] => + mkLocalVar(op,a) + form is ['is,l,pattern] => + findLocalVars1(op,l) + for var in listOfVariables CDR pattern repeat mkLocalVar(op,var) + form is [oper,:itrl,body] and MEMQ(oper,'(REPEAT COLLECT)) => + findLocalsInLoop(op,itrl,body) + form is [y,:argl] => + y is 'Record => nil + for x in argl repeat findLocalVars1(op,x) + keyedSystemError("S2IM0020",[op]) + +findLocalsInLoop(op,itrl,body) == + for it in itrl repeat + it is ['STEP,index,lower,step,:upperList] => + mkLocalVar(op,index) + findLocalVars1(op,lower) + for up in upperList repeat findLocalVars1(op,up) + it is ['IN,index,s] => + mkLocalVar(op,index) ; findLocalVars1(op,s) + it is ['WHILE,b] => + findLocalVars1(op,b) + it is ['_|,pred] => + findLocalVars1(op,pred) + findLocalVars1(op,body) + for it in itrl repeat + it is [op,b] and (op in '(UNTIL)) => + findLocalVars1(op,b) + +isLocalVar(var) == member(var,$localVars) + +mkLocalVar(op,var) == + -- add var to the local variable list + isFreeVar(var) => $localVars + $localVars:= insert(var,$localVars) + +isFreeVar(var) == member(var,$freeVars) + +mkFreeVar(op,var) == + -- op here for symmetry with mkLocalVar + $freeVars:= insert(var,$freeVars) + +listOfVariables pat == + -- return a list of the variables in pat, which is an "is" pattern + IDENTP pat => (pat='_. => nil ; [pat]) + pat is ['_:,var] or pat is ['_=,var] => + (var='_. => NIL ; [var]) + PAIRP pat => REMDUP [:listOfVariables p for p in pat] + nil + +getMapBody(op,mapDef) == + -- looks in $e for a map body; if not found it computes then stores it + get(op,'mapBody,$e) or + combineMapParts mapDef +-- $e:= putHist(op,'mapBody,body:= combineMapParts mapDef,$e) +-- body + +getLocalVars(op,body) == + -- looks in $e for local vars; if not found, computes then stores them + get(op,'localVars,$e) or + $e:= putHist(op,'localVars,lv:=findLocalVars(op,body),$e) + lv + +-- DO NOT BELIEVE ALL OF THE FOLLOWING (IT IS OLD) + +-- VARIABLES. Variables may or may not have a mode property. If +-- present, any value which is assigned or generated by that variable +-- is first coerced to that mode before being assigned or returned. +-- +-- +-- Variables are given a triple [val,m,e] as a "value" property on +-- its property list in the environment. The expression val has the +-- forms: +-- +-- (WRAPPED . y) --value of x is y (don't re-evaluate) +-- y --anything else --value of x is obtained by evaluating y +-- +-- A wrapped expression is created by an assignment. In the second +-- case, y can never contain embedded wrapped expressions. The mode +-- part m of the triple is the type of y in the wrapped case and is +-- consistent with the declared mode if given. The mode part of an +-- unwrapped value is always $EmptyMode. The e part is usually NIL +-- but may be used to hold a partial closure. +-- +-- Effect of changes. A rule can be built up for a variable by +-- successive rules involving conditional expressions. However, once +-- a value is assigned to the variable or an unconditional definition +-- is given, any existing value is replaced by the new entry. When +-- the mode of a variable is declared, an wrapped value is coerced to +-- the new mode; if this is not possible, the user is notified that +-- the current value is discarded and why. When the mode is +-- redeclared and an upwrapped value is present, the value is +-- retained; the only other effect is to coerce any cached values +-- from the old mode to the new one. +-- +-- Caches. When a variable x is evaluated and re-evaluation occurs, +-- the triple produced by that evaluation is stored under "cache" on +-- the property list of x. This cached triple is cleared whenever any +-- of the variables which x's value depend upon change. Dependencies +-- are stored on $dependencies whose value has the form [[a b ..] ..] +-- to indicate that when a is changed, b .. must have all cached +-- values destroyed. In the case of parameterized forms which are +-- represented by maps, we currently can cache values only when the +-- compiler option is turned on by )on c s meaning "on compiler with +-- the save option". When f is compiled as f;1, it then has an alist +-- f;1;AL which records these values. If f depends globally on a's +-- value, all cached values of all local functions defined for f have +-- to be declared. If a's mode should change, then all compilations +-- of f must be thrown away. +-- +-- PARAMETERIZED FORMS. These always have values [val,m,e] where val +-- are "maps". +-- +-- The structure of maps: +-- (MAP (pattern . rewrite) ...) where +-- pattern has forms: arg-pattern +-- (Tuple arg-pattern ...) +-- rewrite has forms: (WRAPPED . value) --don't re-evaluate +-- computational object --don't (bother to) +-- re-evaluate +-- anything else --yes, re-evaluate +-- +-- When assigning values to a map, each new value must have a type +-- which is consistent with those already assigned. Initially, type +-- of MAP is $EmptyMode. When the map is first assigned a value, the +-- type of the MAP is RPLACDed to be (Mapping target source ..). +-- When the map is next assigned, the type of both source and target +-- is upgraded to be consistent with those values already computed. +-- Of course, if new and old source and target are identical, nothing +-- need happen to existing entries. However, if the new and old are +-- different, all existing entries of the map are coerce to the new +-- data type. +-- +-- Mode analysis. This is done on the bottomUp phase of the process. +-- If a function has been given a mapping declaration, this map is +-- placed in as the mode of the map under the "value" property of the +-- variable. Of course, these modes may be partial types in case a +-- mode analysis is still necessary. If no mapping declaration, a +-- total mode analysis of the function, given its input arguments, is +-- done. This will result a signature involving types only. +-- +-- If the compiler is on, the function is then compiled given this +-- signature involving types. If the map is value of a variable f, a +-- function is given name f;1, f is given a "localModemap" property +-- with modemap ((dummy target source ..) (T f;1)) so that the next +-- time f is applied to arguments which coerce to the source +-- arguments of this local modemap, f;1 will be invoked. +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/interop.boot b/src/interp/interop.boot deleted file mode 100644 index 87958dfc..00000000 --- a/src/interp/interop.boot +++ /dev/null @@ -1,906 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- note domainObjects are now (dispatchVector hashCode . domainVector) --- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), --- pre oldAxiomCategory is (dispatchVector . (cat form)) --- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist)) - -hashCode? x == INTEGERP x - -$domainTypeTokens := ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, - 'oldAxiomCategory, 0] - --- The name game. --- The compiler produces names that are of the form: --- a) cons(0, ) --- b) cons(1, type-name, arg-names...) --- c) cons(2, arg-names...) --- d) cons(3, value) --- NB: (c) is for tuple-ish constructors, --- and (d) is for dependent types. - -DNameStringID := 0 -DNameApplyID := 1 -DNameTupleID := 2 -DNameOtherID := 3 - -DNameToSExpr1 dname == - NULL dname => error "unexpected domain name" - CAR dname = DNameStringID => - INTERN(CompStrToString CDR dname) - name0 := DNameToSExpr1 CAR CDR dname - args := CDR CDR dname - name0 = '_-_> => - froms := CAR args - froms := MAPCAR(function DNameToSExpr, CDR froms) - ret := CAR CDR args -- a tuple - ret := DNameToSExpr CAR CDR ret -- contents - CONS('Mapping, CONS(ret, froms)) - name0 = 'Union or name0 = 'Record => - sxs := MAPCAR(function DNameToSExpr, CDR CAR args) - CONS(name0, sxs) - name0 = 'Enumeration => - CONS(name0, MAPCAR(function DNameFixEnum, CDR CAR args)) - CONS(name0, MAPCAR(function DNameToSExpr, args)) - -DNameToSExpr dname == - CAR dname = DNameOtherID => - CDR dname - sx := DNameToSExpr1 dname - CONSP sx => sx - LIST sx - -DNameFixEnum arg == CompStrToString CDR arg - -SExprToDName(sexpr, cosigVal) == - -- is it a non-type valued object? - NOT cosigVal => [DNameOtherID, :sexpr] - if CAR sexpr = '_: then sexpr := CAR CDR CDR sexpr - CAR sexpr = 'Mapping => - args := [ SExprToDName(sx, 'T) for sx in CDR sexpr] - [DNameApplyID, - [DNameStringID,: StringToCompStr '"->"], - [DNameTupleID, : CDR args], - [DNameTupleID, CAR args]] - name0 := [DNameStringID, : StringToCompStr SYMBOL_-NAME CAR sexpr] - CAR sexpr = 'Union or CAR sexpr = 'Record => - [DNameApplyID, name0, - [DNameTupleID,: [ SExprToDName(sx, 'T) for sx in CDR sexpr]]] - newCosig := CDR GETDATABASE(CAR sexpr, QUOTE COSIG) - [DNameApplyID, name0, - : MAPCAR(function SExprToDName, CDR sexpr, newCosig)] - --- local garbage because Compiler strings are null terminated -StringToCompStr(str) == - CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0)) - -CompStrToString(str) == - SUBSTRING(str, 0, (LENGTH str - 1)) --- local garbage ends - -runOldAxiomFunctor(:allArgs) == - [:args,env] := allArgs - GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => - [$oldAxiomPreCategoryDispatch,: [env, :args]] - dom:=APPLY(env, args) - makeOldAxiomDispatchDomain dom - -makeLazyOldAxiomDispatchDomain domform == - attribute? domform => - [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)] - GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => - [$oldAxiomPreCategoryDispatch,: domform] - dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] - NCONC(dd,dd) -- installs back pointer to head of domain. - dd - -makeOldAxiomDispatchDomain dom == - PAIRP dom => dom - [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] - -closeOldAxiomFunctor(name) == - [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name] - -lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == - dom := instantiate domenv - SPADCALL(CDR dom, self, op, sig, box, skipdefaults, CAR(dom).3) - -lazyOldAxiomDomainHashCode(domenv, env) == CAR domenv - -lazyOldAxiomDomainDevaluate(domenv, env) == - dom := instantiate domenv - SPADCALL(CDR dom, CAR(dom).1) - -lazyOldAxiomAddChild(domenv, kid, env) == - CONS($lazyOldAxiomDomainDispatch,domenv) - -$lazyOldAxiomDomainDispatch := - VECTOR('lazyOldAxiomDomain, - [function lazyOldAxiomDomainDevaluate], - [nil], - [function lazyOldAxiomDomainLookupExport], - [function lazyOldAxiomDomainHashCode], - [function lazyOldAxiomAddChild]) - --- old Axiom pre category objects are just (dispatch . catform) --- where catform is ('categoryname,: evaluated args) --- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom]) -oldAxiomPreCategoryBuild(catform, dom, env) == - pack := oldAxiomCategoryDefaultPackage(catform, dom) - CONS($oldAxiomCategoryDispatch, - [catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]) -oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0) -oldAxiomCategoryDefaultPackage(catform, dom) == - hasDefaultPackage opOf catform - -oldAxiomPreCategoryDevaluate([op,:args], env) == - SExprToDName([op,:devaluateList args], T) - -$oldAxiomPreCategoryDispatch := - VECTOR('oldAxiomPreCategory, - [function oldAxiomPreCategoryDevaluate], - [nil], - [nil], - [function oldAxiomPreCategoryHashCode], - [function oldAxiomPreCategoryBuild], - [nil]) - -oldAxiomCategoryDevaluate([[op,:args],:.], env) == - SExprToDName([op,:devaluateList args], T) - -oldAxiomPreCategoryParents(catform,dom) == - vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)] - vals := [dom,:rest catform] - -- parents := GETDATABASE(opOf catform, 'PARENTS) - parents := parentsOf opOf catform - PROGV(vars, vals, - LIST2VEC - [EVAL quoteCatOp cat for [cat,:pred] in parents | EVAL pred]) - -quoteCatOp cat == - atom cat => MKQ cat - ['LIST, MKQ CAR cat,: CDR cat] - - -oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == - [catform,hash, pack,:.] := catenv - opIsHasCat op => if EQL(sig, hash) then [self] else nil - NULL(pack) => nil - if not VECP pack then - pack:=apply(pack, CONS(self, rest catform)) - RPLACA(CDDR catenv, pack) - fun := basicLookup(op, sig, pack, self) => [fun] - nil - -oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents -oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == - catform := ELT(parvec, n-1) - VECTORP KAR catform => catform - newcat := oldAxiomPreCategoryBuild(catform,dom,nil) - SETELT(parvec, n-1, newcat) - newcat - -oldAxiomCategoryBuild([catform,:.], dom, env) == - oldAxiomPreCategoryBuild(catform,dom, env) -oldAxiomCategoryHashCode([.,hash,:.], env) == hash - -$oldAxiomCategoryDispatch := - VECTOR('oldAxiomCategory, - [function oldAxiomCategoryDevaluate], - [nil], - [function oldAxiomCategoryLookupExport], - [function oldAxiomCategoryHashCode], - [function oldAxiomCategoryBuild], -- builder ?? - [function oldAxiomCategoryParentCount], - [function oldAxiomCategoryNthParent]) -- 1 indexed - -attributeDevaluate(attrObj, env) == - [name, hash] := attrObj - StringToCompStr SYMBOL_-NAME name - -attributeLookupExport(attrObj, self, op, sig, box, env) == - [name, hash] := attrObj - opIsHasCat op => if EQL(hash, sig) then [self] else nil - -attributeHashCode(attrObj, env) == - [name, hash] := attrObj - hash - -attributeCategoryBuild(attrObj, dom, env) == - [name, hash] := attrObj - [$attributeDispatch, name, hash] - -attributeCategoryParentCount(attrObj, env) == 0 - -attributeNthParent(attrObj, env) == nil - -$attributeDispatch := - VECTOR('attribute, - [function attributeDevaluate], - [nil], - [function attributeLookupExport], - [function attributeHashCode], - [function attributeCategoryBuild], -- builder ?? - [function attributeCategoryParentCount], - [function attributeNthParent]) -- 1 indexed - - -orderedDefaults(conform,domform) == - $depthAssocCache : local := MAKE_-HASHTABLE 'ID - conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op] - acc := nil - ancestors := ancestorsOf(conform,domform) - for x in conList repeat - for y in ancestors | x = CAAR y repeat acc := [y,:acc] - NREVERSE acc - -instantiate domenv == - -- following is a patch for a bug in runtime.as - -- has a lazy dispatch vector with an instantiated domenv - VECTORP CDR domenv => [$oldAxiomDomainDispatch ,: domenv] - callForm := CADR domenv - oldDom := CDDR domenv - [functor,:args] := callForm --- if null(fn := GETL(functor,'instantiate)) then --- ofn := SYMBOL_-FUNCTION functor --- loadFunctor functor --- fn := SYMBOL_-FUNCTION functor --- SETF(SYMBOL_-FUNCTION functor, ofn) --- PUT(functor, 'instantiate, fn) --- domvec := APPLY(fn, args) - domvec := APPLY(functor, args) - RPLACA(oldDom, $oldAxiomDomainDispatch) - RPLACD(oldDom, [CADR oldDom,: domvec]) - oldDom - -hashTypeForm([fn,: args], percentHash) == - hashType([fn,:devaluateList args], percentHash) - ---------------------> NEW DEFINITION (override in i-util.boot.pamphlet) -devaluate(d) == - isDomain d => - -- ?need a shortcut for old domains - -- ELT(CAR d, 0) = 'oldAxiomDomain => ... - -- FIXP(ELT(CAR d,0)) => d - DNameToSExpr(SPADCALL(CDR d,CAR(d).1)) - not REFVECP d => d - QSGREATERP(QVSIZE d,5) and QREFELT(d,3) is ['Category] => QREFELT(d,0) - QSGREATERP(QVSIZE d,0) => - d':=QREFELT(d,0) - isFunctor d' => d' - d - d - -$hashOp1 := hashString '"1" -$hashOp0 := hashString '"0" -$hashOpApply := hashString '"apply" -$hashOpSet := hashString '"set!" -$hashSeg := hashString '".." -$hashPercent := hashString '"%" - -oldAxiomDomainLookupExport _ - (domenv, self, op, sig, box, skipdefaults, env) == - domainVec := CDR domenv - if hashCode? op then - EQL(op, $hashOp1) => op := 'One - EQL(op, $hashOp0) => op := 'Zero - EQL(op, $hashOpApply) => op := 'elt - EQL(op, $hashOpSet) => op := 'setelt - EQL(op, $hashSeg) => op := 'SEGMENT - constant := nil - if hashCode? sig and self and EQL(sig, getDomainHash self) then - sig := '($) - constant := true - val := - skipdefaults => - oldCompLookupNoDefaults(op, sig, domainVec, self) - oldCompLookup(op, sig, domainVec, self) - null val => val - if constant then val := SPADCALL val - RPLACA(box, val) - box - -oldAxiomDomainHashCode(domenv, env) == CAR domenv - -oldAxiomDomainHasCategory(domenv, cat, env) == - HasAttribute(domvec := CDR domenv, cat) or - HasCategory(domvec, devaluate cat) - -oldAxiomDomainDevaluate(domenv, env) == - SExprToDName(CDR(domenv).0, 'T) - -oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv) - -$oldAxiomDomainDispatch := - VECTOR('oldAxiomDomain, - [function oldAxiomDomainDevaluate], - [nil], - [function oldAxiomDomainLookupExport], - [function oldAxiomDomainHashCode], - [function oldAxiomAddChild]) - ---------------------> NEW DEFINITION (see g-util.boot.pamphlet) -isDomain a == - PAIRP a and VECP(CAR a) and - member(CAR(a).0, $domainTypeTokens) - --- following is interpreter interfact to function lookup --- perhaps it should always work with hashcodes for signature? ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -NRTcompiledLookup(op,sig,dom) == - if CONTAINED('_#,sig) then - sig := [NRTtypeHack t for t in sig] - hashCode? sig => compiledLookupCheck(op,sig,dom) - (fn := compiledLookup(op,sig,dom)) => fn - percentHash := - VECP dom => hashType(dom.0, 0) - getDomainHash dom - compiledLookupCheck(op, hashType(['Mapping,:sig], percentHash), dom) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -compiledLookup(op, sig, dollar) == - if not isDomain dollar then dollar := NRTevalDomain dollar - basicLookup(op, sig, dollar, dollar) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -basicLookup(op,sig,domain,dollar) == - -- following case is for old domains like Record and Union - -- or for getting operations out of yourself - VECP domain => - isNewWorldDomain domain => -- getting ops from yourself (or for defaults) - oldCompLookup(op, sig, domain, dollar) - -- getting ops from Record or Union - lookupInDomainVector(op,sig,domain,dollar) - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - box := [nil] - not VECP(dispatch := CAR domain) => error "bad domain format" - lookupFun := dispatch.3 - dispatch.0 = 0 => -- new compiler domain object - hashSig := - hashCode? sig => sig - opIsHasCat op => hashType(sig, hashPercent) - hashType(['Mapping,:sig], hashPercent) - - if SYMBOLP op then - op = 'Zero => op := $hashOp0 - op = 'One => op := $hashOp1 - op = 'elt => op := $hashOpApply - op = 'setelt => op := $hashOpSet - op := hashString SYMBOL_-NAME op - val:=CAR SPADCALL(CDR domain, dollar, op, hashSig, box, false, - lookupFun) => val - hashCode? sig => nil - #sig>1 or opIsHasCat op => nil - boxval := SPADCALL(CDR dollar, dollar, op, hashType(first sig, hashPercent), - box, false, lookupFun) => - [FUNCTION IDENTITY,: CAR boxval] - nil - opIsHasCat op => - HasCategory(domain, sig) - if hashCode? op then - EQL(op, $hashOp1) => op := 'One - EQL(op, $hashOp0) => op := 'Zero - EQL(op, $hashOpApply) => op := 'elt - EQL(op, $hashOpSet) => op := 'setelt - EQL(op, $hashSeg) => op := 'SEGMENT - hashCode? sig and EQL(sig, hashPercent) => - SPADCALL CAR SPADCALL(CDR dollar, dollar, op, '($), box, false, lookupFun) - CAR SPADCALL(CDR dollar, dollar, op, sig, box, false, lookupFun) - -basicLookupCheckDefaults(op,sig,domain,dollar) == - box := [nil] - not VECP(dispatch := CAR dollar) => error "bad domain format" - lookupFun := dispatch.3 - dispatch.0 = 0 => -- new compiler domain object - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - - hashSig := - hashCode? sig => sig - hashType( ['Mapping,:sig], hashPercent) - - if SYMBOLP op then op := hashString SYMBOL_-NAME op - CAR SPADCALL(CDR dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun) - CAR SPADCALL(CDR dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun) - -$hasCatOpHash := hashString '"%%" -opIsHasCat op == - hashCode? op => EQL(op, $hasCatOpHash) - EQ(op, "%%") - --- has cat questions lookup up twice if false --- replace with following ? --- not(opIsHasCat op) and --- (u := lookupInDomainVector(op,sig,domvec,domvec)) => u - -oldCompLookup(op, sig, domvec, dollar) == - $lookupDefaults:local := nil - u := lookupInDomainVector(op,sig,domvec,dollar) => u - $lookupDefaults := true - lookupInDomainVector(op,sig,domvec,dollar) - -oldCompLookupNoDefaults(op, sig, domvec, dollar) == - $lookupDefaults:local := nil - lookupInDomainVector(op,sig,domvec,dollar) - ---------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) -lookupInDomainVector(op,sig,domain,dollar) == - PAIRP domain => basicLookupCheckDefaults(op,sig,domain,domain) - slot1 := domain.1 - SPADCALL(op,sig,dollar,slot1) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupComplete(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,nil) - newLookupInTable(op,sig,dollar,env,nil) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupIncomplete(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) - newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lookupInCompactTable(op,sig,dollar,env) == - hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) - newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lazyMatchArg2(s,a,dollar,domain,typeFlag) == - if s = '$ then --- a = 0 => return true --needed only if extra call in newGoGet to basicLookup - s := devaluate dollar -- calls from HasCategory can have $s - INTEGERP a => - not typeFlag => s = domain.a - a = 6 and $isDefaultingPackage => s = devaluate dollar - VECP (d := domainVal(dollar,domain,a)) => - s = d.0 => true - domainArg := ($isDefaultingPackage => domain.6.0; domain.0) - KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - isDomain d => - dhash:=getDomainHash d - dhash = - (if hashCode? s then s else hashType(s, dhash)) --- s = devaluate d - lazyMatch(s,d,dollar,domain) --new style - a = '$ => s = devaluate dollar - a = "$$" => s = devaluate domain - STRINGP a => - STRINGP s => a = s - s is ['QUOTE,y] and PNAME y = a - IDENTP s and PNAME s = a - atom a => a = s - op := opOf a - op = 'NRTEVAL => s = nrtEval(CADR a,domain) - op = 'QUOTE => s = CADR a - lazyMatch(s,a,dollar,domain) - --above line is temporarily necessary until system is compiled 8/15/90 ---s = a - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -getOpCode(op,vec,max) == ---search Op vector for "op" returning code if found, nil otherwise - res := nil - hashCode? op => - for i in 0..max by 2 repeat - EQL(hashString PNAME QVELT(vec,i),op) => return (res := QSADD1 i) - res - for i in 0..max by 2 repeat - EQ(QVELT(vec,i),op) => return (res := QSADD1 i) - res - -hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == - opIsHasCat op => - HasCategory(domain, sig) - if hashCode? op and EQL(op, $hashOp1) then op := 'One - if hashCode? op and EQL(op, $hashOp0) then op := 'Zero - hashPercent := - VECP dollar => hashType(dollar.0,0) - hashType(dollar,0) - if hashCode? sig and EQL(sig, hashPercent) then - sig := hashType('(Mapping $), hashPercent) - dollar = nil => systemError() - $lookupDefaults = true => - hashNewLookupInCategories(op,sig,domain,dollar) --lookup first in my cats - or newLookupInAddChain(op,sig,domain,dollar) - --fast path when called from newGoGet - success := false - if $monitorNewWorld then - sayLooking(concat('"---->",form2String devaluate domain, - '"----> searching op table for:","%l"," "),op,sig,dollar) - someMatch := false - numvec := getDomainByteVector domain - predvec := domain.3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return - flag => newLookupInAddChain(op,sig,domain,dollar) - nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - numArgs := if hashCode? sig then -1 else (#sig)-1 - success := nil - $isDefaultingPackage: local := - -- use special defaulting handler when dollar non-trivial - dollar ^= domain and isDefaultPackageForm? devaluate domain - while finish > start repeat - PROGN - i := start - numTableArgs :=numvec.i - predIndex := numvec.(i := QSADD1 i) - (predIndex ^= 0) and null testBitVector(predvec,predIndex) => nil - exportSig := - [newExpandTypeSlot(numvec.(i + j + 1), - dollar,domain) for j in 0..numTableArgs] - sig ^= hashType(['Mapping,: exportSig],hashPercent) => nil --signifies no match - loc := numvec.(i + numTableArgs + 2) - loc = 1 => (someMatch := true) - loc = 0 => - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - i := start + 2 - someMatch := true --mark so that if subsumption fails, look for original - subsumptionSig := - [newExpandTypeSlot(numvec.(QSPLUS(i,j)), - dollar,domain) for j in 0..numTableArgs] - if $monitorNewWorld then - sayBrightly [formatOpSignature(op,sig),'"--?-->", - formatOpSignature(op,subsumptionSig)] - nil - slot := domain.loc - null atom slot => - EQ(QCAR slot,'newGoGet) => someMatch:=true - --treat as if operation were not there - --if EQ(QCAR slot,'newGoGet) then - -- UNWIND_-PROTECT --break infinite recursion - -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), - -- if domain.loc = 'skip then domain.loc := slot) - return (success := slot) - slot = 'skip => --recursive call from above 'replaceGoGetSlot - return (success := newLookupInAddChain(op,sig,domain,dollar)) - systemError '"unexpected format" - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - (success ^= 'failed) and success => - if $monitorNewWorld then - sayLooking1('"<----",uu) where uu() == - PAIRP success => [first success,:devaluate rest success] - success - success - subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u - flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) - nil - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - isDomain lazyt => devaluate lazyt - ATOM lazyt => lazyt - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - -hashNewLookupInCategories(op,sig,dom,dollar) == - slot4 := dom.4 - catVec := CADR slot4 - SIZE catVec = 0 => nil --early exit if no categories - INTEGERP KDR catVec.0 => - newLookupInCategories1(op,sig,dom,dollar) --old style - $lookupDefaults : local := nil - if $monitorNewWorld = true then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := dom.3 - packageVec := QCAR slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..MAXINDEX packageVec | - (entry := packageVec.i) and entry ^= 'T repeat - package := - VECP entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - IDENTP entry => - cat := catVec.i - packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) - success := - --VECP infovec => ----new world - true => ----new world - opvec := infovec.1 - max := MAXINDEX opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDDR infovec.3 - endPos := - code+2 > max => SIZE byteVector - opvec.(code+2) - --not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil - --numOfArgs := byteVector.(opvec.code) - --numOfArgs ^= #(QCDR sig) => nil - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - ----old world - table := HGET($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u]) => - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld = true then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := basicLookup(op,sig,package,dollar) => - if $monitorNewWorld = true then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld = true then - sayBrightly '"candidate fails -- continuing to search categories" - nil - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -replaceGoGetSlot env == - [thisDomain,index,:op] := env - thisDomainForm := devaluate thisDomain - bytevec := getDomainByteVector thisDomain - numOfArgs := bytevec.index - goGetDomainSlotIndex := bytevec.(index := QSADD1 index) - goGetDomain := - goGetDomainSlotIndex = 0 => thisDomain - thisDomain.goGetDomainSlotIndex - if PAIRP goGetDomain and SYMBOLP CAR goGetDomain then - goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) - sig := - [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) - for i in 0..numOfArgs] - thisSlot := bytevec.(QSADD1 index) - if $monitorNewWorld then - sayLooking(concat('"%l","..",form2String thisDomainForm, - '" wants",'"%l",'" "),op,sig,goGetDomain) - slot := basicLookup(op,sig,goGetDomain,goGetDomain) - slot = nil => - $returnNowhereFromGoGet = true => - ['nowhere,:goGetDomain] --see newGetDomainOpTable - sayBrightly concat('"Function: ",formatOpSignature(op,sig), - '" is missing from domain: ",form2String goGetDomain.0) - keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) - if $monitorNewWorld then - sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) - SETELT(thisDomain,thisSlot,slot) - if $monitorNewWorld then - sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) - slot - -HasAttribute(domain,attrib) == - hashPercent := - VECP domain => hashType(domain.0,0) - hashType(domain,0) - isDomain domain => - FIXP((first domain).0) => - -- following call to hashType was missing 2nd arg. - -- getDomainHash domain added on 4/01/94 by RSS - basicLookup("%%",hashType(attrib, hashPercent),domain,domain) - HasAttribute(CDDR domain, attrib) ---> - isNewWorldDomain domain => newHasAttribute(domain,attrib) ---+ - (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) - -newHasAttribute(domain,attrib) == - hashPercent := - VECP domain => hashType(domain.0,0) - hashType(domain,0) - predIndex := - hashCode? attrib => - -- following call to hashType was missing 2nd arg. - -- hashPercent added by PAB 15/4/94 - or/[x for x in domain.2 | attrib = hashType(first x, hashPercent)] - LASSOC(attrib,domain.2) - predIndex => - EQ(predIndex,0) => true - predvec := domain.3 - testBitVector(predvec,predIndex) - false - -newHasCategory(domain,catform) == - catform = '(Type) => true - slot4 := domain.4 - auxvec := CAR slot4 - catvec := CADR slot4 - $isDefaultingPackage: local := isDefaultPackageForm? devaluate domain - #catvec > 0 and INTEGERP KDR catvec.0 => --old style - predIndex := lazyMatchAssocV1(catform,catvec,domain) - null predIndex => false - EQ(predIndex,0) => true - predvec := QVELT(domain,3) - testBitVector(predvec,predIndex) - lazyMatchAssocV(catform,auxvec,catvec,domain) --new style - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 - n : FIXNUM := MAXINDEX catvec - -- following call to hashType was missing 2nd arg. 0 added on 3/31/94 by RSS - hashCode? x => - percentHash := - VECP domain => hashType(domain.0, 0) - getDomainHash domain - or/[ELT(auxvec,i) for i in 0..n | - x = hashType(newExpandLocalType(QVELT(catvec,i),domain,domain), percentHash)] - xop := CAR x - or/[ELT(auxvec,i) for i in 0..n | - --xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] - xop = CAR (lazyt := getCatForm(catvec,i,domain)) and lazyMatch(x,lazyt,domain,domain)] - -getCatForm(catvec, index, domain) == - NUMBERP(form := QVELT(catvec,index)) => domain.form - form - -has(domain,catform') == HasCategory(domain,catform') - -HasCategory(domain,catform') == - catform' is ['SIGNATURE,:f] => HasSignature(domain,f) - catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) - isDomain domain => - FIXP((first domain).0) => - catform' := devaluate catform' - basicLookup("%%",catform',domain,domain) - HasCategory(CDDR domain, catform') - catform:= devaluate catform' - isNewWorldDomain domain => newHasCategory(domain,catform) - domain0:=domain.0 -- handles old style domains, Record, Union etc. - slot4 := domain.4 - catlist := slot4.1 - member(catform,catlist) or - MEMQ(opOf(catform),'(Object Type)) or --temporary hack - or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] - ---systemDependentMkAutoload(fn,cnam) == --- FBOUNDP(cnam) => "next" --- SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - ---------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) -lazyDomainSet(lazyForm,thisDomain,slot) == - form := - --lazyForm is [vec,.,:u] and VECP vec => u --old style - lazyForm --new style - slotDomain := evalSlotDomain(form,thisDomain) - if $monitorNewWorld then - sayLooking1(concat(form2String devaluate thisDomain, - '" activating lazy slot ",slot,'": "),slotDomain) --- name := CAR form ---getInfovec name - SETELT(thisDomain,slot,slotDomain) - - ---------------------> NEW DEFINITION (override in template.boot.pamphlet) -evalSlotDomain(u,dollar) == - $returnNowhereFromGoGet: local := false - $ : fluid := dollar - $lookupDefaults : local := nil -- new world - isDomain u => u - u = '$ => dollar - u = "$$" => dollar - FIXP u => - VECP (y := dollar.u) => y - isDomain y => y - y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? - y is [v,:.] => - VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] - constructor? v or MEMQ(v,'(Record Union Mapping)) => - lazyDomainSet(y,dollar,u) --new style has lazyt - y - y - u is ['NRTEVAL,y] => - y is ['ELT,:.] => evalSlotDomain(y,dollar) - eval y - u is ['QUOTE,y] => y - u is ['Record,:argl] => - FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is ['Union,:argl] and first argl is ['_:,.,.] => - APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is ['spadConstant,d,n] => - dom := evalSlotDomain(d,dollar) - SPADCALL(dom . n) - u is ['ELT,d,n] => - dom := evalSlotDomain(d,dollar) - slot := dom . n - slot is ['newGoGet,:env] => replaceGoGetSlot env - slot - u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) - systemErrorHere '"evalSlotDomain" - ---------------------> NEW DEFINITION (override in i-util.boot.pamphlet) -domainEqual(a,b) == - devaluate(a) = devaluate(b) - ---makeConstructorsAutoLoad() - --- following changes should go back into xrun.boot --- patched version from xrun.boot ---------------------> NEW DEFINITION (override in clammed.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -coerceConvertMmSelection(funName,m1,m2) == - -- calls selectMms with $Coerce=NIL and tests for required - -- target type. funName is either 'coerce or 'convert. - $declaredMode : local:= NIL - $reportBottomUpFlag : local:= NIL - l := selectMms1(funName,m2,[m1],[m1],NIL) --- mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and - mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and - sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] - mmS and CAR mmS - ---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) -getFunctionFromDomain(op,dc,args) == - -- finds the function op with argument types args in dc - -- complains, if no function or ambiguous - $reportBottomUpFlag:local:= NIL - member(CAR dc,$nonLisplibDomains) => - throwKeyedMsg("S2IF0002",[CAR dc]) - not constructor? CAR dc => - throwKeyedMsg("S2IF0003",[CAR dc]) - p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => ---+ - --sig := [NIL,:args] - domain := evalDomain dc - for mm in nreverse p until b repeat - [[.,:osig],nsig,:.] := mm - b := compiledLookup(op,nsig,domain) - b or throwKeyedMsg("S2IS0023",[op,dc]) - throwKeyedMsg("S2IF0004",[op,dc]) - diff --git a/src/interp/interop.boot.pamphlet b/src/interp/interop.boot.pamphlet new file mode 100644 index 00000000..88d4e560 --- /dev/null +++ b/src/interp/interop.boot.pamphlet @@ -0,0 +1,933 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/interop.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- note domainObjects are now (dispatchVector hashCode . domainVector) +-- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), +-- pre oldAxiomCategory is (dispatchVector . (cat form)) +-- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist)) + +hashCode? x == INTEGERP x + +$domainTypeTokens := ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, + 'oldAxiomCategory, 0] + +-- The name game. +-- The compiler produces names that are of the form: +-- a) cons(0, ) +-- b) cons(1, type-name, arg-names...) +-- c) cons(2, arg-names...) +-- d) cons(3, value) +-- NB: (c) is for tuple-ish constructors, +-- and (d) is for dependent types. + +DNameStringID := 0 +DNameApplyID := 1 +DNameTupleID := 2 +DNameOtherID := 3 + +DNameToSExpr1 dname == + NULL dname => error "unexpected domain name" + CAR dname = DNameStringID => + INTERN(CompStrToString CDR dname) + name0 := DNameToSExpr1 CAR CDR dname + args := CDR CDR dname + name0 = '_-_> => + froms := CAR args + froms := MAPCAR(function DNameToSExpr, CDR froms) + ret := CAR CDR args -- a tuple + ret := DNameToSExpr CAR CDR ret -- contents + CONS('Mapping, CONS(ret, froms)) + name0 = 'Union or name0 = 'Record => + sxs := MAPCAR(function DNameToSExpr, CDR CAR args) + CONS(name0, sxs) + name0 = 'Enumeration => + CONS(name0, MAPCAR(function DNameFixEnum, CDR CAR args)) + CONS(name0, MAPCAR(function DNameToSExpr, args)) + +DNameToSExpr dname == + CAR dname = DNameOtherID => + CDR dname + sx := DNameToSExpr1 dname + CONSP sx => sx + LIST sx + +DNameFixEnum arg == CompStrToString CDR arg + +SExprToDName(sexpr, cosigVal) == + -- is it a non-type valued object? + NOT cosigVal => [DNameOtherID, :sexpr] + if CAR sexpr = '_: then sexpr := CAR CDR CDR sexpr + CAR sexpr = 'Mapping => + args := [ SExprToDName(sx, 'T) for sx in CDR sexpr] + [DNameApplyID, + [DNameStringID,: StringToCompStr '"->"], + [DNameTupleID, : CDR args], + [DNameTupleID, CAR args]] + name0 := [DNameStringID, : StringToCompStr SYMBOL_-NAME CAR sexpr] + CAR sexpr = 'Union or CAR sexpr = 'Record => + [DNameApplyID, name0, + [DNameTupleID,: [ SExprToDName(sx, 'T) for sx in CDR sexpr]]] + newCosig := CDR GETDATABASE(CAR sexpr, QUOTE COSIG) + [DNameApplyID, name0, + : MAPCAR(function SExprToDName, CDR sexpr, newCosig)] + +-- local garbage because Compiler strings are null terminated +StringToCompStr(str) == + CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0)) + +CompStrToString(str) == + SUBSTRING(str, 0, (LENGTH str - 1)) +-- local garbage ends + +runOldAxiomFunctor(:allArgs) == + [:args,env] := allArgs + GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => + [$oldAxiomPreCategoryDispatch,: [env, :args]] + dom:=APPLY(env, args) + makeOldAxiomDispatchDomain dom + +makeLazyOldAxiomDispatchDomain domform == + attribute? domform => + [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)] + GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => + [$oldAxiomPreCategoryDispatch,: domform] + dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] + NCONC(dd,dd) -- installs back pointer to head of domain. + dd + +makeOldAxiomDispatchDomain dom == + PAIRP dom => dom + [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] + +closeOldAxiomFunctor(name) == + [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name] + +lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == + dom := instantiate domenv + SPADCALL(CDR dom, self, op, sig, box, skipdefaults, CAR(dom).3) + +lazyOldAxiomDomainHashCode(domenv, env) == CAR domenv + +lazyOldAxiomDomainDevaluate(domenv, env) == + dom := instantiate domenv + SPADCALL(CDR dom, CAR(dom).1) + +lazyOldAxiomAddChild(domenv, kid, env) == + CONS($lazyOldAxiomDomainDispatch,domenv) + +$lazyOldAxiomDomainDispatch := + VECTOR('lazyOldAxiomDomain, + [function lazyOldAxiomDomainDevaluate], + [nil], + [function lazyOldAxiomDomainLookupExport], + [function lazyOldAxiomDomainHashCode], + [function lazyOldAxiomAddChild]) + +-- old Axiom pre category objects are just (dispatch . catform) +-- where catform is ('categoryname,: evaluated args) +-- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom]) +oldAxiomPreCategoryBuild(catform, dom, env) == + pack := oldAxiomCategoryDefaultPackage(catform, dom) + CONS($oldAxiomCategoryDispatch, + [catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]) +oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0) +oldAxiomCategoryDefaultPackage(catform, dom) == + hasDefaultPackage opOf catform + +oldAxiomPreCategoryDevaluate([op,:args], env) == + SExprToDName([op,:devaluateList args], T) + +$oldAxiomPreCategoryDispatch := + VECTOR('oldAxiomPreCategory, + [function oldAxiomPreCategoryDevaluate], + [nil], + [nil], + [function oldAxiomPreCategoryHashCode], + [function oldAxiomPreCategoryBuild], + [nil]) + +oldAxiomCategoryDevaluate([[op,:args],:.], env) == + SExprToDName([op,:devaluateList args], T) + +oldAxiomPreCategoryParents(catform,dom) == + vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)] + vals := [dom,:rest catform] + -- parents := GETDATABASE(opOf catform, 'PARENTS) + parents := parentsOf opOf catform + PROGV(vars, vals, + LIST2VEC + [EVAL quoteCatOp cat for [cat,:pred] in parents | EVAL pred]) + +quoteCatOp cat == + atom cat => MKQ cat + ['LIST, MKQ CAR cat,: CDR cat] + + +oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == + [catform,hash, pack,:.] := catenv + opIsHasCat op => if EQL(sig, hash) then [self] else nil + NULL(pack) => nil + if not VECP pack then + pack:=apply(pack, CONS(self, rest catform)) + RPLACA(CDDR catenv, pack) + fun := basicLookup(op, sig, pack, self) => [fun] + nil + +oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents +oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == + catform := ELT(parvec, n-1) + VECTORP KAR catform => catform + newcat := oldAxiomPreCategoryBuild(catform,dom,nil) + SETELT(parvec, n-1, newcat) + newcat + +oldAxiomCategoryBuild([catform,:.], dom, env) == + oldAxiomPreCategoryBuild(catform,dom, env) +oldAxiomCategoryHashCode([.,hash,:.], env) == hash + +$oldAxiomCategoryDispatch := + VECTOR('oldAxiomCategory, + [function oldAxiomCategoryDevaluate], + [nil], + [function oldAxiomCategoryLookupExport], + [function oldAxiomCategoryHashCode], + [function oldAxiomCategoryBuild], -- builder ?? + [function oldAxiomCategoryParentCount], + [function oldAxiomCategoryNthParent]) -- 1 indexed + +attributeDevaluate(attrObj, env) == + [name, hash] := attrObj + StringToCompStr SYMBOL_-NAME name + +attributeLookupExport(attrObj, self, op, sig, box, env) == + [name, hash] := attrObj + opIsHasCat op => if EQL(hash, sig) then [self] else nil + +attributeHashCode(attrObj, env) == + [name, hash] := attrObj + hash + +attributeCategoryBuild(attrObj, dom, env) == + [name, hash] := attrObj + [$attributeDispatch, name, hash] + +attributeCategoryParentCount(attrObj, env) == 0 + +attributeNthParent(attrObj, env) == nil + +$attributeDispatch := + VECTOR('attribute, + [function attributeDevaluate], + [nil], + [function attributeLookupExport], + [function attributeHashCode], + [function attributeCategoryBuild], -- builder ?? + [function attributeCategoryParentCount], + [function attributeNthParent]) -- 1 indexed + + +orderedDefaults(conform,domform) == + $depthAssocCache : local := MAKE_-HASHTABLE 'ID + conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op] + acc := nil + ancestors := ancestorsOf(conform,domform) + for x in conList repeat + for y in ancestors | x = CAAR y repeat acc := [y,:acc] + NREVERSE acc + +instantiate domenv == + -- following is a patch for a bug in runtime.as + -- has a lazy dispatch vector with an instantiated domenv + VECTORP CDR domenv => [$oldAxiomDomainDispatch ,: domenv] + callForm := CADR domenv + oldDom := CDDR domenv + [functor,:args] := callForm +-- if null(fn := GETL(functor,'instantiate)) then +-- ofn := SYMBOL_-FUNCTION functor +-- loadFunctor functor +-- fn := SYMBOL_-FUNCTION functor +-- SETF(SYMBOL_-FUNCTION functor, ofn) +-- PUT(functor, 'instantiate, fn) +-- domvec := APPLY(fn, args) + domvec := APPLY(functor, args) + RPLACA(oldDom, $oldAxiomDomainDispatch) + RPLACD(oldDom, [CADR oldDom,: domvec]) + oldDom + +hashTypeForm([fn,: args], percentHash) == + hashType([fn,:devaluateList args], percentHash) + +--------------------> NEW DEFINITION (override in i-util.boot.pamphlet) +devaluate(d) == + isDomain d => + -- ?need a shortcut for old domains + -- ELT(CAR d, 0) = 'oldAxiomDomain => ... + -- FIXP(ELT(CAR d,0)) => d + DNameToSExpr(SPADCALL(CDR d,CAR(d).1)) + not REFVECP d => d + QSGREATERP(QVSIZE d,5) and QREFELT(d,3) is ['Category] => QREFELT(d,0) + QSGREATERP(QVSIZE d,0) => + d':=QREFELT(d,0) + isFunctor d' => d' + d + d + +$hashOp1 := hashString '"1" +$hashOp0 := hashString '"0" +$hashOpApply := hashString '"apply" +$hashOpSet := hashString '"set!" +$hashSeg := hashString '".." +$hashPercent := hashString '"%" + +oldAxiomDomainLookupExport _ + (domenv, self, op, sig, box, skipdefaults, env) == + domainVec := CDR domenv + if hashCode? op then + EQL(op, $hashOp1) => op := 'One + EQL(op, $hashOp0) => op := 'Zero + EQL(op, $hashOpApply) => op := 'elt + EQL(op, $hashOpSet) => op := 'setelt + EQL(op, $hashSeg) => op := 'SEGMENT + constant := nil + if hashCode? sig and self and EQL(sig, getDomainHash self) then + sig := '($) + constant := true + val := + skipdefaults => + oldCompLookupNoDefaults(op, sig, domainVec, self) + oldCompLookup(op, sig, domainVec, self) + null val => val + if constant then val := SPADCALL val + RPLACA(box, val) + box + +oldAxiomDomainHashCode(domenv, env) == CAR domenv + +oldAxiomDomainHasCategory(domenv, cat, env) == + HasAttribute(domvec := CDR domenv, cat) or + HasCategory(domvec, devaluate cat) + +oldAxiomDomainDevaluate(domenv, env) == + SExprToDName(CDR(domenv).0, 'T) + +oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv) + +$oldAxiomDomainDispatch := + VECTOR('oldAxiomDomain, + [function oldAxiomDomainDevaluate], + [nil], + [function oldAxiomDomainLookupExport], + [function oldAxiomDomainHashCode], + [function oldAxiomAddChild]) + +--------------------> NEW DEFINITION (see g-util.boot.pamphlet) +isDomain a == + PAIRP a and VECP(CAR a) and + member(CAR(a).0, $domainTypeTokens) + +-- following is interpreter interfact to function lookup +-- perhaps it should always work with hashcodes for signature? +--------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) +NRTcompiledLookup(op,sig,dom) == + if CONTAINED('_#,sig) then + sig := [NRTtypeHack t for t in sig] + hashCode? sig => compiledLookupCheck(op,sig,dom) + (fn := compiledLookup(op,sig,dom)) => fn + percentHash := + VECP dom => hashType(dom.0, 0) + getDomainHash dom + compiledLookupCheck(op, hashType(['Mapping,:sig], percentHash), dom) + +--------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) +compiledLookup(op, sig, dollar) == + if not isDomain dollar then dollar := NRTevalDomain dollar + basicLookup(op, sig, dollar, dollar) + +--------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) +basicLookup(op,sig,domain,dollar) == + -- following case is for old domains like Record and Union + -- or for getting operations out of yourself + VECP domain => + isNewWorldDomain domain => -- getting ops from yourself (or for defaults) + oldCompLookup(op, sig, domain, dollar) + -- getting ops from Record or Union + lookupInDomainVector(op,sig,domain,dollar) + hashPercent := + VECP dollar => hashType(dollar.0,0) + hashType(dollar,0) + box := [nil] + not VECP(dispatch := CAR domain) => error "bad domain format" + lookupFun := dispatch.3 + dispatch.0 = 0 => -- new compiler domain object + hashSig := + hashCode? sig => sig + opIsHasCat op => hashType(sig, hashPercent) + hashType(['Mapping,:sig], hashPercent) + + if SYMBOLP op then + op = 'Zero => op := $hashOp0 + op = 'One => op := $hashOp1 + op = 'elt => op := $hashOpApply + op = 'setelt => op := $hashOpSet + op := hashString SYMBOL_-NAME op + val:=CAR SPADCALL(CDR domain, dollar, op, hashSig, box, false, + lookupFun) => val + hashCode? sig => nil + #sig>1 or opIsHasCat op => nil + boxval := SPADCALL(CDR dollar, dollar, op, hashType(first sig, hashPercent), + box, false, lookupFun) => + [FUNCTION IDENTITY,: CAR boxval] + nil + opIsHasCat op => + HasCategory(domain, sig) + if hashCode? op then + EQL(op, $hashOp1) => op := 'One + EQL(op, $hashOp0) => op := 'Zero + EQL(op, $hashOpApply) => op := 'elt + EQL(op, $hashOpSet) => op := 'setelt + EQL(op, $hashSeg) => op := 'SEGMENT + hashCode? sig and EQL(sig, hashPercent) => + SPADCALL CAR SPADCALL(CDR dollar, dollar, op, '($), box, false, lookupFun) + CAR SPADCALL(CDR dollar, dollar, op, sig, box, false, lookupFun) + +basicLookupCheckDefaults(op,sig,domain,dollar) == + box := [nil] + not VECP(dispatch := CAR dollar) => error "bad domain format" + lookupFun := dispatch.3 + dispatch.0 = 0 => -- new compiler domain object + hashPercent := + VECP dollar => hashType(dollar.0,0) + hashType(dollar,0) + + hashSig := + hashCode? sig => sig + hashType( ['Mapping,:sig], hashPercent) + + if SYMBOLP op then op := hashString SYMBOL_-NAME op + CAR SPADCALL(CDR dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun) + CAR SPADCALL(CDR dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun) + +$hasCatOpHash := hashString '"%%" +opIsHasCat op == + hashCode? op => EQL(op, $hasCatOpHash) + EQ(op, "%%") + +-- has cat questions lookup up twice if false +-- replace with following ? +-- not(opIsHasCat op) and +-- (u := lookupInDomainVector(op,sig,domvec,domvec)) => u + +oldCompLookup(op, sig, domvec, dollar) == + $lookupDefaults:local := nil + u := lookupInDomainVector(op,sig,domvec,dollar) => u + $lookupDefaults := true + lookupInDomainVector(op,sig,domvec,dollar) + +oldCompLookupNoDefaults(op, sig, domvec, dollar) == + $lookupDefaults:local := nil + lookupInDomainVector(op,sig,domvec,dollar) + +--------------------> NEW DEFINITION (override in nrungo.boot.pamphlet) +lookupInDomainVector(op,sig,domain,dollar) == + PAIRP domain => basicLookupCheckDefaults(op,sig,domain,domain) + slot1 := domain.1 + SPADCALL(op,sig,dollar,slot1) + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lookupComplete(op,sig,dollar,env) == + hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,nil) + newLookupInTable(op,sig,dollar,env,nil) + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lookupIncomplete(op,sig,dollar,env) == + hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) + newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lookupInCompactTable(op,sig,dollar,env) == + hashCode? sig => hashNewLookupInTable(op,sig,dollar,env,true) + newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lazyMatchArg2(s,a,dollar,domain,typeFlag) == + if s = '$ then +-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup + s := devaluate dollar -- calls from HasCategory can have $s + INTEGERP a => + not typeFlag => s = domain.a + a = 6 and $isDefaultingPackage => s = devaluate dollar + VECP (d := domainVal(dollar,domain,a)) => + s = d.0 => true + domainArg := ($isDefaultingPackage => domain.6.0; domain.0) + KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + isDomain d => + dhash:=getDomainHash d + dhash = + (if hashCode? s then s else hashType(s, dhash)) +-- s = devaluate d + lazyMatch(s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + a = "$$" => s = devaluate domain + STRINGP a => + STRINGP s => a = s + s is ['QUOTE,y] and PNAME y = a + IDENTP s and PNAME s = a + atom a => a = s + op := opOf a + op = 'NRTEVAL => s = nrtEval(CADR a,domain) + op = 'QUOTE => s = CADR a + lazyMatch(s,a,dollar,domain) + --above line is temporarily necessary until system is compiled 8/15/90 +--s = a + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +getOpCode(op,vec,max) == +--search Op vector for "op" returning code if found, nil otherwise + res := nil + hashCode? op => + for i in 0..max by 2 repeat + EQL(hashString PNAME QVELT(vec,i),op) => return (res := QSADD1 i) + res + for i in 0..max by 2 repeat + EQ(QVELT(vec,i),op) => return (res := QSADD1 i) + res + +hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == + opIsHasCat op => + HasCategory(domain, sig) + if hashCode? op and EQL(op, $hashOp1) then op := 'One + if hashCode? op and EQL(op, $hashOp0) then op := 'Zero + hashPercent := + VECP dollar => hashType(dollar.0,0) + hashType(dollar,0) + if hashCode? sig and EQL(sig, hashPercent) then + sig := hashType('(Mapping $), hashPercent) + dollar = nil => systemError() + $lookupDefaults = true => + hashNewLookupInCategories(op,sig,domain,dollar) --lookup first in my cats + or newLookupInAddChain(op,sig,domain,dollar) + --fast path when called from newGoGet + success := false + if $monitorNewWorld then + sayLooking(concat('"---->",form2String devaluate domain, + '"----> searching op table for:","%l"," "),op,sig,dollar) + someMatch := false + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return + flag => newLookupInAddChain(op,sig,domain,dollar) + nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := if hashCode? sig then -1 else (#sig)-1 + success := nil + $isDefaultingPackage: local := + -- use special defaulting handler when dollar non-trivial + dollar ^= domain and isDefaultPackageForm? devaluate domain + while finish > start repeat + PROGN + i := start + numTableArgs :=numvec.i + predIndex := numvec.(i := QSADD1 i) + (predIndex ^= 0) and null testBitVector(predvec,predIndex) => nil + exportSig := + [newExpandTypeSlot(numvec.(i + j + 1), + dollar,domain) for j in 0..numTableArgs] + sig ^= hashType(['Mapping,: exportSig],hashPercent) => nil --signifies no match + loc := numvec.(i + numTableArgs + 2) + loc = 1 => (someMatch := true) + loc = 0 => + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + i := start + 2 + someMatch := true --mark so that if subsumption fails, look for original + subsumptionSig := + [newExpandTypeSlot(numvec.(QSPLUS(i,j)), + dollar,domain) for j in 0..numTableArgs] + if $monitorNewWorld then + sayBrightly [formatOpSignature(op,sig),'"--?-->", + formatOpSignature(op,subsumptionSig)] + nil + slot := domain.loc + null atom slot => + EQ(QCAR slot,'newGoGet) => someMatch:=true + --treat as if operation were not there + --if EQ(QCAR slot,'newGoGet) then + -- UNWIND_-PROTECT --break infinite recursion + -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), + -- if domain.loc = 'skip then domain.loc := slot) + return (success := slot) + slot = 'skip => --recursive call from above 'replaceGoGetSlot + return (success := newLookupInAddChain(op,sig,domain,dollar)) + systemError '"unexpected format" + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + (success ^= 'failed) and success => + if $monitorNewWorld then + sayLooking1('"<----",uu) where uu() == + PAIRP success => [first success,:devaluate rest success] + success + success + subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u + flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) + nil + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + isDomain lazyt => devaluate lazyt + ATOM lazyt => lazyt + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +hashNewLookupInCategories(op,sig,dom,dollar) == + slot4 := dom.4 + catVec := CADR slot4 + SIZE catVec = 0 => nil --early exit if no categories + INTEGERP KDR catVec.0 => + newLookupInCategories1(op,sig,dom,dollar) --old style + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + packageVec := QCAR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + for i in 0..MAXINDEX packageVec | + (entry := packageVec.i) and entry ^= 'T repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := catVec.i + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + --VECP infovec => ----new world + true => ----new world + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDDR infovec.3 + endPos := + code+2 > max => SIZE byteVector + opvec.(code+2) + --not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil + --numOfArgs := byteVector.(opvec.code) + --numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + ----old world + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true then + sayBrightlyNT '" not in: " + pp (packageForm and devaluate package or entry) + nil + if $monitorNewWorld then + sayLooking1('"candidate default package instantiated: ",success) + success + entry + null package => nil + if $monitorNewWorld then + sayLooking1('"Looking at instantiated package ",package) + res := basicLookup(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +replaceGoGetSlot env == + [thisDomain,index,:op] := env + thisDomainForm := devaluate thisDomain + bytevec := getDomainByteVector thisDomain + numOfArgs := bytevec.index + goGetDomainSlotIndex := bytevec.(index := QSADD1 index) + goGetDomain := + goGetDomainSlotIndex = 0 => thisDomain + thisDomain.goGetDomainSlotIndex + if PAIRP goGetDomain and SYMBOLP CAR goGetDomain then + goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) + sig := + [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) + for i in 0..numOfArgs] + thisSlot := bytevec.(QSADD1 index) + if $monitorNewWorld then + sayLooking(concat('"%l","..",form2String thisDomainForm, + '" wants",'"%l",'" "),op,sig,goGetDomain) + slot := basicLookup(op,sig,goGetDomain,goGetDomain) + slot = nil => + $returnNowhereFromGoGet = true => + ['nowhere,:goGetDomain] --see newGetDomainOpTable + sayBrightly concat('"Function: ",formatOpSignature(op,sig), + '" is missing from domain: ",form2String goGetDomain.0) + keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) + if $monitorNewWorld then + sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) + SETELT(thisDomain,thisSlot,slot) + if $monitorNewWorld then + sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) + slot + +HasAttribute(domain,attrib) == + hashPercent := + VECP domain => hashType(domain.0,0) + hashType(domain,0) + isDomain domain => + FIXP((first domain).0) => + -- following call to hashType was missing 2nd arg. + -- getDomainHash domain added on 4/01/94 by RSS + basicLookup("%%",hashType(attrib, hashPercent),domain,domain) + HasAttribute(CDDR domain, attrib) +--> + isNewWorldDomain domain => newHasAttribute(domain,attrib) +--+ + (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain) + +newHasAttribute(domain,attrib) == + hashPercent := + VECP domain => hashType(domain.0,0) + hashType(domain,0) + predIndex := + hashCode? attrib => + -- following call to hashType was missing 2nd arg. + -- hashPercent added by PAB 15/4/94 + or/[x for x in domain.2 | attrib = hashType(first x, hashPercent)] + LASSOC(attrib,domain.2) + predIndex => + EQ(predIndex,0) => true + predvec := domain.3 + testBitVector(predvec,predIndex) + false + +newHasCategory(domain,catform) == + catform = '(Type) => true + slot4 := domain.4 + auxvec := CAR slot4 + catvec := CADR slot4 + $isDefaultingPackage: local := isDefaultPackageForm? devaluate domain + #catvec > 0 and INTEGERP KDR catvec.0 => --old style + predIndex := lazyMatchAssocV1(catform,catvec,domain) + null predIndex => false + EQ(predIndex,0) => true + predvec := QVELT(domain,3) + testBitVector(predvec,predIndex) + lazyMatchAssocV(catform,auxvec,catvec,domain) --new style + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 + n : FIXNUM := MAXINDEX catvec + -- following call to hashType was missing 2nd arg. 0 added on 3/31/94 by RSS + hashCode? x => + percentHash := + VECP domain => hashType(domain.0, 0) + getDomainHash domain + or/[ELT(auxvec,i) for i in 0..n | + x = hashType(newExpandLocalType(QVELT(catvec,i),domain,domain), percentHash)] + xop := CAR x + or/[ELT(auxvec,i) for i in 0..n | + --xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] + xop = CAR (lazyt := getCatForm(catvec,i,domain)) and lazyMatch(x,lazyt,domain,domain)] + +getCatForm(catvec, index, domain) == + NUMBERP(form := QVELT(catvec,index)) => domain.form + form + +has(domain,catform') == HasCategory(domain,catform') + +HasCategory(domain,catform') == + catform' is ['SIGNATURE,:f] => HasSignature(domain,f) + catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f) + isDomain domain => + FIXP((first domain).0) => + catform' := devaluate catform' + basicLookup("%%",catform',domain,domain) + HasCategory(CDDR domain, catform') + catform:= devaluate catform' + isNewWorldDomain domain => newHasCategory(domain,catform) + domain0:=domain.0 -- handles old style domains, Record, Union etc. + slot4 := domain.4 + catlist := slot4.1 + member(catform,catlist) or + MEMQ(opOf(catform),'(Object Type)) or --temporary hack + or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist] + +--systemDependentMkAutoload(fn,cnam) == +-- FBOUNDP(cnam) => "next" +-- SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +--------------------> NEW DEFINITION (override in nrunfast.boot.pamphlet) +lazyDomainSet(lazyForm,thisDomain,slot) == + form := + --lazyForm is [vec,.,:u] and VECP vec => u --old style + lazyForm --new style + slotDomain := evalSlotDomain(form,thisDomain) + if $monitorNewWorld then + sayLooking1(concat(form2String devaluate thisDomain, + '" activating lazy slot ",slot,'": "),slotDomain) +-- name := CAR form +--getInfovec name + SETELT(thisDomain,slot,slotDomain) + + +--------------------> NEW DEFINITION (override in template.boot.pamphlet) +evalSlotDomain(u,dollar) == + $returnNowhereFromGoGet: local := false + $ : fluid := dollar + $lookupDefaults : local := nil -- new world + isDomain u => u + u = '$ => dollar + u = "$$" => dollar + FIXP u => + VECP (y := dollar.u) => y + isDomain y => y + y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? + y is [v,:.] => + VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] + constructor? v or MEMQ(v,'(Record Union Mapping)) => + lazyDomainSet(y,dollar,u) --new style has lazyt + y + y + u is ['NRTEVAL,y] => + y is ['ELT,:.] => evalSlotDomain(y,dollar) + eval y + u is ['QUOTE,y] => y + u is ['Record,:argl] => + FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is ['Union,:argl] and first argl is ['_:,.,.] => + APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is ['spadConstant,d,n] => + dom := evalSlotDomain(d,dollar) + SPADCALL(dom . n) + u is ['ELT,d,n] => + dom := evalSlotDomain(d,dollar) + slot := dom . n + slot is ['newGoGet,:env] => replaceGoGetSlot env + slot + u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) + systemErrorHere '"evalSlotDomain" + +--------------------> NEW DEFINITION (override in i-util.boot.pamphlet) +domainEqual(a,b) == + devaluate(a) = devaluate(b) + +--makeConstructorsAutoLoad() + +-- following changes should go back into xrun.boot +-- patched version from xrun.boot +--------------------> NEW DEFINITION (override in clammed.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +coerceConvertMmSelection(funName,m1,m2) == + -- calls selectMms with $Coerce=NIL and tests for required + -- target type. funName is either 'coerce or 'convert. + $declaredMode : local:= NIL + $reportBottomUpFlag : local:= NIL + l := selectMms1(funName,m2,[m1],[m1],NIL) +-- mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and + mmS := [x for x in l | x is [sig,:.] and hasCorrectTarget(m2,sig) and + sig is [dc,targ,oarg] and isEqualOrSubDomain(m1,oarg)] + mmS and CAR mmS + +--------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) +getFunctionFromDomain(op,dc,args) == + -- finds the function op with argument types args in dc + -- complains, if no function or ambiguous + $reportBottomUpFlag:local:= NIL + member(CAR dc,$nonLisplibDomains) => + throwKeyedMsg("S2IF0002",[CAR dc]) + not constructor? CAR dc => + throwKeyedMsg("S2IF0003",[CAR dc]) + p:= findFunctionInDomain(op,dc,NIL,args,args,NIL,NIL) => +--+ + --sig := [NIL,:args] + domain := evalDomain dc + for mm in nreverse p until b repeat + [[.,:osig],nsig,:.] := mm + b := compiledLookup(op,nsig,domain) + b or throwKeyedMsg("S2IS0023",[op,dc]) + throwKeyedMsg("S2IF0004",[op,dc]) + +@ + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/interp-fix.boot b/src/interp/interp-fix.boot deleted file mode 100644 index d21bfd1b..00000000 --- a/src/interp/interp-fix.boot +++ /dev/null @@ -1,77 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- From newfort.boot: - -checkPrecision e == - -- Do we have a string? - CHAR_-CODE(CHAR(e,0)) = 34 => e - e := delete(char " ",STRINGIMAGE e) - $fortranPrecision = "double" => - iPart := SUBSEQ(e,0,(period:=POSITION(char ".",e))+1) - expt := if ePos := POSITION(char "E",e) then SUBSEQ(e,ePos+1) else "0" - rPart := - ePos => SUBSEQ(e,period+1,ePos) - period+1 < LENGTH e => SUBSEQ(e,period+1) - "0" - STRCONC(iPart,rPart,"D",expt) - e - --- From i-eval.boot - -evaluateType1 form == - --evaluates the arguments passed to a constructor - [op,:argl]:= form - constructor? op => - null (sig := getConstructorSignature form) => - throwEvalTypeMsg("S2IE0005",[form]) - [.,:ml] := sig - ml := replaceSharps(ml,form) - # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) - for x in argl for m in ml for argnum in 1.. repeat - typeList := [v,:typeList] where v == - categoryForm?(m) => - m := evaluateType MSUBSTQ(x,'_$,m) - evalCategory(x' := (evaluateType x), m) => x' - throwEvalTypeMsg("S2IE0004",[form]) - - m := evaluateType m - GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and - (tree := mkAtree x) and putTarget(tree,m) and - ((bottomUp tree) is [m1]) and - (v:= coerceInteractive(getAndEvalConstructorArgument tree,m)) - => objValUnwrap v - if x = $EmptyMode then x := $quadSymbol - throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) - [op,:NREVERSE typeList] - throwEvalTypeMsg("S2IE0007",[op]) - diff --git a/src/interp/interp-fix.boot.pamphlet b/src/interp/interp-fix.boot.pamphlet new file mode 100644 index 00000000..c0edc418 --- /dev/null +++ b/src/interp/interp-fix.boot.pamphlet @@ -0,0 +1,99 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp interp-fix.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- From newfort.boot: + +checkPrecision e == + -- Do we have a string? + CHAR_-CODE(CHAR(e,0)) = 34 => e + e := delete(char " ",STRINGIMAGE e) + $fortranPrecision = "double" => + iPart := SUBSEQ(e,0,(period:=POSITION(char ".",e))+1) + expt := if ePos := POSITION(char "E",e) then SUBSEQ(e,ePos+1) else "0" + rPart := + ePos => SUBSEQ(e,period+1,ePos) + period+1 < LENGTH e => SUBSEQ(e,period+1) + "0" + STRCONC(iPart,rPart,"D",expt) + e + +-- From i-eval.boot + +evaluateType1 form == + --evaluates the arguments passed to a constructor + [op,:argl]:= form + constructor? op => + null (sig := getConstructorSignature form) => + throwEvalTypeMsg("S2IE0005",[form]) + [.,:ml] := sig + ml := replaceSharps(ml,form) + # argl ^= #ml => throwEvalTypeMsg("S2IE0003",[form,form]) + for x in argl for m in ml for argnum in 1.. repeat + typeList := [v,:typeList] where v == + categoryForm?(m) => + m := evaluateType MSUBSTQ(x,'_$,m) + evalCategory(x' := (evaluateType x), m) => x' + throwEvalTypeMsg("S2IE0004",[form]) + + m := evaluateType m + GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'domain and + (tree := mkAtree x) and putTarget(tree,m) and + ((bottomUp tree) is [m1]) and + (v:= coerceInteractive(getAndEvalConstructorArgument tree,m)) + => objValUnwrap v + if x = $EmptyMode then x := $quadSymbol + throwEvalTypeMsg("S2IE0006",[makeOrdinal argnum,m,form]) + [op,:NREVERSE typeList] + throwEvalTypeMsg("S2IE0007",[op]) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/interp-proclaims.lisp b/src/interp/interp-proclaims.lisp new file mode 100644 index 00000000..30d61fc7 --- /dev/null +++ b/src/interp/interp-proclaims.lisp @@ -0,0 +1,3391 @@ + +(IN-PACKAGE "USER") +(PROCLAIM '(FTYPE (FUNCTION (*) (VALUES T T)) BOOT:|ReadLine|)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FUNCTION) FOAM::FOAMPROGINFOSTRUCT-FUNCALL)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FIXNUM) BOOT::LINE-NUMBER BOOT::|eq0| + VMLISP:CHAR2NUM BOOT::|nothingWidth| BOOT::|nothingSub| + BOOT::|nothingSuper| BOOT::LINE-LAST-INDEX + BOOT::LINE-CURRENT-INDEX FOAM:|ProgHashCode| + FOAM:|strLength| BOOT:|StringLength| BOOT::|widthSC|)) +(PROCLAIM + '(FTYPE (FUNCTION (T) FOAM:|SInt|) + FOAM::FOAMPROGINFOSTRUCT-HASHVAL)) +(PROCLAIM + '(FTYPE (FUNCTION (T) (VALUES T T)) BOOT::|mkSharpVar| + BOOT::|makeCharacter| BOOT::|mapCatchName| + BOOT::|queryUser| BOOT:|LispKeyword| BOOT::MONITOR-INFO + BOOT::FILE-GETTER-NAME BOOT::|mkDomainCatName| + FOAM:AXIOMXL-FILE-INIT-NAME BOOT::|getKeyedMsg| + BOOT::|mkCacheName| BOOT::|mkAuxiliaryName|)) +(PROCLAIM + '(FTYPE (FUNCTION ((VECTOR T) (VECTOR T)) T) VMLISP::VGREATERP + VMLISP::LEXVGREATERP)) +(PROCLAIM '(FTYPE (FUNCTION ((VECTOR T)) T) BOOT:TRIMLZ)) +(PROCLAIM + '(FTYPE (FUNCTION (T) (*)) BOOT:|StringToInteger| + BOOT:|StringToFloat|)) +(PROCLAIM '(FTYPE (FUNCTION (T *) (VALUES T T)) VMLISP:|read-line|)) +(PROCLAIM '(FTYPE (FUNCTION (STRING FIXNUM) T) BOOT::|subWord|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) FIXNUM) VMLISP:QSQUOTIENT + VMLISP:QSREMAINDER VMLISP:QENUM FOAM:|SetProgHashCode| + BOOT:GETCHARN BOOT::|attributeCategoryParentCount|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) (VALUES T T)) BOOT::|htMakeLabel| + BOOT::|fetchKeyedMsg|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) *) BOOT::|applpar1| BOOT::|apprpar1| + BOOT::|appargs1| BOOT::|appagg1| BOOT::|matrixBorder| + BOOT::|e02befDefaultSolve| BOOT::|e02agfDefaultSolve| + BOOT::|e02dafDefaultSolve| BOOT::|htQueryPage| + BOOT::|compileAndLink| BOOT::|f04jgfDefaultSolve| + BOOT::|f02aefDefaultSolve| BOOT::|f02agfDefaultSolve| + BOOT::|apphor| BOOT::|appvertline| BOOT::|applpar| + BOOT::|e04jafDefaultSolve| BOOT::|f01brfDefaultSolve| + BOOT::|e04ycfDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) *) VMLISP:CONCAT + BOOT::LOCALDATABASE BOOT::FE BOOT::|ncBug|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) *) BOOT::|replacePercentByDollar,fn| + BOOT::|getSlotFromDomain| BOOT::|ncGetFunction| + BOOT::|c02affDefaultSolve| BOOT::|c02agfDefaultSolve| + BOOT::|Qf2F| BOOT::|selectOptionLC| BOOT::|compUniquely| + BOOT::|compExpression| BOOT::|e02gafDefaultSolve| + BOOT::|e02aefDefaultSolve| BOOT::|e02bbfDefaultSolve| + BOOT::|asytranForm| BOOT::|asytranFormSpecial| + BOOT::|asytranApplySpecial| BOOT::SOCK-GET-STRING + BOOT::|sockGetString| BOOT::|showIt| BOOT::|pmPreparse,fn| + BOOT::|pmPreparse,gn| BOOT::|dbSearchAbbrev| + BOOT::|mkUpDownPattern,recurse| BOOT::|htMkPath| + BOOT::|getVal| BOOT::|htGlossPage| BOOT::|checkCondition| + BOOT::|compTopLevel| BOOT::GETOP + BOOT::|checkTransformFirsts| BOOT::|parseIf,ifTran| + BOOT::|dbShowOpAllDomains| BOOT::|templateVal| + BOOT::|dbChooseDomainOp| BOOT::|whoUsesOperation| + BOOT::|c05pbfDefaultSolve| BOOT::|c05nbfDefaultSolve| + BOOT::|c06frfDefaultSolve| BOOT::|c06ekfDefaultSolve| + BOOT::|NRTvectorCopy| BOOT::|c06fufDefaultSolve| + BOOT::|c06fpfDefaultSolve| BOOT::|c06fqfDefaultSolve| + BOOT::|applyInPackage| BOOT::|exp2FortSpecial| + BOOT::|f04mcfDefaultSolve| BOOT::|f04atfDefaultSolve| + BOOT::|f04fafDefaultSolve| BOOT::|f02affDefaultSolve| + BOOT::|dbShowCons1| BOOT::|f02aafDefaultSolve| + BOOT::|dbSelectCon| BOOT::|dbShowOperationsFromConform| + BOOT::|genSearch1| BOOT::|dbSearch| + BOOT::|constructorSearch| BOOT::|underscoreDollars,fn| + BOOT::|oSearchGrep| BOOT::|selectOption| + BOOT::|constructorSearchGrep| BOOT::|dbInfoChoose1| + BOOT::|bcDrawIt2| BOOT::|charybdis| BOOT::|bcMkFunction| + BOOT::|charyTop| BOOT::|bcDrawIt| + BOOT::|f01qcfDefaultSolve| BOOT::|e02zafDefaultSolve| + BOOT::|ncloopInclude0| VMLISP:$FCOPY)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) *) BOOT::|e02befColdSolve| + BOOT::|e02ahfDefaultSolve| BOOT::|e02akfDefaultSolve| + BOOT::|d02bbfDefaultSolve| BOOT::|d02cjfDefaultSolve| + BOOT::|e01sefDefaultSolve| BOOT::|htSetLiterals| + BOOT::|f04mbfDefaultSolve| BOOT::|f02axfDefaultSolve| + BOOT::|f02akfDefaultSolve| BOOT::|kcaPage1| + BOOT::MAKE-DEPSYS BOOT::|makeLongStatStringByProperty| + BOOT::|f01rdfDefaultSolve| BOOT::|f01qdfDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) *) BOOT::|compileConstructorLib| + BOOT::|quoteApp| BOOT::|argsapp| BOOT::|appargs| + BOOT::|inApp| BOOT::|appsc| BOOT::|appfrac| BOOT::|exptApp| + BOOT::|charyTrouble| BOOT::|overbarApp| + BOOT::|appHorizLine| BOOT::|overlabelApp| BOOT::/D-1 + BOOT::|appmat| BOOT::|e01bhfDefaultSolve| + BOOT::|e02adfDefaultSolve| BOOT::|e02bcfDefaultSolve| + BOOT::|makeStream| BOOT::|newExpandLocalTypeArgs| + FOAM:|fputss| FOAM:|fgetss| BOOT::|f01mafDefaultSolve| + BOOT::|conform2StringList| BOOT::|f02abfDefaultSolve| + BOOT::|f02awfDefaultSolve| BOOT::|f02ajfDefaultSolve| + BOOT::|f02adfDefaultSolve| BOOT::|patternCheck,mknew| + BOOT::|kDomainName| BOOT::|koPageAux| BOOT::|dbShowOp1| + BOOT::APP BOOT::|appagg| BOOT::|binomialApp| + BOOT::|charyTrouble1| BOOT::|appsub| BOOT::|slashApp| + BOOT::|appsetq| BOOT::|makeStatString| + BOOT::|e02dffDefaultSolve| BOOT::|e04dgfDefaultSolve| + BOOT::|e04fdfDefaultSolve| BOOT::|e04gcfDefaultSolve| + BOOT::|f01refDefaultSolve| BOOT::|f01qefDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T) *) BOOT::|makeFortranFun| + BOOT::|d03eefDefaultSolve| BOOT::|e04nafDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) *) BOOT::|e02ajfDefaultSolve| + BOOT::|e02dcfDefaultSolve| BOOT::|e02ddfDefaultSolve| + BOOT::|d02ejfDefaultSolve| BOOT::|d02bhfDefaultSolve| + BOOT::|d01fcfDefaultSolve| BOOT::|d01gbfDefaultSolve| + BOOT::|f04qafDefaultSolve| BOOT::|f02bjfDefaultSolve| + BOOT::|f02bbfDefaultSolve| BOOT::|e04mbfDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T T T T T) *) + BOOT::BUILD-INTERPSYS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) *) BOOT::|e02ddfColdSolve| + BOOT::|f02xefDefaultSolve| BOOT::|f02wefDefaultSolve| + BOOT::BUILD-DEPSYS)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T) *) BOOT::|e04ucfDefaultSolve| + BOOT::|e02dcfColdSolve| BOOT::|d02kefDefaultSolve| + BOOT::|d02gbfDefaultSolve| BOOT::|d02gafDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T T T T) *) + BOOT::|d02rafDefaultSolve|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) T) BOOT::|mapRecurDepth| BOOT::THETACHECK + BOOT::|flowSegmentedMsg| BOOT::|rewriteMap0| + BOOT::|restoreDependentMapInfo| BOOT::|dcSig| + BOOT::|analyzeNonRecur| BOOT::|addMap| BOOT::|fortCall| + BOOT::|axAddLiteral| BOOT::|writeStringLengths| + BOOT::|writeXDR| BOOT::|deleteMap| BOOT::|fnameNew| + BOOT::|axFormatDefaultOpSig| BOOT::|htpSetProperty| + BOOT::|rewriteMap1| BOOT::|displayMap| + BOOT::|compileDeclaredMap| BOOT::|compileCoerceMap| + BOOT::|displaySingleRule| BOOT::|hasAtt| BOOT::|hasAttSig| + BOOT::SPADRWRITE0 BOOT::SPADRWRITE BOOT::|recordNewValue| + BOOT::|recordOldValue| BOOT::|orderUnionEntries,split| + BOOT::|getSlotNumberFromOperationAlist| + BOOT::|isSuperDomain| BOOT::|recordOldValue0| + BOOT::|PARSE-getSemanticForm| BOOT::|recordNewValue0| + BOOT::|getSlotFromFunctor| BOOT::|addConstructorModemaps| + BOOT::|compDefWhereClause| BOOT::|get1| BOOT::|get2| + BOOT::|get0| BOOT::|throwListOfKeyedMsgs| + BOOT::|getConstructorOpsAndAtts| + BOOT::|mkExplicitCategoryFunction| + BOOT::|findDomainSlotNumber| BOOT::|addIntSymTabBinding| + BOOT::|sigsMatch| BOOT::|compDefineAddSignature| + BOOT::|hasFullSignature| BOOT:ELEMN BOOT::|mkAtree2| + BOOT::|mkAtree3| BOOT::|getValueFromSpecificEnvironment| + BOOT::|compForMode| BOOT::|transferPropsToNode,transfer| + BOOT::|genDomainOps| BOOT::|getOperationAlist| + BOOT::|remprop| BOOT::|setMsgForcedAttr| BOOT::|P2Uts| + BOOT::|Up2FR| BOOT::|mac0Define| BOOT::|getMappingArgValue| + BOOT::|compContained| BOOT::|getArgValueComp| + BOOT::|altTypeOf| BOOT::|mac0InfiniteExpansion| + BOOT::|setMsgUnforcedAttr| BOOT::|genDomainViewList| + BOOT::|compSubDomain| BOOT::|compCapsule| + BOOT::|sideEffectedArg?| BOOT::|evalFormMkValue| + BOOT::|doItIf| BOOT::|compSingleCapsuleItem| + BOOT::|compJoin| BOOT::|rewriteMap| + BOOT::|NRTgetLookupFunction| BOOT::|lisplibWrite| + BOOT::|getLocalMms| BOOT::|makeFunctorArgumentParameters| + BOOT::|selectMmsGen,exact?| BOOT::REDUCE-1 + BOOT::|getLocalMms,f| BOOT::|isOpInDomain| + BOOT::|compDefine| BOOT::|compCategory| + BOOT::|getTargetFromRhs| BOOT::|unifyStructVar| + BOOT::|augmentSub| BOOT::|unifyStruct| BOOT::|compAdd| + BOOT::|filterModemapsFromPackages| BOOT::|constrArg| + BOOT::|evalMmCond0| BOOT::|maprinSpecial| BOOT::|hasCaty| + BOOT::|evalMmCond| BOOT:ADDASSOC BOOT::|hasCate| + BOOT::|matchTypes| BOOT::|findUniqueOpInDomain| + BOOT::|hasSigOr| BOOT::|hasSigAnd| + BOOT::|findCommonSigInDomain| BOOT::|evalMmCat1| + BOOT::|coerceTypeArgs| BOOT::|domArg2| BOOT::|L2Tuple| + BOOT::V2M BOOT::DEF-INNER BOOT::|OV2Sy| BOOT::|Qf2EF| + BOOT::|Sy2P| BOOT::I2NNI BOOT::|Rm2L| BOOT::|Var2OtherPS| + BOOT::|Var2UpS| BOOT::OV2SE BOOT::|NDmp2domain| VMLISP:PUT + BOOT::|Var2Up| BOOT::|Expr2Mp| BOOT::|Expr2Dmp| + BOOT::|Sy2NDmp| VMLISP:DEFIOSTREAM BOOT::|Dmp2P| + BOOT::|Sy2Mp| BOOT::|Var2SUP| BOOT::|Factored2Factored| + VMLISP:EQSUBSTLIST BOOT::I2PI BOOT::|P2Expr| BOOT::|P2Up| + BOOT::|P2Dmp| BOOT::|Var2FS| BOOT::|Sy2Dmp| BOOT::B-MDEF + BOOT::|Ker2Expr| BOOT::|Sy2OV| BOOT::|Var2QF| BOOT::|Sm2V| + BOOT::M2V BOOT::|Var2P| BOOT::I2OI BOOT::P2FR + BOOT::|makeEijSquareMatrix| BOOT::|Set2L| BOOT::|Sm2Rm| + BOOT::DEF BOOT::|Var2NDmp| BOOT::|Dmp2Dmp| + BOOT::|coerceDmp2| BOOT::|rread| BOOT::I2EI BOOT::|Var2Mp| + BOOT::|compCapsuleInner| BOOT::|Mp2FR| BOOT::|Qf2domain| + BOOT::|compCapsuleItems| BOOT::|L2Set| BOOT::|Var2Gdmp| + BOOT::COMP-ILAM BOOT::COMP-SPADSLAM BOOT::|L2Sm| + BOOT::|mkCategoryPackage| BOOT::COMP-SLAM BOOT::L2M + BOOT::|compDefine1| BOOT::|Mp2Expr| BOOT::|Ker2Ker| + BOOT::|Var2Dmp| VMLISP:MSUBST BOOT::|Dmp2NDmp| + BOOT::|Sm2PolyType| BOOT::|Var2OV| + BOOT::|orderPredicateItems| BOOT::|L2Rm| BOOT::|substVars| + BOOT::|OV2poly| BOOT::|Sm2M| + BOOT::|augmentLisplibModemapsFromFunctor| BOOT::OV2P + BOOT::|needBlankForRoot| BOOT::|Rn2F| + BOOT::|getInCoreModemaps| BOOT::|Sm2L| BOOT::|splitConcat| + BOOT::|Un2E| BOOT::|SUP2Up| BOOT::OV2OV + BOOT::|insertAlist,fn| BOOT::|replaceVars| + BOOT::|compFromIf| BOOT::|Scr2Scr| BOOT::|compBoolean| + BOOT::|L2Record| BOOT::|Rm2V| VMLISP:RPLNODE + BOOT::|domain2NDmp| BOOT::|Up2Up| + BOOT::|augLisplibModemapsFromCategory| BOOT::|P2Mp| + BOOT::|compWithMappingMode,FreeList| BOOT::|orderPredTran| + BOOT::|Rm2Sm| BOOT::|Rm2M| BOOT::|Up2SUP| BOOT::|Mp2Up| + BOOT::|Mp2Dmp| BOOT::|LargeMatrixp| BOOT::DP2DP + BOOT::|Dmp2Up| BOOT::|Up2P| BOOT::|Complex2Expr| + BOOT::|seteltModemapFilter| BOOT::/MONITORX BOOT::|P2Upxs| + BOOT::|coerceTraceFunValue2E| BOOT::|Complex2FR| + BOOT::|Up2Mp| BOOT::V2L BOOT::|P2Uls| BOOT::|M2Sm| + BOOT::|coerceTraceArgs2E| BOOT::|Complex2underDomain| + BOOT::|resolveTTRed2| BOOT::|Agg2L2Agg| + BOOT::|resolveTTRed1| BOOT::|fnameMake| + BOOT::MONITOR-PRINARGS VMLISP:HREMPROP + BOOT::|eltModemapFilter| BOOT::|coerceOrCroak| + BOOT::|resolveTTEq2| BOOT::|resolveTTEq1| + BOOT::|matchUpToPatternVars| + BOOT::|getConditionalCategoryOfType| + BOOT::|getSubDomainPredicate| BOOT::|resolveTMEq2| + BOOT::|coerceIntX| BOOT::|compSymbol| + BOOT::|coerceSubDomain| BOOT::|compExpressionList| + BOOT::|NRTcompileEvalForm| BOOT::|setqMultiple,decompose| + BOOT::|permuteToOrder| BOOT::|retractUnderDomain| + BOOT::|compList| BOOT::SMALL-ENOUGH-COUNT + BOOT::|isRectangularList| BOOT::|augModemapsFromDomain1| + BOOT::|canCoerceByFunction1| + BOOT::|sayFunctionSelectionResult| BOOT::|compForm| + BOOT::|compTypeOf| BOOT::|comp3| BOOT::|coerceOrFail| + BOOT::|computeTTTranspositions,compress| BOOT::|algEqual| + BOOT::|compiledLookupCheck| VMLISP:RWRITE + BOOT::|coerceOrThrowFailure| BOOT::|NRTcompiledLookup| + BOOT::|spad2BootCoerce| BOOT::|M2Rm| BOOT::M2M + VMLISP:MACRO-INVALIDARGS BOOT::L2V BOOT::|Mp2P| + BOOT::|Mp2Mp| BOOT::|coerceDmpCoeffs| BOOT::|Expr2Complex| + BOOT::|Dmp2Expr| BOOT::|coerceFFE| BOOT::M2L VMLISP:QESET + BOOT::|V2Sm| BOOT::|isRectangularVector| BOOT::V2DP + BOOT::L2DP BOOT::|Up2Expr| BOOT::|Qf2Qf| BOOT::|NDmp2NDmp| + BOOT::|V2Rm| BOOT::|Qf2PF| BOOT::|Dmp2Mp| BOOT::|Up2Dmp| + BOOT::|Sy2Var| BOOT::|Agg2Agg| BOOT::|Expr2Up| + BOOT::|Sy2Up| VMLISP:HPUT BOOT::|pvarCondList1| + VMLISP:SUBSTRING BOOT::|interpRewriteRule| BOOT::|putAtree| + BOOT::|isEltable| BOOT::|selectMms| BOOT::|throwKeyedMsgSP| + BOOT::|pushDownTargetInfo| + BOOT::|pushDownOnArithmeticVariables| + BOOT::|keyedMsgCompFailureSP| BOOT::|intCodeGenCoerce1| + BOOT::|throwKeyedMsgCannotCoerceWithValue| + BOOT::|asytranForm1| BOOT::|hput| BOOT::|asyCattranOp1| + BOOT::|asyMakeOperationAlist| BOOT::|setVector4| + BOOT::|SetDomainSlots124| BOOT::|asGetExports| + BOOT::|asySig1| BOOT::|ncPutQ| + BOOT::|putConstructorProperty| BOOT::|throwKeyedErrorMsg| + BOOT::|mkUserConstructorAbbreviation| + BOOT::|unabbrevSpecialForms| BOOT::|nAssocQ| + BOOT::|New,ENTRY,2| BOOT::READ-INPUT BOOT::READ-SPAD + BOOT::|errorSupervisor1| BOOT::|argumentDataError| + BOOT::|BesselasymptA| BOOT::|htpSetLabelSpadValue| + BOOT::|optPackageCall| BOOT::|from?| BOOT::|clngamma| + BOOT::|chebevalarr| BOOT::|PsiBack| BOOT::|logH| + BOOT::|PiMinusLogSinPi| BOOT::|besselIcheb| + BOOT::|chebstarevalarr| BOOT::|chebf01coefmake| + BOOT::|clngammacase23| BOOT::|PsiAsymptoticOrder| + BOOT::|grepf| BOOT::|clngammacase1| BOOT::|cotdiffeval| + BOOT::|BesselIAsympt| BOOT::|lffloat| + BOOT::|substringMatch| BOOT::|makeResultRecord| + BOOT::|makeCompilation| BOOT::|extractFileNameFromPath,fn| + BOOT::|makeAspGenerators| BOOT::|makeAspGenerators1| + BOOT::|mkNewUnionFunList| BOOT::|EnumEqual| + BOOT::|cleanUpAfterNagman| BOOT::|sySpecificErrorAtToken| + BOOT::|prepareResults,defaultValue| + BOOT::|setVector4Onecat| BOOT::|pfLambda| BOOT::|pfWIf| + BOOT::|SigSlotsMatch| BOOT::|DomainPrint1| + BOOT::|DescendCodeAdd1,update| BOOT::|CheckVector| + BOOT::|pfTLambda| BOOT::|htSystemVariables,fn| + BOOT::|postCollect,finish| VMLISP:|nsubst| + BOOT::|npBackTrack| BOOT::|bchtMakeButton| + BOOT::|compWhere| BOOT::|compVector| BOOT::|compAtom| + BOOT::|getUniqueModemap| BOOT::|modeIsAggregateOf| + BOOT::|compArgumentsAndTryAgain| VMLISP:MACRO-MISSINGARGS + BOOT::|compForm1| BOOT::|mergeModemap| + BOOT::|compSubsetCategory| BOOT::|compString| + BOOT::|augModemapsFromDomain| BOOT::|compWithMappingMode| + BOOT::|extractCodeAndConstructTriple| BOOT::|compCat| + BOOT::|pfWith| BOOT::|compMakeDeclaration| + BOOT::|extendsCategoryForm| BOOT::|compSeq| + BOOT::|compSeq1| BOOT::|compReturn| BOOT::|isSubset| + BOOT::|getModemapList| BOOT::|compCase1| + BOOT::|compCoerce1| BOOT::|compPretend| BOOT::|compMacro| + BOOT::|compConstructorCategory| BOOT::|compCoerce| + BOOT::|compColon| BOOT::|compSetq| BOOT::|compLeave| + BOOT::|npList| BOOT::|modeEqualSubst| BOOT::|compIf| + BOOT::|compIs| BOOT::|comp2| BOOT::|compImport| + BOOT::|coerce,fn| BOOT::|throwKeyedMsgFromDb| + BOOT::|sayKeyedMsgFromDb| BOOT::|compHas| BOOT::|compExit| + BOOT::|compElt| BOOT::|compConstruct| BOOT::|compCons| + BOOT::|compCons1| BOOT::|compSeqItem| + BOOT::|recordInstantiation1| BOOT::|compCase| + BOOT::|compQuote| BOOT::|recordInstantiation| + BOOT::|compAtSign| BOOT::|compSuchthat| + BOOT::|addToConstructorCache| BOOT::|loadLibNoUpdate| + BOOT::SETDATABASE BOOT::|lassocShiftWithFunction| + BOOT::|assocCache| BOOT::|assocCacheShift| + BOOT::|assocCacheShiftCount| BOOT::|pileForests| + BOOT::|isLegitimateMode;| BOOT::|hasFileProperty;| + BOOT::|coerceConvertMmSelection;| + BOOT::|hasFilePropertyNoCache| BOOT::|writeLib1| + BOOT::|rwrite| BOOT::|putModemapIntoDatabase| + BOOT::|getOplistWithUniqueSignatures| + BOOT::|checkSkipOpToken| BOOT::|checkSkipIdentifierToken| + BOOT::|readLib1| BOOT::|checkSkipBlanks| + BOOT::MAKE-PARSE-FUNC-FLATTEN-1 BOOT::|checkSkipToken| + BOOT::|getDocForCategory| BOOT::|newWordFrom| + BOOT::PRINT-XDR-STREAM BOOT::|getDocForDomain| + BOOT::|getDoc| BOOT::|htcharPosition| + BOOT::|PackageDescendCode| BOOT::|RecordEqual| + BOOT::|processPackage,replace| BOOT::|UnionEqual| + BOOT::|mkEnumerationFunList| BOOT::|mkMappingFunList| + BOOT::|mkUnionFunList| BOOT::|mkRecordFunList| + BOOT::|MappingEqual| BOOT::|CondAncestorP| + BOOT::|updateDatabase| BOOT::|compressSexpr| + BOOT::|parseTypeError| BOOT::|moreGeneralCategoryPredicate| + BOOT::|encodeUnion| BOOT::|makeCatPred| + BOOT::|lookupInDomainByName| BOOT::|simpHasAttribute| + BOOT::|domainHput| BOOT::|simpHasPred,simpHas| + BOOT::|substDollarArgs| BOOT::|NRTisRecurrenceRelation| + BOOT::|dbShowOpSigList| BOOT::|dbSelectData| + BOOT::|dbReduceOpAlist| BOOT::|listOfCategoryEntriesIf| + BOOT::|dbResetOpAlistCondition| + BOOT::|algCoerceInteractive| BOOT::|buildPredVector,fn| + BOOT::|extendsCategoryBasic| BOOT::|catExtendsCat?| + BOOT::|expandType| BOOT::|expandTypeArgs| BOOT::|stuffSlot| + BOOT::|dbPresentOpsSaturn| BOOT::|reduceOpAlistForDomain| + BOOT::|mungeAddGensyms,fn| BOOT::|dbReduceBySelection| + BOOT::|extendsCategoryBasic0| BOOT::|substSlotNumbers| + BOOT::|dbReduceBySignature| BOOT::|extendsCategory| + BOOT::|buildPredVector| BOOT::|dbParts| + BOOT::|NRTextendsCategory1| BOOT::|getSubstQualify| + BOOT::|fortFormatLabelledIfGoto| BOOT::|whoUsesMatch1?| + BOOT::|fullSubstitute| BOOT::|whoUsesMatch?| + BOOT::|getfortarrayexp| BOOT::|addWhereList| + BOOT::|dbGetDisplayFormForOp| + BOOT::|dbGetFormFromDocumentation| BOOT::|anySubstring?| + VMLISP::MAKE-ENTRY BOOT::|NRTsetVector4a| + BOOT::|NRTsetVector4Part1| BOOT::|NRTencode,encode| + BOOT::|consOpSig| BOOT::|genSlotSig| BOOT::|NRTsetVector4| + BOOT::|newExpandGoGetTypeSlot| BOOT::MAKEOP + BOOT::|insertEntry| BOOT::|nextown| BOOT::|mkFortFn| + BOOT::|exp2Fort2| BOOT::|evalQUOTE| BOOT::|evalSEQ| + BOOT::|IFcodeTran| BOOT::|exp2FortFn| + BOOT::|fortFormatHead| BOOT::|addContour,fn1| + BOOT::|traverse,traverseInner| BOOT::|upTableSetelt| + BOOT::|printSignature| BOOT::|addContour,fn3| + BOOT::|commandAmbiguityError| BOOT::|charPosition| + BOOT::|traverse| BOOT::|dbPart| BOOT::|commandErrorMessage| + BOOT::|substituteOp| BOOT::|displayModemap| + BOOT::|displayType| BOOT::|comp| BOOT::|displayMode| + BOOT::|numOfOccurencesOf,fn| VMLISP::QUOREM + BOOT::|pmatchWithSl| BOOT::|displayCondition| + BOOT::|displayValue| + BOOT::|intersectionContour,buildModeAssoc| BOOT::|get| + BOOT::|sigDomainVal| BOOT::GEQNSUBSTLIST + BOOT::|compNoStacking| BOOT::|transImplementation| + BOOT::GEQSUBSTLIST BOOT::|libConstructorSig,g| + BOOT::|coerceable| BOOT::|substituteIntoFunctorModemap| + BOOT::|adjExitLevel| BOOT::|getParentsFor| + BOOT::|asytranApply| BOOT::|explodeIfs,fn| BOOT::|dbSplit| + BOOT::|buildLibAttr| BOOT::|buildLibOp| + BOOT::|transKCatAlist| BOOT::|dbTickIndex| + BOOT::|insertShortAlist| BOOT::|sublisFormal,sublisFormal1| + BOOT::PUTALIST FOAM:|FormatNumber| + BOOT::|dbSetOpAlistCondition| BOOT::|compiledLookup| + BOOT::|insertAlist| BOOT::|reduceAlistForDomain| + BOOT:|StreamCopyChars| BOOT:|StreamCopyBytes| + BOOT::|dbXParts| BOOT::|kePageDisplay| + BOOT::|dbShowOpItems| BOOT::MKPFFLATTEN-1 + BOOT::|dbSearchOrder| BOOT::CARCDRX1 BOOT::SETELTREST + BOOT::SETELTFIRST BOOT::AS-INSERT1 BOOT::AS-INSERT + BOOT::PROPERTY BOOT::|mkDomTypeForm| BOOT::|stringPosition| + BOOT:|StringFromTo| BOOT::|patternCheck,equal| + BOOT:|StringFromLong| BOOT::|rightCharPosition| + BOOT::|infix?| BOOT::|matchSegment?| BOOT::|stringMatch| + BOOT::|skipBlanks| BOOT::|dbPresentConsSaturn| + BOOT::MAKE-DEFUN BOOT::|compOrCroak| BOOT::|profileRecord| + BOOT::|getSignature| BOOT::|traceDomainLocalOps| + BOOT::|getArgumentModeOrMoan| + BOOT::|filterListOfStringsWithFn| + BOOT::|mkGrepPattern1,charPosition| + BOOT::|displayModemap,g| + BOOT::|filterAndFormatConstructors| BOOT::READ-BOOT + BOOT::|userLevelErrorMessage| BOOT::|addBinding| + BOOT::|dbShowConsDoc1| BOOT::|makePathname| + BOOT::|mkConform| BOOT::|dbInfoFindCat| BOOT::|compReduce| + BOOT::|dbShowInfoList| BOOT::|dbShowConditions| + BOOT::|compRepeatOrCollect| BOOT::|dbInfoOrigin| + BOOT::|dbConstructorDoc| BOOT::|interpret2| + BOOT::|htpSetLabelInputString| BOOT::|letPrint2| + BOOT::|letPrint| BOOT::|mapLetPrint| + BOOT::|htpAddInputAreaProp| BOOT::|getOpBindingPower| + BOOT::|infixArgNeedsParens| BOOT::|linearFinalRequest| + BOOT::|bcInputEquations,f| BOOT::|htpSetLabelErrorMsg| + BOOT::|isBreakSegment?| BOOT::|substring?| + BOOT::|sublisMatAlist| BOOT::MAKESPAD + BOOT::|reportCategory| BOOT::|longext| + BOOT::|npParenthesize| BOOT::|bcString2WordList,fn| + VMLISP::ECQGENEXP VMLISP::RCQGENEXP BOOT::|outputString| + BOOT::|outputNumber| VMLISP::DODSETQ + BOOT::|pfInfApplication| BOOT::|insertString| + BOOT::|npAndOr| BOOT::|npListofFun| BOOT::|optSpecialCall| + BOOT::|pfPushBody| BOOT::|pfIf| BOOT::|incZip| + BOOT::|augProplist| BOOT::|augProplistInteractive| + BOOT::|centerString| BOOT::|evalCOLLECT| + BOOT::|interpCOLLECTbody| BOOT::|upLoopIterIN| + BOOT::|position,posn| BOOT::|domainVal| BOOT::|subVecNodes| + BOOT::|addBindingInteractive| BOOT::|interpCOLLECT| + BOOT::|upTaggedUnionConstruct| BOOT::|upRecordConstruct| + BOOT::|newExpandTypeSlot| BOOT::|upNullList| + BOOT::|upStreamIterIN| BOOT::|getCatForm| + BOOT::|oldAxiomAddChild| BOOT::|evalCOERCE| + BOOT::|mkAndApplyZippedPredicates| BOOT::|lookupPred| + BOOT::|oldAxiomDomainHasCategory| BOOT::|mkIterFun| + BOOT::|attributeCategoryBuild| + BOOT::|oldAxiomCategoryBuild| BOOT::|upLETtype| + BOOT::|upLETWithFormOnLhs| BOOT::|lazyMatchAssocV1| + BOOT::|oldAxiomCategoryNthParent| BOOT::|assignSymbol| + BOOT::|evalIsntPredicate| BOOT::|evalIsPredicate| + BOOT::|SpadInterpretStream| BOOT::|upSetelt| BOOT:SUBLISLIS + BOOT::|upNullTuple| BOOT::|evalIF| BOOT::|intloopProcess| + BOOT::|evalis| BOOT::|evalREPEAT| BOOT::|upwhereMain| + BOOT::|upwhereMkAtree| BOOT::|upwhereClause| + BOOT::|intloopInclude0| BOOT::|intloopSpadProcess,interp| + BOOT::|incPrefix?| BOOT::|inclmsgIfSyntax| + BOOT::|renamePatternVariables1| BOOT::|newExpandLocalType| + BOOT::|newExpandLocalTypeForm| + BOOT::|oldAxiomPreCategoryBuild| + BOOT::|getFunctionFromDomain| BOOT::|lazyOldAxiomAddChild| + BOOT:SUBSTEQ BOOT::|getOpCode| BOOT::|lazyDomainSet| + BOOT::|application2String| BOOT::|putI| BOOT::|mkInterpFun| + BOOT::|interpret1| BOOT::|analyzeMap0| + BOOT::|reportOpSymbol,sayMms| BOOT::|findLocalsInLoop|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T) T) BOOT::|analyzeRecursiveMap| + BOOT::|augmentMap| BOOT::|reportFunctionCompilation| + BOOT::|putSrcPos| BOOT::|hasSigInTargetCategory,fn| + BOOT::|encodeFunctionName| BOOT::|getArgValueComp2| + BOOT::|augModemapsFromCategory| BOOT::|compDefineFunctor1| + BOOT::|augModemapsFromCategoryRep| + BOOT::|compDefineFunctor| BOOT::|processFunctor| + BOOT::|buildFunctor| BOOT::|selectMmsGen,matchMms| + BOOT::|makeConstrArg| + BOOT::|commuteSparseUnivariatePolynomial| + BOOT::|commuteUnivariatePolynomial| + BOOT::|commuteSquareMatrix| BOOT::|coerceDmp1| + BOOT::|aggregateApp| BOOT::|compDefineCategory1| + BOOT::|commuteFraction| BOOT::|compDefineCategory| + BOOT::|commuteQuaternion| BOOT::|commuteComplex| + BOOT::|resolveTT2| BOOT::|concatApp1| + BOOT::|compFormPartiallyBottomUp| + BOOT::|canReturn,findThrow| BOOT::|orderMms| + BOOT::|sayFunctionSelection| BOOT::MATCH-FUNCTION-DEF + BOOT::|commuteNewDistributedMultivariatePolynomial| + BOOT::|commuteMPolyCat| + BOOT::|commuteDistributedMultivariatePolynomial| + BOOT::|commuteMultivariatePolynomial| + BOOT::|commutePolynomial| BOOT::|bottomUpDefaultCompile| + BOOT::|bottomUpDefaultEval| BOOT::|bottomUpFormTuple| + BOOT::|bottomUpFormAnyUnionRetract| BOOT::|bottomUpForm| + BOOT::|bottomUpFormUntaggedUnionRetract| + BOOT::|bottomUpFormRetract| BOOT::|bottomUpForm2| + BOOT::|bottomUpForm0| BOOT::|bottomUpForm3| + BOOT::|coerceByTable| BOOT::|compileRecurrenceRelation| + BOOT::|logS| BOOT::|spadify| BOOT::|prepareResults| + BOOT::|DescendCodeAdd1| + BOOT::|htSystemVariables,displayOptions| BOOT::|evalAndSub| + BOOT::FINCOMBLOCK BOOT::|compIf,Env| BOOT::LOCALASY + BOOT::|mkCacheVec| BOOT::LOCALNRLIB BOOT::|selectMms1;| + BOOT::|selectMms2| BOOT::|processPackage| + BOOT::|mkCategory| BOOT::|newCompareSig| + BOOT::|lookupInDomain| BOOT::|fortFormatDo| + BOOT::|newLookupInDomain| BOOT::|getNewDefaultPackage| + BOOT::|printLabelledList| BOOT::|compApplication| + BOOT::|dbExpandOpAlistIfNecessary| BOOT::-REDUCE + BOOT::|compDefineCapsuleFunction| BOOT::|genSearchSay| + BOOT::|compRepeatOrCollect,fn| BOOT::|dbGetDocTable| + BOOT::|apprpar| BOOT::WRITE-TAG-LINE BOOT::|concatTrouble| + BOOT::|charyBinary| BOOT::|split2| BOOT::|needStar| + BOOT::|lazyMatchArg2| BOOT::|newLookupInTable| + BOOT::|hashNewLookupInTable| BOOT::|compileADEFBody| + BOOT::|interpLoopIter| BOOT::|compileIF| + BOOT::|xlCannotRead| BOOT::|xlMsg| BOOT::|xlNoSuchFile| + BOOT::|incLine| BOOT::|xlFileCycle| BOOT::|xlConStill| + BOOT::|xlConActive| BOOT::|xlSay| BOOT::|xlOK1| + BOOT::|incLude| BOOT::|analyzeDeclaredMap|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T) T) BOOT::|analyzeNonRecursiveMap| + BOOT::|makeInternalMapName| BOOT::|printCName| + BOOT::|clearDep1| BOOT::|domArg| BOOT::|mkDomPvar| + BOOT::|hasSig| BOOT::|putIntSymTab| + BOOT::|findConstructorSlotNumber| BOOT::MAKE-FLOAT + BOOT::|getFileProperty| + BOOT::|compDefWhereClause,fetchType| BOOT::|compSubDomain1| + BOOT::|putFileProperty| BOOT::|srcPosNew| + BOOT::|substNames| BOOT::|mac0MLambdaApply| + BOOT::|mac0ExpandBody| BOOT::|genDomainView| + BOOT::|getArgValue2| BOOT::|compFunctorBody| + BOOT::|analyzeMap| BOOT::|defaultTarget| + BOOT::|selectDollarMms| BOOT::|selectMmsGen| + BOOT::|allOrMatchingMms| BOOT::|evalMmCat| + BOOT::|matchMmSig| BOOT::/LOCATE BOOT::|hasCateSpecialNew| + BOOT::|evalMm| BOOT::|evalMmFreeFunction| + BOOT::|hasCateSpecial| BOOT::|hasCate1| BOOT::|boxApp| + BOOT::|concatApp| BOOT::|appsum| BOOT::|altSuperSubApp| + BOOT::|concatbApp| BOOT::|appSum| BOOT::|binomApp| + BOOT::|aggApp| BOOT::|fixUpPredicate| BOOT::|stepApp| + BOOT::|appneg| BOOT::|setqMultipleExplicit| + BOOT::|braceApp| BOOT::|compSetq1| BOOT::|timesApp| + BOOT::|rootApp| BOOT::|bracketApp| BOOT::|plusApp| + BOOT::|appparu1| BOOT::|bigopWidth| BOOT::|P2Us| + BOOT::|pi2App| BOOT::|boxLApp| VMLISP:STRPOSL + BOOT::|compOrCroak1| BOOT::|piApp| BOOT::|compForm2| + BOOT::|compForm3| BOOT::|getConditionalCategoryOfType1| + BOOT::|indefIntegralApp| BOOT::|nothingApp| + BOOT::|evalconstruct| BOOT::|evalInfiniteTupleConstruct| + BOOT::|setqSetelt| BOOT::|evalTupleConstruct| + BOOT::|consProplistOf| BOOT::|setqMultiple| + BOOT::|coerceImmediateSubDomain| BOOT::|intApp| + BOOT::|setqSingle| BOOT::|assignError| BOOT::|sigma2App| + BOOT::|canReturn| BOOT::|appext| BOOT::|centerApp| + BOOT::|sigmaApp| BOOT::|stringApp| BOOT::|MpP2P| + BOOT::|evalForm| BOOT::|selectLocalMms| + BOOT::|bottomUpDefault| BOOT::|canCoerceTopMatching| + BOOT::|catchCoerceFailure| BOOT::|asGetModemaps| + BOOT::|asytranCategory| BOOT::|asytranCategoryItem| + BOOT::|asytranDeclaration| + BOOT::|InvestigateConditions,flist| BOOT::|getTranslation| + BOOT::|condUnabbrev| + BOOT::|constructorAbbreviationErrorCheck| BOOT::READ-SPAD0 + BOOT::|BesselasymptB| BOOT::|optCallSpecially| + BOOT::|getDocDomainForOpSig| BOOT::|reportFunctionCacheAll| + BOOT::|clngammacase2| BOOT::|constoken| BOOT::|writeMalloc| + BOOT::|printDec| BOOT::|htPred2English,gn| + BOOT::|prepareData| BOOT::|protectedNagCall| + BOOT::|axiomType| BOOT::|DescendCode| + BOOT::|SetFunctionSlots| + BOOT::|InvestigateConditions,update| + BOOT::|htSystemVariables,functionTail| VMLISP:STRPOS + BOOT::|replaceExitEtc,fn| BOOT::|compNoStacking1| + BOOT::|compClam| BOOT::|getModemapListFromDomain| + BOOT::|say2Split| BOOT::|compColonInside| BOOT::|haddProp| + BOOT::|npEnclosed| BOOT::|hputNewProp| + BOOT::ASHARPMKAUTOLOADFUNCTOR + BOOT::ASHARPMKAUTOLOADCATEGORY BOOT::|addCoreModemap| + BOOT::|getMatchingRightPren| BOOT::|checkHTargs| + BOOT::|mkOperatorEntry| BOOT::|catPairUnion| + BOOT::|lookupUF| BOOT::|newLookupInCategories| + BOOT::|lookupFF| BOOT::|simpHasSignature| + BOOT::|compareSig| BOOT::|lazyCompareSigEqual| + BOOT::|lookupInAddChain| BOOT::|lookupInCategories| + BOOT::|lookupInTable| BOOT::|lookupDisplay| + BOOT::|domainTableLookup| BOOT::|dbShowOpConditions| + BOOT::|dbShowOpParameterJump| + BOOT::|dbShowOpImplementations| BOOT::|dbShowOpParameters| + BOOT::|dbShowOpOrigins| BOOT::|dbShowOpSignatures| + BOOT::|getSigSubst| BOOT::|optDeltaEntry| + BOOT::|lazyMatchArg| BOOT::|nrunNumArgCheck| + BOOT::|nextown2| BOOT::|semchkProplist| + BOOT::|interpREPEAT| BOOT::|makeCommonEnvironment,fn| + BOOT::|compMapCondFun| BOOT::|compApplyModemap| + BOOT::|compMapCond| BOOT::|compMapCond'| + BOOT::|compToApply| BOOT::REDUCE-N BOOT::|applyMapping| + BOOT::|compFormWithModemap| BOOT::|compAtomWithModemap| + BOOT::|ancestorsRecur| BOOT::|checkCommentsForBraces| + BOOT::|dbShowOpDocumentation| BOOT::|dbShowOpNames| + BOOT::REDUCE-N-1 BOOT::|dbGatherData| BOOT::|dbConsHeading| + BOOT::REDUCE-N-2 BOOT::|termMatch| BOOT::|matchAnySegment?| + BOOT::|replaceExitEtc| BOOT::|put| BOOT::|checkAndDeclare| + BOOT::|hasSigInTargetCategory| BOOT::READ-SPAD1 + BOOT::|mkDetailedGrepPattern| BOOT::|displayInfoOp| + BOOT::|dbShowInfoOp| BOOT::|compReduce1| BOOT::|letPrint3| + BOOT::|intloopSpadProcess| BOOT::|zagApp| + BOOT::|findBalancingBrace| BOOT::|appelse| BOOT::|appChar| + BOOT::|appInfix| BOOT::|htMakeButtonSaturn| + BOOT::|vconcatapp| BOOT::|superSubApp| BOOT::|xLate| + BOOT::|appconc| BOOT::MAKELIB BOOT::|appparu| + BOOT::|charySemiColon| BOOT::|charyElse| + BOOT::|charyEquatnum| BOOT::|bcFindString| + BOOT::|charySplit| BOOT::|charyMinus| VMLISP::DCQGENEXP + BOOT::|augProplistOf| BOOT::|putHist| + BOOT::|evalUntargetedADEF| BOOT::|evalTargetedADEF| + BOOT::|mergeInPlace| BOOT::|upLoopIterSTEP| + BOOT::|mergeSort| BOOT::|interpLoop| BOOT::|collectStream| + BOOT::|collectStream1| BOOT::|lazyMatch| + BOOT::|lazyMatchArgDollarCheck| + BOOT::|interpCOLLECTbodyIter| BOOT::|lookupInCompactTable| + BOOT::|sayLooking| BOOT::|upStreamIterSTEP| + BOOT::|lookupIncomplete| BOOT::|newLookupInAddChain| + BOOT::|hashNewLookupInCategories| BOOT::|lookupComplete| + BOOT::|newLookupInCategories1| BOOT::|lazyMatchAssocV| + BOOT::|collectSeveralStreams| BOOT::|mkIterZippedFun| + BOOT::|compareSigEqual| BOOT::|mkInterpTargetedADEF| + BOOT::|compileTargetedADEF| BOOT::|collectOneStream| + BOOT::|oldCompLookupNoDefaults| BOOT::|evalTuple| + BOOT::|interpIF| BOOT::|getReduceFunction| + BOOT::|NRTgetMinivectorIndex| BOOT::|xlPrematureFin| + BOOT::|xlPrematureEOF| BOOT::|xlCmdBug| BOOT::|xlIfBug| + BOOT::|xlSkippingFin| BOOT::|xlConsole| BOOT::|xlOK| + BOOT::|xlSkip| BOOT::|lookupInDomainVector| + BOOT::|basicLookupCheckDefaults| BOOT::|basicLookup| + BOOT::|oldCompLookup| BOOT::|analyzeUndeclaredMap|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T) T) BOOT::|compDefineLisplib| + BOOT::|compConLib1| BOOT::|addModemap| BOOT::|mmCost| + BOOT::|findFunctionInDomain1| BOOT::/WRITEUPDATE + BOOT::|mmCost0| BOOT::|/D,2,LIB| + BOOT::|processFunctorOrPackage| BOOT::|compOrCroak1,fn| + BOOT::/D-2 BOOT::|BesselIBackRecur| BOOT::|invokeFortran| + BOOT::|nagCall| BOOT::|makeFort| BOOT::|addModemapKnown| + BOOT::|addModemap1| BOOT::|addEltModemap| BOOT::|compHash| + BOOT::|compHashGlobal| BOOT::|compApply| BOOT::|kdPageInfo| + BOOT::|addModemap0| BOOT::|bracketagglist| + BOOT::|attributeLookupExport| BOOT::|upDollarTuple| + BOOT::|xlIfSyntax| BOOT::|incLine1| + BOOT::|oldAxiomCategoryLookupExport| BOOT::|genMapCode| + BOOT::|putMapCode|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T *) T) BOOT::|pfLeaf| BOOT::BPITRACE + VMLISP:|remove| VMLISP:RREAD VMLISP:REMOVEQ + BOOT::MATCH-LISP-TAG VMLISP:NREMOVE VMLISP:NREMOVEQ + BOOT::|tokConstruct| BOOT::|pfAdd| + BOOT:|ByteFileReadLineIntoString| BOOT:MATCH-TOKEN)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T *) T) BOOT::|ncHardError| + BOOT::TOKEN-INSTALL BOOT::|ncSoftError| BOOT::|lnCreate|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T) T) BOOT::|findFunctionInCategory| + BOOT::|Mp2MpAux1| BOOT::|Mp2MpAux0| BOOT::|Expr2Dmp1| + BOOT::|Mp2SimilarDmp| BOOT::|bigopAppAux| + BOOT::|findFunctionInDomain| BOOT::|abbreviationError| + BOOT::|lisplibError| BOOT::|invokeNagman| + BOOT::|mkNewModemapList| BOOT::|mkDiffAssoc| + BOOT::|dbGatherThenShow| BOOT::|appInfixArg| + BOOT::|lazyOldAxiomDomainLookupExport| + BOOT::|oldAxiomDomainLookupExport|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T T) T) + BOOT::|displayDomainOp|)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T *) T) VMLISP:RPLACSTR)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T T) T) BOOT::|P2DmpAux| + BOOT::|makeSpadFun|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T) T) BOOT::|compDefineCategory2| + BOOT::|P2MpAux| BOOT::|makeFort1|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T T T T T T T) T) BOOT::|writeCFile| + BOOT::|Mp2MpAux2|)) +(PROCLAIM '(FTYPE (FUNCTION (T T T T T *) T) BOOT::|msgCreate|)) +(PROCLAIM + '(FTYPE (FUNCTION NIL *) BOOT::|generateResultsName| + BOOT::|generateDataName| BOOT::|htShowPage| + BOOT::|PARSE-Label| BOOT::|bcMatrix| BOOT::|PARSE-Primary1| + BOOT::|PARSE-Enclosure| BOOT::|bcDraw2DSolve| + BOOT::|PARSE-Selector| BOOT::|PARSE-Category| + BOOT::|PARSE-Option| BOOT::|PARSE-TokenOption| + BOOT::|PARSE-Sexpr1| BOOT::|PARSE-Sexpr| + BOOT::|PARSE-Scripts| BOOT::|PARSE-SpecialCommand| + BOOT::|PARSE-FloatBasePart| BOOT::|PARSE-FloatBase| + BOOT::|PARSE-Leave| BOOT::|e02aef| BOOT::|e04ucfCopOut| + BOOT::|c02agf| BOOT::|c02aff| BOOT::|e02adf| BOOT::|c05pbf| + VMLISP:RECLAIM BOOT::MKPROMPT BOOT::|sendHTErrorSignal| + BOOT::|testPage| BOOT::|e01sef| BOOT::|e01saf| + BOOT::|e01daf| BOOT::|e01bhf| BOOT::|e01bgf| BOOT::|e01bff| + BOOT::|e01bef| BOOT::|e01baf| BOOT::|e02zaf| BOOT::|e02gaf| + BOOT::|e02dff| BOOT::|e02def| BOOT::|e02ddf| BOOT::|e02dcf| + BOOT::|e02daf| BOOT::|e02bef| BOOT::|e02bdf| + BOOT::|minusInfinity| BOOT::|plusInfinity| + BOOT::SERVER-SWITCH BOOT::CLEARDATABASE BOOT::NBOOT-LEXPR + BOOT::BOOT-LEXPR BOOT::|executeQuietCommand| + BOOT::|serverSwitch| BOOT::|scanS| + BOOT::|sendNagmanErrorSignal| BOOT::|d01gbf| BOOT::|d01gaf| + BOOT::|d01fcf| BOOT::|d01bbf| BOOT::|d01asf| + BOOT::|d02rafCopOut| BOOT::|d02raf| BOOT::|d02kef| + BOOT::|d02gbf| BOOT::|d02gaf| BOOT::|d02ejf| BOOT::|d02cjf| + BOOT::|d02bhf| BOOT::|d02bbf| BOOT::|e02ahf| + BOOT::|d03edfShort| BOOT::|d03edfLong| BOOT::|d03eefInput| + BOOT::|d03faf| BOOT::|d03eef| BOOT::|d03edf| + BOOT::|htSystemVariables| BOOT::|htSetVars| + BOOT::|mkSetTitle| BOOT::|npCategory| + BOOT::PARSE-CONS_SEXPR BOOT::PARSE-SEXPR + BOOT::PARSE-REF_SEXPR BOOT::PARSE-EXPR2 BOOT::PARSE-EXPR1 + BOOT::|htsv| BOOT::|npDefinitionItem| BOOT::|npDefn| + BOOT::|npMacro| BOOT::|npMDEFinition| BOOT::|npRule| + BOOT::RESETHASHTABLES BOOT::READSPADEXPR + BOOT::|batchExecute| BOOT::|c05nbf| BOOT::|c05adf| + BOOT::|c06gsf| BOOT::|c06gqf| BOOT::|c06gcf| BOOT::|c06gbf| + BOOT::|c06fuf| BOOT::|c06frf| BOOT::|c06fqf| BOOT::|c06fpf| + BOOT::|c06ekf| BOOT::|c06ecf| BOOT::|c06ebf| BOOT::|c06eaf| + BOOT::|s17def| BOOT::|s17dcf| BOOT::|s17akf| BOOT::|s17ajf| + BOOT::|s17ahf| BOOT::|s17agf| BOOT::|s17aff| BOOT::|s17aef| + BOOT::|s17adf| BOOT::|s17acf| BOOT::|s15aef| BOOT::|s15adf| + BOOT::|s14baf| BOOT::|s14abf| BOOT::|s14aaf| BOOT::|s13adf| + BOOT::|s13acf| BOOT::|s13aaf| BOOT::|s01eaf| BOOT::|s21bdf| + BOOT::|s21bcf| BOOT::|s21bbf| BOOT::|s21baf| BOOT::|s20adf| + BOOT::|e02agf| BOOT::|s20acf| BOOT::|d01aqf| BOOT::|s19adf| + BOOT::|d01apf| BOOT::|s19acf| BOOT::|d01anf| BOOT::|d01amf| + BOOT::|d01alf| BOOT::|s19abf| BOOT::|d01akf| BOOT::|s19aaf| + BOOT::|d01ajf| BOOT::|s18def| BOOT::|s18dcf| BOOT::|s18aff| + BOOT::|s18aef| BOOT::|s18adf| BOOT::|s18acf| BOOT::|f04qaf| + BOOT::|f04mcf| BOOT::|f04mbf| BOOT::|f04maf| BOOT::|f04jgf| + BOOT::|f04faf| BOOT::|f04axf| BOOT::|f04atf| BOOT::|f04asf| + BOOT::|quit| BOOT::|f04arf| BOOT::|quitSpad2Cmd| + BOOT::|f04adf| BOOT::|pquit| BOOT::|pquitSpad2Cmd| + BOOT::CONTINUE BOOT::|continue| BOOT::|purgeLocalLibdb| + BOOT::|dbSplitLibdb| BOOT::|f07fef| BOOT::|f07fdf| + BOOT::|f07aef| BOOT::|f07adf| BOOT::|copyright| + BOOT::|s17dlf| BOOT::|s17dhf| BOOT::|s17dgf| BOOT::|f02xef| + BOOT::|f02wef| BOOT::|f02fjf| BOOT::|f02bjf| BOOT::|f02bbf| + BOOT::|f02axf| BOOT::|f02awf| BOOT::|f02akf| BOOT::|f02ajf| + BOOT::|f02agf| BOOT::|htShowPageNoScroll| BOOT::|f02aff| + BOOT::|f02aef| BOOT::|f02adf| BOOT::|f02abf| BOOT::|f02aaf| + BOOT::|measure| BOOT::|writeSaturnSuffix| BOOT::NEWRULE + BOOT::PARSE-LOCAL_VAR BOOT::|htErrorStar| + BOOT::|queryClients| BOOT::|onDisk| BOOT::|endHTPage| + BOOT::|readSpadProfileIfThere| BOOT::|bcDraw3Dpar1| + BOOT::|bcDraw3Dpar| BOOT::|htShowPageStarSaturn| + BOOT::|htShowPageStar| BOOT::|bcDraw3Dfun| + BOOT::|bcDraw2Dpar| BOOT::|bcSum| BOOT::|bcSeries| + BOOT::|bcProduct| BOOT::|bcLimit| + BOOT::|bcIndefiniteIntegrate| BOOT::|bcDraw| + BOOT::|bcDifferentiate| BOOT::|bcDefiniteIntegrate| + BOOT::|bcDraw2Dfun| BOOT::MAKE-TAGS-FILE BOOT::|bcSolve| + BOOT::|npPrimary1| BOOT::|e02bcf| BOOT::|e02bbf| + BOOT::|e02baf| BOOT::|e02akf| BOOT::|e02ajf| BOOT::|e04ycf| + BOOT::|e04ucf| BOOT::|e04naf| BOOT::|e04mbf| BOOT::|e04jaf| + BOOT::|e04gcf| BOOT::|e04fdf| BOOT::|e04dgf| BOOT::|f01ref| + BOOT::|f01rdf| BOOT::|f01rcf| BOOT::|f01qef| BOOT::|f01qdf| + BOOT::|f01qcf| BOOT::|f01mcf| BOOT::|f01maf| BOOT::|f01bsf| + BOOT::|f01brf|)) +(PROCLAIM + '(FTYPE (FUNCTION NIL T) BOOT::|getCodeVector| + BOOT:PARSE-IDENTIFIER BOOT::|axDoLiterals| + BOOT::|PARSE-Suffix| BOOT:CURRENT-TOKEN + BOOT::|PARSE-TokTail| BOOT::|PARSE-InfixWith| + BOOT::|PARSE-With| BOOT::|PARSE-Form| + BOOT::|PARSE-Reduction| BOOT::|PARSE-SemiColon| + BOOT::|PARSE-Iterator| BOOT::|PARSE-Primary| + BOOT::|PARSE-ElseClause| BOOT::|PARSE-Conditional| + BOOT::|PARSE-Name| BOOT::|PARSE-Sequence| + BOOT::|PARSE-Data| BOOT::|PARSE-FormalParameter| + BOOT::|PARSE-IntegerTok| BOOT::|PARSE-String| + BOOT::|PARSE-Quad| BOOT::|PARSE-VarForm| + BOOT::|PARSE-Qualification| BOOT::|PARSE-Prefix| + BOOT::|PARSE-Infix| BOOT::|PARSE-Application| + BOOT:CURRENT-SYMBOL BOOT::|clearCmdSortedCaches| + BOOT::|PARSE-Statement| BOOT::|PARSE-Command| + BOOT::|updateInCoreHist| BOOT::|processSynonyms| + BOOT::|disableHist| BOOT::|PARSE-IteratorTail| + BOOT::|histFileName| BOOT::|PARSE-OpenBrace| + BOOT::|PARSE-Sequence1| BOOT::|PARSE-OpenBracket| + BOOT::|PARSE-PrimaryNoFloat| BOOT:FAIL BOOT::|PARSE-Float| + BOOT::|PARSE-PrimaryOrQM| BOOT::|PARSE-TokenList| + BOOT::|PARSE-AnyId| BOOT::|resetInCoreHist| + BOOT::|PARSE-TokenCommandTail| BOOT::|isTokenDelimiter| + BOOT::|PARSE-ScriptItem| BOOT::|PARSE-CommandTail| + BOOT::|historySpad2Cmd| BOOT::|PARSE-FormalParameterTok| + BOOT::|PARSE-SpecialKeyWord| + BOOT::|writeHistModesAndValues| BOOT::|PARSE-FloatTok| + BOOT::|PARSE-FloatExponent| BOOT::|updateHist| + BOOT::|initHistList| BOOT::|initHist| BOOT::|PARSE-Exit| + BOOT::|oldHistFileName| BOOT:PARSE-NUMBER + BOOT::|PARSE-Return| BOOT::|PARSE-ReductionOp| + BOOT::|PARSE-LabelExpr| BOOT::|PARSE-Import| + BOOT::|writeHiFi| BOOT::|PARSE-Loop| + BOOT::|updateCurrentInterpreterFrame| BOOT::|PARSE-Seg| + BOOT:CURINPUTLINE BOOT::|profileWrite| BOOT:PARSE-BSTRING + BOOT:NEXT-TOKEN BOOT:IOSTAT BOOT::|isPackageFunction| + BOOT:UNGET-TOKENS BOOT::|setOptKeyBlanks| + BOOT::|getInfovecCode| BOOT::|NRTmakeSlot1Info| + BOOT::|reportOnFunctorCompilation| BOOT:BUMPCOMPERRORCOUNT + BOOT::|displayMissingFunctions| BOOT:PARSE-STRING + BOOT:ADVANCE-TOKEN BOOT::ERRHUH BOOT:CURRENT-CHAR + VMLISP:$TOTAL-ELAPSED-TIME BOOT::IS-GENSYM + BOOT::|getSpecialCaseAssoc| + BOOT::|makeConstructorsAutoLoad| + BOOT::|displayExposedGroups| + BOOT::|displayHiddenConstructors| + BOOT::|displaySemanticErrors| BOOT::|clock| + BOOT::|startTimer| BOOT::|spadPrompt| BOOT::|stopTimer| + BOOT::|quadSch| BOOT::/TRACEREPLY BOOT::TRACELETREPLY + BOOT::|voidValue| BOOT::/COMP BOOT::|getDateAndTime| + BOOT::|coercionFailure| VMLISP:EMBEDDED + BOOT::|printableArgModeSetList| BOOT::|asList| + BOOT::|boot2LispError| BOOT::|extendConstructorDataTable| + BOOT::|fin| BOOT::PARSERSTATE BOOT::|New,ENTRY,1| + BOOT::|mkLowerCaseConTable| BOOT::NEW-LEXPR-INTERACTIVE + BOOT::NEW-LEXPR BOOT::|spadThrow| BOOT::INITIALIZE + BOOT::NEW BOOT::|New,ENTRY| BOOT::|traceComp| + BOOT::|New,ENTRY1| BOOT::|New,ENTRY,SYS| BOOT::NEWPO + BOOT::|returnToReader| BOOT::|returnToTopLevel| BOOT::TOP + BOOT::|serverLoop| BOOT::|describeSetOutputTex| + BOOT::|describeSetOutputFortran| + BOOT::|describeSetLinkerArgs| + BOOT::|describeProtectSymbols| + BOOT::|describeOutputLibraryArgs| + BOOT::|describeSetFortDir| BOOT::|describeFortPersistence| + BOOT::|describeSetFortTmpDir| + BOOT::|describeProtectedSymbolsWarning| + BOOT::|describeSetStreamsCalculate| + BOOT::|describeSetOutputFormula| + BOOT::|describeInputLibraryArgs| + BOOT::|resetWorkspaceVariables| BOOT::|describeSetNagHost| + BOOT::|describeAsharpArgs| BOOT::|describeSetOutputAlgebra| + BOOT::|sayAllCacheCounts| BOOT::|describeSetFunctionsCache| + BOOT::|nangenericcomplex| BOOT::|createTypeEquivRules| + BOOT::|createResolveTTRules| BOOT::|createResolveTMRules| + BOOT::|bcBlankLine| BOOT::|browserAutoloadOnceTrigger| + BOOT::|scanKeyTableCons| BOOT::|scanToken| BOOT::|scanEsc| + BOOT::|scanError| BOOT::|scanEscape| BOOT::|scanNumber| + BOOT::|asharpConstructors| BOOT::|scanString| + BOOT::|scanSpace| BOOT::|scanPunct| BOOT::|scanNegComment| + BOOT::|startsNegComment?| BOOT::|scanComment| + BOOT::|startsComment?| BOOT::|scanPunCons| + BOOT::|scanDictCons| BOOT::|resetStackLimits| + BOOT::|npRecoverTrap| BOOT::|syGeneralErrorHere| + BOOT::|DPname| BOOT::|pfNoPosition| VMLISP:CURRENTTIME + BOOT::|buildHtMacroTable| BOOT::|checkWarningIndentation| + BOOT::|npDecl| BOOT::|npType| VMLISP:$SCREENSIZE + BOOT::|npAmpersand| BOOT::|npName| BOOT::|npFromdom| + BOOT::|npSCategory| BOOT::|npPrimary| BOOT::|npState| + BOOT::|npDefaultValue| BOOT::|npAssignVariableName| + BOOT::|npPDefinition| BOOT::|npDollar| + BOOT::|npSQualTypelist| BOOT::PARSE-NON_DEST_REF + BOOT::PARSE-OPT_EXPR BOOT::PARSE-REPEATOR + BOOT::|npCategoryL| BOOT::PARSE-SEXPR_STRING + BOOT::|npProduct| BOOT::PARSE-TEST BOOT::|npIterators| + BOOT::PARSE-EXPR BOOT::|npWhile| + BOOT::|displayPreCompilationErrors| BOOT::PARSE-N_TEST + BOOT::|npForIn| BOOT::PARSE-REP_TEST BOOT::|npGives| + BOOT::PARSE-FIL_TEST BOOT::|npLogical| BOOT::PARSE-SUBEXPR + BOOT::|npExpress| BOOT::PARSE-FID BOOT::PARSE-RULE + BOOT::|npExpress1| BOOT::PARSE-HEADER + BOOT::|npCommaBackSet| BOOT::PARSE-RULE1 BOOT::|npQualType| + VMLISP:$TOTAL-GC-TIME BOOT::|npADD| + BOOT::|npConditionalStatement| + BOOT::|npQualifiedDefinition| BOOT::|npPushId| + BOOT::|npVariable| BOOT::|npDefinitionOrStatement| + BOOT::|npAssignVariable| BOOT::|npColon| + BOOT::|npAssignment| BOOT::|profileDisplay| + BOOT:|TimeStampString| BOOT::|computeDomainVariableAlist| + BOOT::MONITOR-READINTERP BOOT::|npSingleRule| + BOOT::MONITOR-UNTESTED BOOT::|npDefTail| BOOT::|npQuiver| + BOOT::MONITOR-PERCENT BOOT::|npDef| BOOT::|npStatement| + BOOT::|npImport| BOOT::|npTyping| BOOT::|npItem| + BOOT::|npQualDef| BOOT::|npAssign| BOOT::MONITOR-AUTOLOAD + BOOT::|npDefinition| BOOT::MONITOR-RESULTS + BOOT::MONITOR-END BOOT::|npPop3| BOOT::MONITOR-INITTABLE + BOOT::|npAtom2| BOOT::|npInfixOperator| BOOT::|npPower| + BOOT::MONITOR-HELP BOOT::|npMatch| BOOT::MONITOR-REPORT + BOOT::|npMdef| BOOT::|reportInstantiations| + BOOT::|npPrimary2| BOOT::?DOMAINS BOOT::|?domains| + BOOT::|npSuch| BOOT::|npMDEF| BOOT::|npDisjand| + BOOT::|npInfixOp| BOOT::|npDiscrim| + BOOT::|clearConstructorAndLisplibCaches| + BOOT::|npVariableName| BOOT::|clearConstructorCaches| + BOOT::|clearClams| BOOT::|clearCategoryCaches| + BOOT::|cacheStats| BOOT::|reportAndClearClams| + BOOT::|traceDown| BOOT::|statRecordInstantiationEvent| + BOOT::|tc| BOOT::GET-CURRENT-DIRECTORY + BOOT::|removeAllClams| BOOT::|clamStats| BOOT::|npPop1| + BOOT::|npTrap| BOOT::|npApplication| BOOT::|npPop2| + BOOT::|npApplication2| BOOT::WRITE-WARMDATA + BOOT::WRITE-INTERPDB BOOT::|npAssignVariablelist| + BOOT::|clearHashReferenceCounts| BOOT::|npSignature| + BOOT::|pfNothing| BOOT::|npSigItemlist| BOOT::|npEncl| + BOOT::|npBDefinition| BOOT::|npPrefixColon| BOOT::|npNext| + BOOT::|allOperations| BOOT::WRITE-CATEGORYDB + BOOT::WRITE-OPERATIONDB BOOT::WRITE-BROWSEDB + BOOT::WRITE-COMPRESS BOOT::INITIAL-GETDATABASE + BOOT::CATEGORYOPEN BOOT::BROWSEOPEN BOOT::OPERATIONOPEN + BOOT::INTERPOPEN BOOT::COMPRESSOPEN + BOOT::CREATE-INITIALIZERS BOOT::|poNoPosition| + BOOT::|saveDependentsHashTable| BOOT::|saveUsersHashTable| + BOOT::|mkTopicHashTable| BOOT::TOKEN-STACK-SHOW + BOOT::|system| BOOT::|terminateSystemCommand| + BOOT::|getSystemCommandLine| BOOT::TERMCHR + BOOT::IOSTREAMS-SHOW BOOT::|displayExposedConstructors| + BOOT::|finalizeDocumentation| BOOT::REDUCE-STACK-SHOW + BOOT::CLEAR-HIGHLIGHT BOOT::RESET-HIGHLIGHT BOOT::RESTART0 + START BOOT::|libraryFileLists| BOOT::|waitForViewport| + BOOT::|setViewportProcess| + BOOT::|installStandardTestPackages| BOOT::|printCopyright| + BOOT::AKCL-VERSION BOOT::SET-RESTART-HOOK + BOOT::|undoINITIALIZE| BOOT::|simpCategoryTable| + BOOT::|simpTempCategoryTable| BOOT::COMPFIN + BOOT::INPUT-CLEAR BOOT::|genTempCategoryTable| BOOT::|cc| + BOOT::|initNewWorld| BOOT::|genCategoryTable| + BOOT::|dbOpsExposureMessage| BOOT::|htSayUnexposed| + BOOT::|NRTmakeCategoryAlist| + BOOT::|NRTgenFinalAttributeAlist| BOOT::|dcSizeAll| + BOOT::|initialiseIntrinsicList| BOOT::|tempLen| + BOOT::|changeDirectoryInSlot1| BOOT::|NRTaddDeltaCode| + BOOT::|ncIntLoop| BOOT::SPECIALCASESYNTAX + BOOT::|newFortranTempVar| BOOT::|currentSP| + BOOT::|elapsedTime| BOOT::|traceUp| + BOOT::|getIntrinsicList| BOOT::|getInterpMacroNames| + BOOT::|synonymSpad2Cmd| BOOT::|interpFunctionDepAlists| + BOOT::NPPPG BOOT::|isFalse| BOOT::NPPPF BOOT::NPPPFF + BOOT::|printDashedLine| BOOT::|satBreak| BOOT::|up| + BOOT::|getWorkspaceNames| BOOT::|getParserMacroNames| + BOOT::|oldCompilerAutoloadOnceTrigger| BOOT::|TrimCF| + BOOT::|displayWorkspaceNames| BOOT::UP + BOOT::|displayWarnings| BOOT::|buildGloss| + BOOT::|nextInterpreterFrame| BOOT::|down| + BOOT::|displayFrameNames| BOOT::DOWN + BOOT::|previousInterpreterFrame| BOOT::SAME BOOT::|same| + BOOT::|mkUsersHashTable| BOOT::|allConstructors| + BOOT::|frameNames| BOOT::|sayShowWarning| BOOT::|credits| + BOOT::|mkDependentsHashTable| + BOOT::|buildDefaultPackageNamesHT| + BOOT::|dbAugmentConstructorDataTable| FOAM:|fiGetDebugVar| + BOOT::|menuButton| BOOT::|htSaturnBreak| BOOT::|random| + BOOT::|dbConsExposureMessage| BOOT::|mkSigPredVectors| + BOOT::FIRST-ERROR BOOT::|writeSaturnPrefix| BOOT::|on| + BOOT::|offDisk| BOOT::|htBigSkip| BOOT::PARSE-PROGRAM + BOOT::IN-META BOOT::|traceReply| BOOT::|?t| + BOOT::SKIP-BLANKS BOOT::|pspacers| BOOT::NEXT-LINES-SHOW + BOOT::|resetCounters| BOOT::PARSE-DEST_REF + BOOT::SPAD_SHORT_ERROR BOOT::|pcounters| + BOOT::SPAD_LONG_ERROR BOOT::INIT-BOOT/SPAD-READER + BOOT::NEXT-LINES-CLEAR BOOT::|resetTimers| + BOOT::|resetSpacers| BOOT::|ptimers| + BOOT::|PARSE-Expression| + BOOT::|oldParserAutoloadOnceTrigger| BOOT::|boot-LEXPR| + BOOT::|reportCount| BOOT::NEW-LEXPR1 BOOT::|spadReply| + BOOT::|listConstructorAbbreviations| BOOT::BOOT-SKIP-BLANKS + BOOT::|updateFromCurrentInterpreterFrame| + BOOT::PARSE-ARGUMENT-DESIGNATOR BOOT::PARSE-KEYWORD + BOOT::PARSE-SPADSTRING + BOOT::|initializeInterpreterFrameRing| BOOT::READ-SPAD-1 + BOOT::READBOOT BOOT::|reportWhatOptions| + BOOT::TERSYSCOMMAND BOOT::|PARSE-NewExpr| + BOOT::|makeInitialModemapFrame| + BOOT::|createCurrentInterpreterFrame| + BOOT::|getParserMacros| BOOT::|clearCmdCompletely| + BOOT::|clearCmdAll| BOOT::|clearMacroTable| + BOOT::|initializeSystemCommands| BOOT::|htSayHrule| + BOOT::|htEndTable| BOOT::|mkMenuButton| BOOT::|runspad| + BOOT::|htBeginTable| BOOT::|ncTopLevel| + BOOT::|spadStartUpMsgs| BOOT::|initializeRuleSets| + BOOT::|loadExposureGroupData| + BOOT::|statisticsInitialization| BOOT::|ut| + BOOT::|printStatisticsSummary| BOOT::|printStorage| + BOOT::|prTraceNames| BOOT::|spad| BOOT::|spadpo| + BOOT::|intloop| BOOT::|off| BOOT::|htEndTabular| + BOOT::|htSaySaturnAmpersand| BOOT::|page| + BOOT::|clearFrame| BOOT::|getSaturnExampleList| + BOOT::|saturnTERPRI| BOOT::|bcSadFaces| BOOT::YEARWEEK + BOOT::|npBPileDefinition| BOOT::|npTypified| + BOOT::|npVariablelist| BOOT::|npTagged| BOOT::|bcvspace| + BOOT::|npTypeStyle| BOOT::|npColonQuery| BOOT::|npPretend| + BOOT::|npRestrict| BOOT::|npCoerceTo| BOOT::|npRelation| + BOOT::|npFirstTok| BOOT::|npVoid| BOOT::|npSLocalItem| + BOOT::NPPCG BOOT::|npLocalItemlist| BOOT::|npFix| + BOOT::NPPCFF BOOT::|npDefaultItemlist| BOOT::|npSynthetic| + BOOT::|npAmpersandFrom| BOOT::|npBy| BOOT::|npLet| + BOOT::|npTypeVariable| BOOT::|npSignatureDefinee| + BOOT::|npAtom1| BOOT::|npConstTok| BOOT::|npLocalItem| + BOOT::|npLocalDecl| BOOT::|npExport| BOOT::|npLocal| + BOOT::|npInline| BOOT::|npFree| BOOT::|npInterval| + BOOT::|npSegment| BOOT::|npArith| BOOT::|npBreak| + BOOT::|npDefaultItem| BOOT::|npDefaultDecl| + BOOT::|npReturn| BOOT::|npSemiBackSet| + BOOT::|npSDefaultItem| BOOT::|npTypeVariablelist| + BOOT::|npPileDefinitionlist| BOOT::|npDefinitionlist| + BOOT::|npComma| BOOT::|npSymbolVariable| BOOT::|npId| + BOOT::|npSum| BOOT::|npTerm| BOOT::|npRemainder| + BOOT::|npIterate| BOOT::|npLoop| BOOT::|npSuchThat| + BOOT::|npSelector| BOOT::|npIterator| BOOT::|npSigItem| + BOOT::|npSigDecl| BOOT::|statRecordLoadEvent| + BOOT::|computeElapsedTime| BOOT::|npLambda| + BOOT::|computeElapsedSpace| BOOT::|popTimedName| + BOOT::|npBacksetElse| BOOT::|peekTimedName| + BOOT::|npQualTypelist| BOOT::|npPileExit| BOOT::|npExit| + BOOT::|statisticsSummary| BOOT::|displayHeapStatsIfWanted| + BOOT::|update| BOOT:RESTART BOOT:|version| BOOT:/EMBEDREPLY + BOOT:NEXTINPUTLINE BOOT:|Category| BOOT::|intUnsetQuiet| + BOOT::|intSetQuiet| BOOT:POP-REDUCTION + BOOT::|intSetNeedToSignalSessionManager| + BOOT::|intNewFloat| BOOT::|leaveScratchpad| BOOT::|ncError| + BOOT::|incConsoleInput| BOOT:NEXT-CHAR + BOOT::|inclmsgCmdBug| BOOT::|inclmsgIfBug| + BOOT::|inclmsgFinSkipped| BOOT::|inclmsgConsole| + COMPILER::GAZONK-NAME HELP BOOT:ADVANCE-CHAR + BOOT::|rbrkSch| BOOT::|lbrkSch|)) +(PROCLAIM + '(FTYPE (FUNCTION (*) *) BOOT::|makeSpadCommand| BOOT::/RF + BOOT::|/RQ,LIB| VMLISP:$ERASE BOOT::|mkGrepPattern1| + BOOT::|nothingFoundPage| BOOT::|dbNotAvailablePage| + BOOT::|htSetCache| BOOT::NEXT-LINE BOOT::/EF + BOOT::INIT-MEMORY-CONFIG BOOT::/RQ BOOT::|newGoGet| + BOOT::|goGet| BOOT::|dbShowOps| BOOT::|oPage| BOOT::|aPage| + BOOT::|buildLibdb| BOOT::|emptySearchPage| + BOOT::|conOpPage1| BOOT::|conPage| BOOT::|kPage| + BOOT::|genSearch| BOOT::|dbShowCons| BOOT::|form2HtString| + BOOT::|bcFinish| BOOT::|Undef| BOOT:META-SYNTAX-ERROR)) +(PROCLAIM + '(FTYPE (FUNCTION (T) *) BOOT::|numArgs| + BOOT::|formatSignatureArgs0| BOOT::|formatSignatureArgs| + BOOT::|sayWidth| BOOT::SRCABBREVS BOOT::|bcMatrixGen| + BOOT::|bcwords2liststring| BOOT::|bcGenExplicitMatrix| + BOOT::|bcGen| BOOT::|bcInputMatrixByFormulaGen| + BOOT::|bcReadMatrix| BOOT::|systemCommand| + BOOT::|safeWritify| BOOT::|unAbbreviateKeyword| + BOOT::|replacePercentByDollar| BOOT::|e04ucfSolve| + BOOT::|brightPrint0AsTeX| BOOT::|sayDisplayStringWidth| + BOOT:GET-TOKEN BOOT::|initializeLisplib| BOOT::|getMsgTag| + BOOT::|poFileName| BOOT::|mac0InfiniteExpansion,name| + BOOT::|NRTtypeHack| BOOT::|getMsgPos2| BOOT::|e02agfSolve| + BOOT::|c02agfGen| BOOT:NUMOFARGS BOOT::|c02affSolve| + BOOT::|c02affGen| BOOT::|c02agfSolve| BOOT::|c05adfGen| + BOOT::|outputTran| BOOT::|replaceSharpCalls| + BOOT::/UNTRACE-0 BOOT::|doReplaceSharpCalls| BOOT::DEFTRAN + BOOT::LIST2STRING BOOT::DEF-WHERECLAUSELIST BOOT::DEF-ISNT + BOOT::|quoteSuper| BOOT::|quoteSub| BOOT::MK_LEFORM + BOOT::MK_LEFORM-CONS BOOT::|aggSuper| + BOOT::|oldParseString| BOOT::|outformWidth| BOOT::|aggSub| + BOOT::|agggwidth| BOOT::|agggsuper| BOOT::|agggsub| + BOOT::|obj2String| BOOT::|compileFileQuietly| + BOOT::|exptSub| BOOT::|mathPrint| BOOT::|rootSub| + BOOT::|parseTransform| BOOT::|overbarWidth| + BOOT::MONITOR-EVALAFTER BOOT::|overlabelWidth| + BOOT::|object2String| BOOT::|e02aefGen| BOOT::/TRACE-0 + BOOT::LENGTH2STR BOOT::|matSub| BOOT::/MKINFILENAM + BOOT::|qTSuper| BOOT::|qTSub| BOOT::|sayMSGNT| + VMLISP:BPINAME BOOT::|e01safSolve| BOOT::|e01befSolve| + BOOT::|linkToHTPage| BOOT::|killHTPage| + BOOT::|startReplaceHTPage| BOOT::|e01dafSolve| + BOOT::|startHTPopUpPage| BOOT::|e01bffSolve| + BOOT::|e01bafGen| BOOT::|e01sefGen| BOOT::|e01bhfGen| + BOOT::|e01bhfSolve| BOOT::|e01dafGen| BOOT::|e01bgfGen| + BOOT::|e01befGen| BOOT::|e02dcfColdGen| BOOT::|e02bafGen| + BOOT::|e02agfGen| BOOT::|e02befColdGen| BOOT::|e02ajfSolve| + BOOT::|e02ddfColdGen| BOOT::|numMapArgs| + BOOT::|e02befSolve| BOOT::|e02dcfSolve| + BOOT::|e02ddfWarmGen| BOOT::|e02adfSolve| + BOOT::|e02aefSolve| BOOT::|e02ddfSolve| BOOT::|e02bafSolve| + BOOT::|e02bcfSolve| BOOT::|e02ahfGen| BOOT::|e02gafSolve| + BOOT::|e02bbfGen| BOOT::|e02adfGen| BOOT::|e02defGen| + BOOT::|e02ahfSolve| BOOT::|e02bdfGen| BOOT::|e02akfGen| + BOOT::|e02dafGen| BOOT::|e02bdfSolve| BOOT::|e02dffGen| + BOOT::|e02akfSolve| BOOT::|asyJoinPart| BOOT::|printLine| + BOOT::|sockSendWakeup| BOOT::|sockGetFloat| + BOOT::PRINT-LINE BOOT::SOCK-SEND-WAKEUP + BOOT::SOCK-GET-FLOAT BOOT::|/tb| BOOT::|/ry| BOOT::|/rx| + BOOT::|/cxd| BOOT::/FOOBAR BOOT::/CX BOOT::NEWNAMTRANS + BOOT::|htMakeInputList| BOOT::SPAD-MODETRAN + BOOT::|popSatOutput| BOOT::|subrname| BOOT::SOCK-GET-INT + BOOT::OPEN-SERVER BOOT::|protectedEVAL| + BOOT::|setOutputTex| BOOT::|setOutputFortran| BOOT::|set| + BOOT::|setLinkerArgs| BOOT::|protectSymbols| + BOOT::|protectedSymbolsWarning| BOOT::|setStreamsCalculate| + BOOT::|setOutputFormula| BOOT::|setNagHost| + BOOT::|setFunctionsCache| BOOT::|spadType| BOOT::|spadSys| + BOOT::|mkGrepFile| BOOT::|mkGrepPattern1,addOptions| + BOOT::|mkGrepPattern1,remUnderscores| + BOOT::|mkUpDownPattern| BOOT::|mkUpDownPattern,fixchar| + BOOT::|cSearch| BOOT::|verbatimize| + BOOT::|pmParseFromString,flatten| + BOOT::|htCommandToInputLine| BOOT::|detailedSearch| + BOOT::|docSearch| BOOT::|form2HtString,fnTailTail| + BOOT::|form2HtString,fn| BOOT::|sexpr2HtString| + BOOT::|kInvalidTypePage| BOOT::|args2LispString,fnTailTail| + BOOT::|sexpr2LispString,fn| BOOT::|args2LispString| + BOOT::|sexpr2LispString| BOOT::|sexpr2HtString,fn| + BOOT::|spleI| BOOT::|dbComments| BOOT::|sockGetInt| + BOOT::|parseAndEvalStr| BOOT::|parseAndEvalStr1| + BOOT::|d01gafSolve| BOOT::|d01apfGen| BOOT::|d01fcfSolve| + BOOT::|d01asfGen| BOOT::|d02bbfSolve| BOOT::|d02rafGen| + BOOT::|d02kefGen| BOOT::|d02kefSolve| BOOT::|d02ejfGen| + BOOT::|d02gbfSolve| BOOT::|d02bbfGen| BOOT::|d02bhfGen| + BOOT::|d02rafSolve| BOOT::|d02ejfSolve| BOOT::|d02bhfSolve| + BOOT::|d02gafGen| BOOT::|d02gbfGen| BOOT::|d02gafSolve| + BOOT::|d02cjfGen| BOOT::|d02cjfSolve| BOOT::|d03edfControl| + BOOT::|d03edfSolve| BOOT::|d03eefSolve| + BOOT::|d03edfLongGen| BOOT::|d03eefGen| + BOOT::|d03edfShortGen| BOOT::|e01sefSolve| + BOOT::|lnFileName| BOOT::|e01bgfSolve| BOOT::|e01safGen| + BOOT::|e01bffGen| BOOT::|e01bafSolve| + BOOT::|pfGlobalLinePosn| BOOT::|quoteString| + BOOT::|postTran| BOOT::|decodeScripts| BOOT::|htGloss| + BOOT::|htTutorialSearch| BOOT::|postInSeq| + BOOT::|htTextSearch| BOOT::|htGreekSearch| + BOOT::|postMakeCons| BOOT::|postCategory,fn| + BOOT::|htShowFunctionPageContinued| BOOT::|htCacheSet| + BOOT::|htSetFunCommand| BOOT::|listOfStrings2String| + BOOT::|htCacheOne| BOOT::|htShowSetTree| + BOOT::|htShowSetTreeValue| BOOT::|postBigFloat| + BOOT::|htSetInteger| BOOT::|chkRange| BOOT::|postConstruct| + BOOT::|postSlash| BOOT::|htCacheAddChoice| + BOOT::|startHTPage| BOOT::|htSetLinkerArgs| + BOOT::|htSetOutputCharacters| BOOT::|htSetKernelWarn| + BOOT::|htSetKernelProtect| BOOT::|htSetExpose| + BOOT::|htSetInputLibrary| BOOT::|htSetOutputLibrary| + BOOT::|htSetHistory| SPAD-SAVE BOOT:|OsEnvGet| + BOOT:|LispCompile| BOOT:|LispCompileFile| + BOOT::|condErrorMsg| BOOT:|LispLoadFile| + BOOT:|LispLoadFileQuietly| BOOT::MONITOR-RESTORE + BOOT::|brightPrintCenterAsTeX| BOOT::|brightPrint0| + BOOT::|sayWidth,fn| BOOT::|brightPrintCenter| + BOOT::|clearClam| BOOT::|brightPrintHighlightAsTeX| + BOOT::|brightPrintHighlight| BOOT::|sayDisplayWidth,fn| + BOOT::|sayDisplayWidth| BOOT::INIT-LIB-FILE-GETTER + BOOT::INIT-FILE-GETTER BOOT::|entryWidth| BOOT::FILE-RUNNER + BOOT::|editFile| BOOT::|readForDoc| BOOT::|checkNumOfArgs| + BOOT::|openServer| BOOT::|removeBackslashes| + BOOT::|checkAddBackSlashes| BOOT::/RF-1 BOOT::|docreport| + BOOT::|ExecuteInterpSystemCommand| BOOT::|pfFileName| + BOOT::|InterpExecuteSpadSystemCommand| BOOT::|alistSize| + BOOT::|parseTranList| BOOT::|parseOr| BOOT::|parseIf| + BOOT::|parseImplies| BOOT::|parseEquivalence| + BOOT::|parseLhs| BOOT::|parseAnd| BOOT::|parseLeftArrow| + BOOT::|parseUpArrow| BOOT::|parseNotEqual| BOOT::|parseNot| + BOOT::|parseDollarNotEqual| BOOT::|parseDollarGreaterEqual| + BOOT::|parseDollarLessEqual| BOOT::|parseGreaterEqual| + BOOT::|parseLessEqual| BOOT::|scriptTranRow1| + BOOT::|scriptTran| BOOT::|scriptTranRow| + BOOT::|parseExclusiveOr| BOOT::QUOTE-IF-STRING + BOOT::|dbConformGenUnder| BOOT::|listOfEntries| + BOOT::|conformString| BOOT::|dbConformGen| + BOOT::|evalableConstructor2HtString| BOOT::|halfWordSize| + BOOT::|fortFormatCharacterTypes,mkCharName| + BOOT::|opPageFast| + BOOT::|fortFormatCharacterTypes,par2string| VMLISP::MAKEDIR + VMLISP::DELETE-DIRECTORY VMLISP::GET-IO-INDEX-STREAM + VMLISP::GET-INPUT-INDEX-STREAM VMLISP::DIRECTORY? + BOOT::|c05pbfGen| BOOT::|c05nbfGen| BOOT::|c05pbfSolve| + BOOT::|c05nbfSolve| BOOT::|e02dafSolve| BOOT::|c06ebfGen| + BOOT::|c06ebfSolve| BOOT::|c06gsfGen| BOOT::|c06gsfSolve| + BOOT::|c06ekfSolve| BOOT::|c06eafSolve| BOOT::|c06gqfGen| + BOOT::|c06ecfGen| BOOT::|c06fpfGen| BOOT::|c06frfSolve| + BOOT::|c06gbfSolve| BOOT::|c06fqfGen| BOOT::|c06gqfSolve| + BOOT::|c06eafGen| BOOT::|c06gcfGen| BOOT::|c06gcfSolve| + BOOT::|c06gbfGen| BOOT::|c06fufGen| BOOT::|s01eafGen| + BOOT::|s21bafGen| BOOT::|c06fpfSolve| BOOT::|s17dcfGen| + BOOT::|c06fqfSolve| BOOT::|s18defGen| BOOT::|c06frfGen| + BOOT::|s14bafGen| BOOT::|s18dcfGen| BOOT::|s17dhfGen| + BOOT::|c06ecfSolve| BOOT::|s21bdfGen| BOOT::|c06fufSolve| + BOOT::|c06ekfGen| BOOT::|s21bcfGen| BOOT::|sGen| + BOOT::|s17dgfGen| BOOT::|d01anfGen| BOOT::|d01ajfGen| + BOOT::|d01aqfGen| BOOT::|d01gafGen| BOOT::|d01bbfGen| + BOOT::|s21bbfGen| BOOT::|d01amfGen| BOOT::|s17dlfGen| + BOOT::|d01alfGen| BOOT::|d01fcfGen| BOOT::|d01akfGen| + BOOT::|d01gbfGen| BOOT::|d01gbfSolve| VMLISP::|npPC| + VMLISP::|npPP| BOOT::|exp2FortOptimizeArray| + BOOT::|fortError1| BOOT::|fortPre1| BOOT::|spadcall1| + BOOT::|fortPreRoot| BOOT::|checkPrecision| + BOOT::|fix2FortranFloat| BOOT::|normalizeStatAndStringify| + BOOT::|mkParameterList,par2string| BOOT::|f02wefSolve| + BOOT::|f02ajfGen| BOOT::|printAny| BOOT::|f02adfGen| + BOOT::|e02dffSolve| BOOT::|printString| BOOT::|f04jgfGen| + BOOT::|f04qafGen| BOOT::|f04asfGen| BOOT::|summary| + BOOT::|show| BOOT::|showSpad2Cmd| BOOT::|f04qafSolve| + BOOT::|f04mbfGen| BOOT::|f04fafGen| BOOT::|f04arfGen| + BOOT::|f04adfSolve| BOOT::|fixObjectForPrinting| + BOOT::|savesystem| BOOT::|escapeSpecialChars| + BOOT::|f04mcfSolve| BOOT::|encodeItem| BOOT::|f04atfGen| + BOOT::|form2LispString| BOOT::|f04adfGen| + BOOT::|concatWithBlanks| BOOT::|withAsharpCmd| + BOOT::|f04jgfSolve| BOOT::|extendLocalLibdb| + BOOT::|deleteFile| BOOT::|compileAsharpCmd1| + BOOT::|f04mcfGen| BOOT::|f04arfSolve| BOOT::|frame| + BOOT::|frameSpad2Cmd| BOOT::|addNewInterpreterFrame| + BOOT::|getEnv| BOOT::|f04asfSolve| BOOT::|f04fafSolve| + BOOT::|f04mbfSolve| BOOT::|f04atfSolve| BOOT::|f07fdfSolve| + BOOT::|obey| BOOT::|f07aefGen| BOOT::|buildLibdbString| + BOOT::|f07aefSolve| BOOT::|f07fefGen| BOOT::|f07adfSolve| + BOOT::|f07adfGen| BOOT::|dbReadComments| + BOOT::|f07fefSolve| BOOT::|f07fdfGen| BOOT::|s17defGen| + BOOT::|f01qdfSolve| BOOT::|f01rcfSolve| BOOT::|f01mafGen| + BOOT::|f01rdfGen| BOOT::|f01mafSolve| BOOT::|f01brfGen| + BOOT::|f01mcfGen| BOOT::|f02axfGen| BOOT::|f02aefSolve| + BOOT::|f02akfGen| BOOT::|f02abfSolve| BOOT::|f02bjfGen| + BOOT::|bcErrorPage| BOOT::|f02xefGen| BOOT::|form2String| + BOOT::|f02aafSolve| BOOT::|dbSourceFile| + BOOT::MAKE-REASONABLE BOOT::|f02ajfSolve| + BOOT::|f02axfSolve| BOOT::|f02affSolve| BOOT::|downlink| + BOOT::BRIGHTPRINT-0 BOOT::|f02wefGen| + BOOT::|conform2String| BOOT::|f02akfSolve| + BOOT::|f02adfSolve| BOOT::|f02aafGen| + BOOT::|dbSpecialExports| BOOT::|f02agfGen| + BOOT::|f02bjfSolve| BOOT::|buildLibdbConEntry| + BOOT::|f02agfSolve| BOOT::|dbSpecialDescription| + BOOT::|f02xefSolve| BOOT::|f02abfGen| BOOT::|f02bbfGen| + BOOT::|mkButtonBox| BOOT::|f02awfSolve| + BOOT::|assignSlotToPred| BOOT::|f02bbfSolve| + BOOT::|f02aefGen| BOOT::|f02awfGen| BOOT::|f02affGen| + BOOT::|dbMkEvalable| BOOT::|mkEvalable| + BOOT::|conPageChoose| BOOT::KILL-TRAILING-BLANKS + BOOT::|ySearch| BOOT::|aSearch| BOOT::|close| + BOOT::|kSearch| BOOT::|compileBoot| BOOT::|aokSearch| + BOOT::|showNamedConstruct| + BOOT::|reportOpsFromUnitDirectly1| BOOT::|oSearch| + BOOT::|tabsToBlanks| BOOT::|underscoreDollars| + BOOT::|mkGrepTextfile| BOOT::|reportOpsFromUnitDirectly0| + BOOT::|replaceGrepStar| BOOT::|grepSource| BOOT::|xSearch| + BOOT::|pSearch| BOOT::|dSearch| BOOT::|doSystemCommand| + BOOT::|standardizeSignature| BOOT::|conPageFastPath| + BOOT::|conPageConEntry| BOOT::|quickForm2HtString| + BOOT::|dbAttr| BOOT::|e02ajfGen| BOOT::|pluralize| + BOOT::|parseTran| BOOT::|e02defSolve| + BOOT::|dbSpecialOperations| BOOT::|issueHTStandard| + BOOT::|justifyMyType| BOOT::|getCallBackFn| + BOOT::|bcDifferentiateGen| BOOT::|bcIndefiniteIntegrateGen| + BOOT::|htMakeErrorPage| BOOT::|issueHT| + BOOT::|setOutputAlgebra| BOOT::|bcDraw2DparGen| + BOOT::|ExecuteSpadSystemCommand| BOOT::|bcDraw3Dpar1Gen| + BOOT::|bcProductGen| BOOT::|ts| BOOT::|bcRealLimitGen| + BOOT::|e02zafGen| BOOT::|bcSumGen| BOOT::|bcDraw3DparGen| + BOOT::|bcDraw3DfunGen| BOOT::|aggwidth| BOOT::WIDTH + BOOT::|bcDefiniteIntegrateGen| BOOT::|bcSeriesGen| + BOOT::|subspan| BOOT::|bcPuiseuxSeriesGen| + BOOT::|bcLaurentSeriesGen| BOOT::|superspan| + BOOT::|bcSeriesByFormulaGen| BOOT::|bcNotReady| + BOOT::|bcDraw2DfunGen| BOOT::|bcTaylorSeriesGen| + BOOT::|bcDraw2DSolveGen| BOOT::KCL-OS-ENV-GET + BOOT::|bcComplexLimitGen| BOOT::|saturnPRINTEXP| + BOOT::|bcSeriesExpansionGen| BOOT::COMPILE-BOOT-FILE + BOOT::|bcCreateVariableString| BOOT::|bcGenEquations| + BOOT::|vConcatSuper| BOOT::BOOT-LOAD + BOOT::|bcSolveNumerically1| BOOT::|bcLinearSolveEqnsGen| + BOOT::|bcMakeUnknowns| BOOT::|bcInputSolveInfo| + BOOT::|bcInputEquationsEnd| BOOT::|bcSystemSolveEqns1| + BOOT::|bcLinearSolveEqns1| BOOT::|bcVectorGen| + BOOT::|printBasic| BOOT::|subSuper| BOOT::|tr| + BOOT::|bcLinearSolveMatrix1| BOOT::|stringList2String| + BOOT::|bcString2HyString2| BOOT::|bcwords2liststring,fn| + BOOT::|linkGen| BOOT::|optCallEval| BOOT::|tokType| + BOOT::|timedEvaluate| BOOT::|roundStat| + BOOT::|bracketString| BOOT::|e02bcfGen| BOOT::|e02gafGen| + BOOT::|e02bbfSolve| VMLISP:OBEY BOOT::|e04ycfSolve| + BOOT::|e04nafSolve| BOOT::|e04dgfSolve| BOOT::|e04fdfGen| + BOOT::|e04gcfGen| BOOT::|NRTevalDomain| BOOT::|e04fdfSolve| + BOOT::|e04mbfSolve| BOOT::|e04nafGen| BOOT::|e04gcfSolve| + BOOT::|e04ucfGen| BOOT::|e04jafGen| BOOT::|e04mbfGen| + BOOT::|e04jafSolve| BOOT::|e04dgfGen| BOOT::|e04ycfGen| + BOOT::|f01rdfSolve| BOOT::|f01mcfSolve| BOOT::|f01qdfGen| + BOOT::|f01qcfGen| BOOT::|f01qefGen| BOOT::|f01rcfGen| + BOOT::|f01refSolve| BOOT::|f01qefSolve| BOOT::|e02zafSolve| + BOOT::|f01qcfSolve| BOOT::|f01refGen| BOOT::|f01brfSolve| + BOOT::|poGlobalLinePosn| BOOT:|sayString| + BOOT::|incHandleMessage| BOOT::|pred2English| + BOOT::|prefix2String0| BOOT::|form2StringLocal| + BOOT::|formatOpType| BOOT::|form2String1| BOOT::|ncTag| + BOOT::|ncAlist| BOOT::|tuple2String,f| + BOOT::|formatAttributeArg| BOOT::|formString| + BOOT::|form2StringWithPrens| BOOT::|prefix2String| + BOOT::|form2StringAsTeX| BOOT::|prefix2StringAsTeX|)) +(PROCLAIM + '(FTYPE (FUNCTION (*) T) BOOT::|bcConform| BOOT:STREAM-EOF + BOOT::|categoryParts| BOOT:IOCLEAR BOOT:SAY BOOT:MOAN + BOOT::|centerNoHighlight| BOOT:CROAK BOOT::INTERRUPT + BOOT::LISP-BREAK-FROM-AXIOM BOOT:META VMLISP:NILFN + BOOT::MAKE-DATABASE BOOT::|defaultTargetFE| BOOT::/DUPDATE + BOOT::/UPDATE BOOT::/MONITOR VMLISP:$FILEP VMLISP:CALLBELOW + BOOT::|systemError| BOOT::|listSort| + BOOT::|asCategoryParts| BOOT::RDEFOUTSTREAM + BOOT::RDEFINSTREAM VMLISP::SETQERROR BOOT::|throwMessage| + BOOT::TOPLEVEL BOOT::|getDomainSigs| + BOOT::|getInheritanceByDoc| BOOT::|showImp| + BOOT::|showFrom| BOOT::|getDomainDocs| BOOT::|grepFile| + BOOT::|printRecordFile| BOOT::|wasIs| + BOOT::|htFile2RecordFile| BOOT::|inputFile2RecordFile| + BOOT::|htFile2InputFile| BOOT::|bcComments| + BOOT::|bcNameTable| BOOT::|dbSayItemsItalics| + BOOT::|htPred2English| BOOT::|interpret| + BOOT::|Enumeration,LAM| VMLISP:VMREAD VMLISP:RKEYIDS + BOOT::/RP BOOT::MONITOR-TESTED BOOT::MONITOR-RESET + BOOT::MONITOR-DISABLE BOOT::MONITOR-ENABLE + BOOT::|returnStLFromKey| BOOT::MAKE-MONITOR-DATA + BOOT::|level| BOOT::LEVEL BOOT::|resolveTT| + BOOT::|isLegitimateMode| BOOT::|hasFileProperty| + BOOT::|coerceConvertMmSelection| BOOT::|canCoerce| + BOOT::|selectMms1| BOOT::|canCoerceFrom| BOOT::MAKE-TOKEN + BOOT::MAKE-LINE BOOT::|centerAndHighlight| BOOT::|getOpDoc| + BOOT::MAKE-STACK BOOT::|firstNonBlankPosition| + BOOT::MAKE-XDR-STREAM BOOT::INITROOT + BOOT::|EnumerationCategory,LAM| BOOT::|Mapping| + BOOT::|RecordCategory,LAM| BOOT::|Union| + BOOT::|UnionCategory,LAM| BOOT::|displayCategoryTable| + BOOT::MAKE-REDUCTION BOOT::READ-A-LINE BOOT::|dbPresentOps| + BOOT::|buildBitTable| BOOT::|htBlank| + BOOT::|dbMakeContrivedForm| BOOT::|dcSize| BOOT::|sum| + BOOT::|args2HtString| BOOT::|dc| BOOT::|bcNameCountTable| + VMLISP::MAKE-LIBSTREAM BOOT::|nextown1| BOOT::|next1| + BOOT::|incAppend1| BOOT::|synonym| BOOT::|grepConstruct| + VMLISP::LOTSOF BOOT::|htBeginMenu| BOOT::|bcCon| + BOOT::|koOps| BOOT::|dbWriteLines| BOOT::|catsOf| + BOOT::|getDomainOpTable| BOOT:|PlainError| + BOOT:|PlainPrint| BOOT::|htInitPageNoScroll| + BOOT:|ReadLispExpr| BOOT::|conSpecialString?| + BOOT::|htSayStandard| BOOT:|StreamFlush| BOOT:|NewPathname| + BOOT:|SessionPathname| BOOT::|domainsOf| + BOOT::|dbPresentCons| READLINE BOOT:|StringConcat| + BOOT::|htBcLinks| BOOT::|pluralSay| + BOOT::|getConstructorExports| BOOT::|sublisFormal| + BOOT::NEXT-META-LINE BOOT::|htLispLinks| + BOOT::META-META-ERROR-HANDLER BOOT::|dbHeading| + BOOT::NEXT-BOOT-LINE BOOT::|concat| BOOT::SPAD_SYNTAX_ERROR + BOOT::BOOT BOOT::|htQuery| BOOT::SPAD + BOOT::|htSayIndentRel| BOOT::|bcConPredTable| + BOOT::|htSaySaturn| BOOT::|dbSayItems| BOOT::|simpHasPred| + BOOT::|start| BOOT::|protectedPrompt| + BOOT::|htpMakeEmptyPage| BOOT::|htMakeButton| + BOOT::|htSayIfStandard| BOOT::|htSay| BOOT::|incZip1| + BOOT::|incIgen1| BOOT::|incRgen1| + BOOT::|runOldAxiomFunctor| BOOT:|fillerSpaces| + BOOT::|incLude1| FOAM::MAKE-FOAMPROGINFOSTRUCT + BOOT::|bcPred| BOOT::|sayNewLine|)) +(PROCLAIM + '(FTYPE (FUNCTION (T) CHARACTER) VMLISP:EBCDIC VMLISP:NUM2CHAR + BOOT::LINE-CURRENT-CHAR)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) FIXNUM) BOOT::LINE-NEW-LINE)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) FIXNUM) BOOT::|rwrite128|)) +(PROCLAIM + '(FTYPE (FUNCTION (T) STRING) BOOT::|stripSpaces| BOOT::LINE-BUFFER + BOOT::DROPTRAILINGBLANKS)) +(PROCLAIM + '(FTYPE (FUNCTION (T) T) BOOT::|form2FenceQuoteTail| + BOOT::|combineMapParts| BOOT::|form2FenceQuote| + BOOT::|mkMapPred| BOOT::|formatOpConstant| + BOOT::|formJoin2| BOOT::|axOpTran| BOOT::|axFormatOpList| + BOOT::|axFormatOp| BOOT::|optcomma| + BOOT::|displayTranModemap| + BOOT::|makeInternalMapMinivectorName| + BOOT::|cleanUpSegmentedMsg| BOOT::|makeDefaultDef| + BOOT::|getDefaultingOps| BOOT::|getOpSegment| + BOOT::|removeIsDomainD| BOOT::|formatSignatureAsTeX| + BOOT::|axFormatType| BOOT::|sayRemoveFunctionOrValue| + BOOT::|pvarCondList| BOOT::|makeTypeSequence| + BOOT::|makeArgumentIntoNumber| BOOT::|axFormatAttrib| + BOOT::|categoryForm?| BOOT::|axFormatCondOp| BOOT:OPTIONAL + BOOT::|axFormatPred| BOOT::|fileConstructors| + BOOT::SOURCEPATH BOOT::|untraceMapSubNames| BOOT:LASTELEM + BOOT::|mapPredTran| BOOT::|makeDefaultArgs| + BOOT::|stripType| BOOT::|dqUnitCopy| BOOT::|mkAliasList| + BOOT::|dqUnit| BOOT::|modemapToAx| + BOOT::|isDefaultPackageName| BOOT::|getEqualSublis| + BOOT::|myWritable?| BOOT::|getInfovec| BOOT::|predTran| + BOOT::|fnameReadable?| BOOT::|hasDefaultPackage| + BOOT::|compFailure| BOOT::|fnameType| + BOOT::|setExtendedDomains| + BOOT::|simplifyMapConstructorRefs| BOOT::|fnameName| + BOOT::|StringToDir| + BOOT::|spad2AxTranslatorAutoloadOnceTrigger| + BOOT::|fnameDirectory| + BOOT::|simplifyMapPattern,unTrivialize| BOOT::|DirToString| + BOOT::|isPatternArgument| BOOT::|htQuote| + BOOT::|isConstantArgument| BOOT::|frameName| + BOOT::|objValUnwrap| BOOT::|htMakePage| + BOOT::|PARSE-LedPart| BOOT::|htpPropertyList| + BOOT::|analyzeMap,f| BOOT::|PARSE-NudPart| + BOOT::|PARSE-Expr| BOOT::|bcHt| BOOT::|getIteratorIds| + BOOT::|getUserIdentifiersInIterators| + BOOT::|htpInputAreaAlist| BOOT::|getUserIdentifiersIn| + BOOT::|PARSE-GliphTok| BOOT::|kePageOpAlist| + BOOT::|fileNameStrings| BOOT::|inclmsgCannotRead| + BOOT::MAKE-SYMBOL-OF BOOT:MATCH-ADVANCE-STRING + BOOT::|removeUndoLines| BOOT::STACK-SIZE BOOT:NOTE + BOOT::|histFileErase| BOOT::|histInputFileName| + BOOT::STACK-STORE BOOT::|readHiFi| BOOT::|restoreHistory| + BOOT::STACK-UPDATED BOOT::|clearSpad2Cmd| BOOT::|getToken| + BOOT::|makeHistFileName| BOOT::|changeHistListLen| + BOOT::|showHistory| BOOT::|setIOindex| BOOT::|saveHistory| + BOOT::|PARSE-NBGliphTok| BOOT::|dewritify,dewritifyInner| + BOOT::|setHistoryCore| BOOT::|charDigitVal| + BOOT::|dewritify,is?| BOOT::|writify| BOOT::|history| + BOOT::|gensymInt| BOOT::|dewritify| BOOT::TOKEN-NONBLANK + BOOT::|undoFromFile| BOOT::FLOATEXPID + BOOT::|e02dffSolve,fy| BOOT::|spadClosure?| + BOOT::|bustUnion| BOOT::|writify,writifyInner| + BOOT::|undoChanges| BOOT::|undoInCore| BOOT::|getSlot1| + BOOT::|writifyComplain| BOOT::|unwritable?| + BOOT::|dbSpecialDisplayOpChar?| BOOT::|removeAttributes| + BOOT:|pathname| BOOT::|isLeaf| BOOT::|srcPosDisplay| + BOOT::|srcPosColumn| BOOT::|transformOperationAlist| + BOOT::|srcPosSource| BOOT::|sayNonUnique| + BOOT::|compDefWhereClause,removeSuchthat| + BOOT::|srcPosLine| BOOT::|compTuple2Record| + BOOT::|srcPosFile| BOOT::|mkAtreeValueOf1| BOOT::|center80| + BOOT::|loadFunctor| + BOOT::|compDefWhereClause,transformType| + BOOT::|mkCategoryPackage,gn| + BOOT::|updateCategoryFrameForConstructor| BOOT:|sayFORMULA| + BOOT::|convertOpAlist2compilerInfo| + BOOT::|getCategoryOpsAndAtts| BOOT::|lispize| + BOOT::|getSrcPos| BOOT::|mustInstantiate| + BOOT::|isSystemDirectory| BOOT:ASSOCRIGHT BOOT::|getFlag| + BOOT::|getMsgToWhere| BOOT::|mkExplicitCategoryFunction,fn| + BOOT::|updateCategoryFrameForCategory| BOOT:CURSTRMLINE + BOOT::|alreadyOpened?| BOOT::|msgImPr?| BOOT::|Operators| + BOOT::|mkAtree1| BOOT::|getLineText| BOOT::|pfSourceText| + BOOT::|toFile?| BOOT::|getMsgArgL| BOOT::|poGetLineObject| + BOOT:BRIGHTPRINT BOOT::|getLinePos| + BOOT::|loadIfNecessaryAndExists| BOOT::|lnPlaceOfOrigin| + BOOT::|makeLeaderMsg| BOOT::|putInLocalDomainReferences| + BOOT::|pfPosOrNopos| BOOT::|killNestedInstantiations| + BOOT::|NRTputInTail| BOOT::|quotifyCategoryArgument| + BOOT::|getLisplibVersion| BOOT::|getMsgPrefix| + BOOT::|unInstantiate| BOOT::|asTupleAsVector| + BOOT::|lisplibDoRename| BOOT::|asTupleSize| + BOOT::|finalizeLisplib| BOOT::|disallowNilAttribute| + BOOT::|asTupleNewCode0| BOOT::|processKeyedError| + BOOT::|toScreen?| BOOT::|compileConstructor1| + BOOT::|compileDocumentation| BOOT::|transformREPEAT| + BOOT::|line?| BOOT::|readLibPathFast| + BOOT::|modemap2Signature| BOOT::|transformCollect| + BOOT::|msgLeader?| BOOT::|compileConstructor| + BOOT::|initToWhere| BOOT::|initImPr| + BOOT::|putDatabaseStuff| BOOT::|e02defSolve,fxy| + BOOT::|getMsgPosTagOb| BOOT::|pfIdSymbol| + BOOT::|mkAtreeExpandMacros| BOOT::|getMsgPos| + BOOT::|macApplication| BOOT::|isInterpMacro| + BOOT::|getMsgFTTag?| BOOT::|leader?| + BOOT::|pf0ApplicationArgs| BOOT::|atree2EvaluatedTree| + BOOT::|remFile| BOOT::|pfMLambda?| BOOT::|whichCat| + BOOT::|pfApplicationOp| BOOT::|removeBindingI| + BOOT::|addArgumentConditions,fn| BOOT::|macId| + BOOT:STRMBLANKLINE BOOT::|getUnname1| BOOT:STRMSKIPTOBLANK + BOOT::|remLine| BOOT::|pfSourcePosition| + BOOT::|spadCompileOrSetq| BOOT::|getMsgKey?| + BOOT::|mac0Get| BOOT::|getMsgKey| BOOT::|compile| + BOOT::|evaluateType| BOOT::|constructMacro| + BOOT::|poPosImmediate?| BOOT::|pfMLambdaBody| + BOOT::|poNopos?| BOOT::|evaluateType1| + BOOT::|pf0MLambdaArgs| BOOT:NEXTSTRMLINE + BOOT::|evaluateSignature| BOOT::|macMacro| + BOOT::|poLinePosn| BOOT::|failCheck| BOOT::|pfNothing?| + BOOT::|compile,isLocalFunction| BOOT::|macSubstituteOuter| + BOOT::|erMsgSep| BOOT::|pfMacroRhs| BOOT::|mkConstructor| + BOOT::|showMsgPos?| BOOT::|pfMacroLhs| BOOT::|macExpand| + BOOT:IS_GENVAR BOOT::|mkEvalableMapping| BOOT::|macLambda| + BOOT::|getMsgInfoFromKey| BOOT::|evaluateType0| + BOOT::|getStFromMsg| BOOT::|getUnnameIfCan| + BOOT::|macWhere| BOOT::|tabbing| BOOT::|getMsgLitSym| + BOOT::|pfApplication?| BOOT::|getPosStL| BOOT::|pfMacro?| + BOOT::|doItIf,localExtras| BOOT::|getMsgText| + BOOT::|mkEvalableUnion| BOOT::|pfLambda?| + BOOT::|getMsgPrefix?| BOOT::|mkEvalableRecord| + BOOT::|pfWhere?| BOOT::|getPreStL| BOOT::|makeOrdinal| + BOOT::|mac0GetName| BOOT::|getAndEvalConstructorArgument| + BOOT::|msgOutputter| BOOT::|pfLeaf?| + BOOT::|mkEvalableCategoryForm| BOOT::|getMsgTag?| + BOOT::|devaluateDeeply| BOOT::|pfLeafPosition| + BOOT::|compDefineFunctor1,FindRep| BOOT::|pfAbSynOp| + BOOT::|listOutputter| BOOT::|pfTypedId| + BOOT::|processChPosesForOneLine| BOOT::|pf0LambdaArgs| + BOOT::|e02dffSolve,fx| BOOT::|getModeSetUseSubdomain| + BOOT::MKQSADD1 BOOT::|getModeSet| BOOT::|poCharPosn| + BOOT::|posPointers| BOOT::|NRTgenInitialAttributeAlist| + BOOT::|makeMsgFromLine| BOOT::THETA_ERROR + BOOT::|mkRationalFunction| BOOT::MACROEXPANDALL + BOOT::|isCategoryPackageName| BOOT::|erMsgSort| + BOOT::|isAVariableType| BOOT::|msgNoRep?| + BOOT::|getPrincipalView| BOOT::|To| BOOT::|hitListOfTarget| + BOOT::SUBANQ BOOT::|From| BOOT::|domainDepth| + BOOT::|NRTgetLocalIndexClear| BOOT::|constructSubst| + BOOT::|containsVars| BOOT::|evalMmDom| + BOOT::|abbreviationsSpad2Cmd| + BOOT::|formatUnabbreviatedSig| BOOT::|optFunctorBody| + BOOT::|optimize| BOOT::|emptyAtree| BOOT::|templateParts| + BOOT::|dqToList| BOOT::|dqConcat| BOOT::|isHomogeneousList| + BOOT::|isUncompiledMap| BOOT::|printMms| + BOOT::|getSymbolType| BOOT::/UNTRACE-REDUCE + BOOT::|matchMmCond| BOOT::|object2Identifier| + BOOT::|selectMostGeneralMm| BOOT::|fixUpTypeArgs| + BOOT::|handleLispBreakLoop| BOOT::TRACEOPTIONS BOOT:REMDUP + BOOT::|evalMmStack| BOOT::SHOWBIND BOOT::DROPENV + BOOT::UNVEC BOOT::|noSharpCallsHere| + BOOT::|untraceDomainConstructor| BOOT:CURMAXINDEX + BOOT::|isDomain| BOOT::|getFunctionSourceFile| + BOOT::|isMap| BOOT::HACKFORIS1 BOOT::HACKFORIS + BOOT::|containsVars1| BOOT::|orderMmCatStack| + BOOT::|evalMmStackInner| BOOT::DEF-IN2ON + BOOT::|new2OldTran| BOOT::|resolveTypeList| + BOOT::|newConstruct| BOOT::|newIf2Cond| BOOT::|newDef2Def| + BOOT::|asTupleNew0| BOOT::DEF-MESSAGE1 BOOT::LIST2STRING1 + BOOT::DEF-WHERE BOOT::DEF-SEQ BOOT::SEQOPT BOOT::DEF-IS + BOOT::DEF-EQUAL BOOT::DEF-MESSAGE BOOT::DEF-CATEGORY + BOOT::DEF-REPEAT BOOT::DEF-COND BOOT::DEF-LESSP + BOOT::SMINT-ABLE BOOT::DEF-COLLECT BOOT::DEF-STRING + BOOT::|Zeros| BOOT::DEF-SETELT BOOT::DEF-RENAME1 + BOOT::DEF-ELT BOOT::|DEF-:| BOOT::DEF-ADDLET + BOOT::|quoteWidth| BOOT::DEF-INSERT_LET1 BOOT::|boxSuper| + BOOT::DEF-WHERECLAUSE BOOT::DEF-STRINGTOQUOTE + BOOT::|boxSub| BOOT::DEF-INSERT_LET BOOT::LIST2CONS-1 + BOOT::|bootTransform| BOOT::|concatWidth| + BOOT::DEF-IS-REMDUP1 BOOT::|altSuperSubWidth| + BOOT::|altSuperSubSuper| BOOT::|concatbWidth| + BOOT::LIST2CONS BOOT::|altSuperSubSub| BOOT::DEF-IS-REMDUP + BOOT::|concatSuper| BOOT::DEF-IS-EQLIST + VMLISP:RECOMPILE-DIRECTORY BOOT::|concatSub| + BOOT::|new2OldDefForm| BOOT::|binomWidth| + BOOT::|binomSuper| BOOT::DEF-SELECT BOOT::|binomSub| + BOOT::COMP-TRAN-1 BOOT::PUSHLOCVAR BOOT::COMP-EXPAND + BOOT::|canCacheLocalDomain,domargsglobal| VMLISP:MAKE-CVEC + BOOT::|inSuper| BOOT::COMP-NEWNAM BOOT::COMP-TRAN + BOOT::|inSub| BOOT::COMP-FLUIDIZE BOOT::|addInputLibrary| + BOOT::|inWidth| BOOT::|dropInputLibrary| + BOOT::|openOutputLibrary| BOOT::|moveORsOutside| + BOOT::|stepSuper| BOOT::|outputTranMatrix| + BOOT::|fracwidth| BOOT::|stepSub| BOOT::|compQuietly| + BOOT::|listOfPatternIds| BOOT::|fracsuper| BOOT::COMP-1 + BOOT::|getOplistForConstructorForm| BOOT::|stepWidth| + BOOT::COMP-2 VMLISP:TRIMSTRING BOOT::|maprin0| + BOOT::|compAndDefine| BOOT::|abbreviate| BOOT::|fracsub| + BOOT::|exptSuper| BOOT::|mathPrintTran| + BOOT::|COMP,FLUIDIZE| VMLISP:COMP370 BOOT::|exptWidth| + BOOT::|rootWidth| BOOT::|with| BOOT::|exptNeedsPren| + BOOT::|minusWidth| VMLISP:|log| BOOT::|maprin| + BOOT::|loadDependents| BOOT::|concatTrouble,fixUp| + BOOT::|loadIfNecessary| VMLISP:MBPIP BOOT::|timesWidth| + BOOT::|rootSuper| BOOT::|interactiveModemapForm,fn| + BOOT::|largeMatrixAlist| VMLISP:QSORT BOOT::|sumWidth| + VMLISP:PLACEP BOOT::LOG10 BOOT::|aggWidth| BOOT::|zagWidth| + BOOT::|pi2Width| BOOT::|rebuildCDT| BOOT::|LZeros| + BOOT::|e02zafSolve,fmu| BOOT::|signatureTran| + BOOT::|destructT| BOOT::|userError| BOOT::|clearAllSlams| + BOOT::|displayComp| VMLISP:HKEYS BOOT::|mkErrorExpr| + BOOT::|pi2Sup| BOOT::|compOrCroak1,compactify| + BOOT::|pi2Sub| BOOT::|convertSpadToAsFile| + BOOT::|overbarSuper| BOOT::|outputOp| BOOT::|compiler| + BOOT::|resolveTMRed1| BOOT::|resolveTTRed3| + BOOT::|fnameWritable?| BOOT::MONITOR-EVALBEFORE + VMLISP:UPCASE BOOT::|interpOp?| BOOT::|pathnameName| + BOOT::|pathnameDirectory| BOOT::SPADSYSNAMEP VMLISP:STATEP + BOOT::|compileSpad2Cmd| BOOT::MONITOR-BLANKS + BOOT::|piWidth| BOOT::|newType?| BOOT::WHOCALLED + BOOT::|charyTopWidth| VMLISP:FBPIP BOOT::|bubbleType| + BOOT::|putWidth| BOOT::|piSup| BOOT::OPTIONS2UC + BOOT::|overlabelSuper| BOOT::|pathnameType| + BOOT::|spadThrowBrightly| BOOT::/OPTIONS BOOT::|piSub| + BOOT::/UNEMBED-Q BOOT::/UNEMBED-1 + BOOT::|typeIsASmallInteger| BOOT::|indefIntegralWidth| + BOOT::|indefIntegralSup| BOOT::|isSimple| VMLISP:UNEMBED + BOOT::|indefIntegralSub| BOOT::|primitiveType| + BOOT::|mkAtree| BOOT::/UNTRACELET-2 + BOOT::|outputTranIterate| BOOT::|errorRef| + VMLISP:RE-ENABLE-INT BOOT::/UNTRACELET-1 BOOT::|intWidth| + BOOT::|NRTgetLocalIndex| BOOT::|getOutputAbbreviatedForm| + BOOT::|isFluid| VMLISP:IVECP BOOT::|iterVarPos| + BOOT::|remWidth| VMLISP:LIST2VEC BOOT::|matWidth| + BOOT::|asTupleAsList| BOOT::|outputTranIteration| + VMLISP:LISTOFQUOTES BOOT::|upcase| BOOT::|intSup| + BOOT::|reassembleTowerIntoType| BOOT::|upor| + BOOT::|matSuper| BOOT::|hasFormalMapVariable,hasone?| + BOOT::|intSub| VMLISP:IS-CONSOLE BOOT::|coerceUnion2Branch| + BOOT::|PushMatrix| BOOT::MKPROGN BOOT::|uncons| + VMLISP:MAKE-ABSOLUTE-FILENAME + BOOT::|retract2Specialization| BOOT::|sigma2Width| + VMLISP:FUNARGP BOOT::|syminusp| BOOT::|NRTassocIndex| + BOOT::|resolveTypeListAny| BOOT::MONITOR-PRINTREST + BOOT::|extwidth| BOOT::|varsInPoly| BOOT::|sigma2Sup| + BOOT::|stackWarning| BOOT::SMALL-ENOUGH BOOT::|extsuper| + BOOT::|sigma2Sub| BOOT::|extsub| BOOT::|sigmaWidth| + BOOT::/INITUPDATES BOOT::|sigmaSup| BOOT::IS_SHARP_VAR + BOOT::|sigmaSub| BOOT::|retract1| BOOT::|qTWidth| VMLISP:LN + BOOT::|decomposeTypeIntoTower| BOOT::|transcomparg| + BOOT::FUNLOC BOOT::|stringWidth| + BOOT::|mathprintWithNumber| BOOT::COND-UCASE + VMLISP:PROPLIST BOOT::|texFormat| BOOT::|bubbleConstructor| + BOOT::|isSubForRedundantMapName| BOOT::|isDomainOrPackage| + BOOT::|dispfortexp| BOOT::|isInterpOnlyMap| + BOOT::|formulaFormat| BOOT::|boxWidth| BOOT::|sayMath| + BOOT::|domainZero| BOOT::|domainOne| VMLISP:COPY + VMLISP:DOWNCASE BOOT::|e04ucfSolve,fg| VMLISP:SHUT + BOOT::|unescapeStringsInForm| + BOOT::|executeInterpreterCommand| VMLISP:REROOT + BOOT::|parseAndInterpret| VMLISP:DIG2FIX + BOOT::|ncSetCurrentLine| BOOT::|pvarsOfPattern| + BOOT::|htEscapeString| BOOT::|e01safSolve,f| + BOOT::|e04ucfSolve,fe| BOOT::|e01befSolve,f| + BOOT::|e01bffSolve,g| VMLISP:LOG2 BOOT::|e01dafSolve,g| + BOOT::|e01dafSolve,f| VMLISP:SIZE VMLISP:EOFP + BOOT::|e01bffSolve,f| VMLISP:RSHUT BOOT::|e04ucfSolve,fd| + BOOT::|e01bhfSolve,f| BOOT::|objVal| BOOT::|getValue| + BOOT::|getMode| BOOT::|getUnname| VMLISP:DIGITP + BOOT::|bottomUp| BOOT::|mkAtreeNode| VMLISP:VEC2LIST + VMLISP:MAKE-VEC VMLISP:GCMSG BOOT::|retract| + BOOT::|getUnionOrRecordTags| BOOT::|e02dcfColdSolve,h| + BOOT::|e02ajfSolve,f| BOOT::|polyVarlist| + BOOT::|e02befColdSolve,f| BOOT::|removeQuote| + BOOT::|e02dcfColdSolve,g| BOOT::|e02dcfColdSolve,f| + BOOT::|isMapExpr| BOOT::|getTarget| + BOOT::|e02ddfColdSolve,f| BOOT::|isType| + BOOT::|bottomUpElt| BOOT::|e02adfSolve,f| + BOOT::|retractAtree| BOOT::|bottomUpPercent| + BOOT::|fetchOutput| BOOT::|e02aefSolve,f| + BOOT::|e02gafSolve,fb| BOOT::|bottomUpUseSubdomain| + BOOT::|getBasicObject| BOOT::|bottomUpCompile| + BOOT::|e02ddfSolve,h| BOOT::|e02ddfSolve,g| + BOOT::|e02bafSolve,g| BOOT::|e02bcfSolve,f| + BOOT::|getBasicMode| BOOT::|e02ddfSolve,f| BOOT::|unwrap| + BOOT::|isWrapped| BOOT::|e02bafSolve,f| BOOT::GETZEROVEC + BOOT::|containsPolynomial| + BOOT::|getModeOrFirstModeSetIfThere| BOOT::|e02ahfSolve,f| + BOOT::|e04ucfSolve,fc| BOOT::|wrapMapBodyWithCatch| + BOOT::|e02agfSolve,i| BOOT::|e02agfSolve,h| + BOOT::|e02bdfSolve,f| BOOT::|containsVariables| + BOOT::|e02bbfSolve,f| BOOT::|wrapped2Quote| + BOOT::|objCodeVal| BOOT::|objCodeMode| + BOOT::|e02akfSolve,f| BOOT::|asyUnTuple| + BOOT::|asyTypeUnitList| BOOT::|asyComma?| + BOOT::|interactiveModemapForm| BOOT::|isTaggedUnion| + BOOT::|asIsCategoryForm| BOOT::|opOf| BOOT::|e02agfSolve,g| + BOOT::|asySubstMapping| BOOT::|e02agfSolve,f| + BOOT::|asyTypeMapping| BOOT::|asyCATEGORY| + BOOT::|e02dafSolve,fp| BOOT::|asyShorten| + BOOT::|e02dafSolve,fmu| BOOT::|createAbbreviation| + BOOT::|astran| BOOT::|asMakeAlist| BOOT::|asyParents| + BOOT::|asyDocumentation| BOOT::|asyConstructorModemap| + BOOT::|asytran| BOOT::|asyPredTran| BOOT::|asyPredTran1| + BOOT::|as| BOOT::|asytranLiteral| BOOT::|asytranEnumItem| + BOOT::|constructor?| BOOT::|hackToRemoveAnd| + BOOT::|asyGetAbbrevFromComments| BOOT::|intern| + BOOT::|asyTypeJoinPartPred| BOOT::|zeroOneConversion| + BOOT::|asyArgs| BOOT::|asyArg| BOOT::|asyFindAttrs| + BOOT::|asyAncestors| BOOT::|asyAncestorList| + BOOT::|asyTypeJoinItem| BOOT::|isLowerCaseLetter| + BOOT::|abbreviation?| BOOT::|asAll| BOOT::|error| + BOOT::|asyTypeJoinPartIf| BOOT::|asyType| + BOOT::|asyTypeJoin| BOOT::|asyTypeJoinPartExport| + BOOT::|asyCattranOp| BOOT::|predicateBitRef| + BOOT::|asyMkpred| BOOT::|asyLooksLikeCatForm?| + BOOT::|asyCosigType| BOOT::|setVector12| + BOOT::|asMakeAlistForFunction| BOOT::|optFunctorPROGN| + BOOT::|getAttributesFromCATEGORY| BOOT::|worthlessCode| + BOOT::|mySort| BOOT::|optFunctorBody,CondClause| + BOOT::|mkDomainFormer| BOOT::|mkNiladics| BOOT::|optCall| + BOOT::|explodeIfs| BOOT::|folks| BOOT::|mkVector| + BOOT::|asyExtractDescription| BOOT::|asyCattran1| + BOOT::|simpCattran| BOOT::|asyCattran| BOOT::|asyCatItem| + BOOT::|asyExportAlist| BOOT::FOOBAR + BOOT::|bootAbsorbSEQsAndPROGNs| BOOT::|displayDatabase| + BOOT::|bootAbsorbSEQsAndPROGNs,flatten| BOOT::|bootTran| + BOOT::|asyConstructorArg| BOOT::|bootLabelsForGO| + BOOT::GP2COND BOOT::|bootPROGN| BOOT::|asyTypeMakePred| + BOOT::|bootSEQ| BOOT::|tryToRemoveSEQ| BOOT::|nakedEXIT?| + BOOT::|asyConstructorArgs| BOOT::|mergeCONDsWithEXITs| + BOOT::STREAM2UC BOOT::|asyTypeJoinStack| BOOT::|bootCOND| + BOOT::STRINGREST BOOT::|bootAND| BOOT::|boot2Lisp| + BOOT::|bootOR| BOOT::|asyTypeJoinPartWith| BOOT::|bootIF| + BOOT::|asyCosig| BOOT::|bootAND,flatten| + BOOT::|bootPushEXITintoCONDclause| BOOT::|asyIsCatForm| + BOOT::|bootOR,flatten| BOOT::|asCategoryParts,exportsOf| + BOOT::|removeEXITFromCOND| BOOT::|flattenCOND| BOOT::/FLAG + BOOT::|extractCONDClauses| BOOT::|hashable| + BOOT::|trimString| BOOT::|mergeableCOND| + BOOT::|knownEqualPred| BOOT::|removeEXITFromCOND?| + BOOT::CPSAY BOOT::|zeroOneConvert| BOOT::/EDIT + BOOT::|domainForm?| BOOT::|makeByteWordVec| + BOOT::DECIMAL-LENGTH BOOT::|unabbrevAndLoad| BOOT::READLISP + BOOT::|abbQuery| BOOT::SPAD-EVAL BOOT::/TRANSNBOOT + BOOT::SPAD-MDTR-2 BOOT::SPAD-MDTR-1 BOOT::/TRANSPAD + BOOT::|setAutoLoadProperty| BOOT::/TRANSMETA + BOOT::|getConstructorUnabbreviation| BOOT::|getLisplibName| + BOOT::OPTIMIZE&PRINT + BOOT::|getPartialConstructorModemapSig| BOOT::UNCONS + BOOT::|maximalSuperType| BOOT::|getImmediateSuperDomain| + BOOT::|augmentLowerCaseConTable| BOOT::|isNameOfType| + BOOT::|objMode| BOOT::|isDomainValuedVariable| + BOOT::|packageForm?| BOOT::|sayMSG2File| BOOT::|concatList| + BOOT::|mkMessage| BOOT::|clearCache| BOOT::|IdentityError| + BOOT::/TRANSBOOT BOOT::|process| BOOT::|mathprint| + BOOT::ISLOCALOP-1 BOOT::|pushSatOutput| BOOT::|fracpart| + BOOT::|negintp| BOOT::|intpart| BOOT::|optRECORDELT| + BOOT::|optIF2COND| BOOT::C-TO-R BOOT::C-TO-S BOOT::S-TO-C + BOOT::CGAMMA BOOT::RGAMMA BOOT::CLNGAMMA BOOT::RLNGAMMA + BOOT::|getDomainOps| BOOT::|showGoGet| + BOOT::|showAttributes| BOOT::|showPredicates| + BOOT::|showSummary| BOOT::|getExtensionsOfDomain| + BOOT::|getDomainSeteltForm| BOOT::|getCategoriesOfDomain| + BOOT::|getDomainExtensionsOfDomain| BOOT::|bnot| + BOOT::|notDnf| BOOT::|b2dnf| BOOT::|ordList| BOOT::|bor| + BOOT::|band| BOOT::|bassert| BOOT::|notCoaf| BOOT::|list3| + BOOT::|list2| BOOT::|list1| BOOT::|dnf2pf| BOOT::|be| + BOOT::|reduceDnf| BOOT::|bassertNot| BOOT::|prove| + BOOT::|testPredList| BOOT::|nodeCount| + BOOT::|mkCircularAlist| BOOT::|clearSlam,LAM| + BOOT::|getCacheCount| BOOT::|clearLocalModemaps| + BOOT::|hashCount| BOOT::|parseAndEvalToHypertex| + BOOT::|oldParseAndInterpret| BOOT::|parseAndInterpToString| + BOOT::|parseAndEvalToStringEqNum| BOOT::|setHistory| + BOOT::|setExposeAddGroup| BOOT::|setFortDir| + BOOT::|validateOutputDirectory| BOOT::|setOutputLibrary| + BOOT::|setFortPers| BOOT::|setExposeDropConstr| + BOOT::|setExposeDropGroup| BOOT::|setExposeDrop| + BOOT::|setFortTmpDir| BOOT::|setExposeAdd| + BOOT::|setExpose| BOOT::|setInputLibrary| + BOOT::|setAsharpArgs| BOOT::|countCache| BOOT::|cgamma| + BOOT::|rgamma| BOOT::|clngammacase3| BOOT::|cgammaBernsum| + BOOT::|cgammaAdjust| BOOT::|lnrgammaRatapprox| + BOOT::|phiRatapprox| BOOT::|lnrgamma| + BOOT::|gammaRatapprox| BOOT::|gammaRatkernel| + BOOT::|gammaStirling| BOOT::|PsiIntpart| + BOOT::|isFilterDelimiter?| + BOOT::|mkDetailedGrepPattern,simp| BOOT::|cgammat| + BOOT::|isDefaultOpAtt| BOOT::|replaceTicksBySpaces| + BOOT::COT BOOT::|conform2OutputForm| BOOT::|lncgamma| + BOOT::|dbGetName| BOOT::|pfTupleList| BOOT::|pfWIfElse| + BOOT::|pfWIfThen| BOOT::|mkGrepPattern1,addWilds| + BOOT::|pfWIfCond| BOOT::|pfWIf?| BOOT::|mkGrepPattern1,g| + BOOT::|organizeByName| BOOT::|pfAssignLhsItems| + BOOT::|pfRetractToType| BOOT::|getTempPath| BOOT::|pfSexpr| + BOOT::|looksLikeDomainForm| BOOT::|pfRetractToExpr| + BOOT::|pfRetractTo?| BOOT::|pfExpression?| + BOOT::|genSearchUniqueCount| + BOOT::|pf0FlattenSyntacticTuple| BOOT::|pfSexpr,strip| + BOOT::|pmPreparse| BOOT::|dbUnpatchLines| + BOOT::|evaluateLines| BOOT::|verifyRecordFile| + BOOT::|sayDocMessage| BOOT::|recordAndPrintTest,fn| + BOOT::|pmParseFromString| + BOOT::|conLowerCaseConTranTryHarder| BOOT::|fnameExists?| + BOOT::|htTrimAtBackSlash| BOOT::|setExposeAddConstr| + BOOT::|dbBasicConstructor?| BOOT::|lfnegcomment| + BOOT::|lfcomment| BOOT::|bcStarConform| BOOT::|lfstring| + BOOT::|bcStar| BOOT::|simpBool| BOOT::|scanKeyTr| + BOOT::|extractHasArgs,find| BOOT::|lfkey| + BOOT::|scanPossFloat| BOOT::|scanCloser?| + BOOT::|bcStarSpace| BOOT::|keyword| + BOOT::|loadLibIfNotLoaded| BOOT::|lineoftoks| + BOOT::|lisp2HT| BOOT::|getCType| BOOT::|lisp2HT,fn| + BOOT::|conform2HtString| BOOT::|nextline| + BOOT::|unMkEvalable| BOOT::|int2Bool| BOOT::|keyword?| + BOOT::|htSayList| BOOT::|scanW| BOOT::|isLoaded?| + BOOT::|mkQuote| BOOT::|lfinteger| BOOT::|mkQuote,addQuote| + BOOT::|functionAndJacobian| BOOT::|lferror| + BOOT::|scanWord| BOOT::|scanTransform| + BOOT::|htPred2English,fnAttr| BOOT::|dbConname| + BOOT::|digit?| BOOT::|addSpaces| BOOT::|dbKindString| + BOOT::|lfspaces| BOOT::|stripUnionTags| BOOT::|lfid| + BOOT::|mkPredList| BOOT::|spad2lisp| + BOOT::|orderUnionEntries| BOOT::|punctuation?| + BOOT::|Record0| BOOT::|makeFort,untangle| + BOOT::|makeFort,untangle2| BOOT::|makeOutputAsFortran| + BOOT::|rdigit?| BOOT::|vec2Lists| BOOT::|npMoveTo| + BOOT::|complexRows| BOOT::|makeLispList| + BOOT::|pfSourceStok| BOOT::|vec2Lists1| + BOOT::|multiToUnivariate| BOOT::|spadTypeTTT| + BOOT::|makeUnion| BOOT::|stripNil| + BOOT::|parseAndEvalToString| + BOOT::|parseAndEvalToStringForHypertex| BOOT::|XDRFun| + BOOT::|pair2list| BOOT::|pfStringConstString| + BOOT::|pfExportDef| BOOT::|prefix2Infix| + BOOT::|pfDefinitionSequenceArgs| BOOT::|lispType| + BOOT::|pfComDefinitionDef| BOOT::|checkForBoolean| + BOOT::|npTrapForm| BOOT::|pfTransformArg| + BOOT::|vectorOfFunctions| BOOT::|pfTaggedToTyped1| + BOOT::|pfFlattenApp| BOOT::|pfTaggedToTyped| + BOOT::|pfCollectVariable1| + BOOT::|InvestigateConditions,pessimise| BOOT::|pfCollect1?| + BOOT::|d01gafSolve,f| BOOT::|pfComDefinitionDoc| + BOOT::|PrepareConditional| BOOT::|pfLoopIterators| + BOOT::|TryGDC| BOOT::|d01fcfSolve,f| BOOT::|compCategories| + BOOT::|pfHidePart| BOOT::|makeMissingFunctionEntry,tran| + BOOT::|PacPrint| BOOT::|keyItem| BOOT::|pfHide?| + BOOT::|pfDocumentText| BOOT::|pfDocument?| + BOOT::|e02dafSolve,fxy| BOOT::|pfLambdaArgs| + BOOT::|ConstantCreator| BOOT::|pfDefinitionLhsItems| + BOOT::|pf0WithWithin| BOOT::|d02bbfSolve,fb| + BOOT::|pfWithWithin| BOOT::|d02bbfSolve,fa| + BOOT::|pf0WithBase| BOOT::|d02gbfSolve,fe| + BOOT::|pfWithBase| BOOT::|pfWithWithon| BOOT::|pfNot| + BOOT::|d02kefSolve,fc| BOOT::|pfId| BOOT::|pfTupleParts| + BOOT::|d02kefSolve,fb| BOOT::|pfWhereContext| + BOOT::|InvestigateConditions| BOOT::|pfCheckArg| + BOOT::|InvestigateConditions,reshape| + BOOT::|d02kefSolve,fa| BOOT::|pfCheckId| + BOOT::|getPossibleViews| BOOT::|pfQualTypeQual| + BOOT::|ICformat| BOOT::|pfTupleListOf| + BOOT::|InvestigateConditions,mkNilT| BOOT::|pfQualTypeType| + BOOT::|pfQualType?| BOOT::|getViewsConditions| + BOOT::|pfDWhereExpr| BOOT::|ICformat,Hasreduce| + BOOT::|pfForinLhs| BOOT::|ICformat,ORreduce| + BOOT::|d02gbfSolve,fi| BOOT::|d02gbfSolve,fh| + BOOT::|pfDWhereContext| BOOT::|CategoriesFromGDC| + BOOT::|pfSymbolVariable?| BOOT::|d02rafSolve,fc| + BOOT::|pfMLambdaArgs| BOOT::|optFunctorBodyRequote| + BOOT::|d02gafSolve,ff| BOOT::|pfInlineItems| + BOOT::|d02rafSolve,fb| BOOT::|pfSemiColonBody| + BOOT::|d02rafSolve,fa| BOOT::|pfSemiColon?| + BOOT::|optFunctorBodyQuotable| BOOT::|d02gafSolve,fd| + BOOT::|pfInline| BOOT::|pf0AddBase| BOOT::|pfAddBase| + BOOT::|d02ejfSolve,fb| BOOT::|pfSemiColon| + BOOT::|pfAddAddon| BOOT::|d02ejfSolve,fa| + BOOT::|pfAddAddin| BOOT::|d02bhfSolve,fb| + BOOT::|pf0ImportItems| BOOT::|d02bhfSolve,fa| + BOOT::|pfImportItems| BOOT::|pfInline?| + BOOT::|pfReturnFrom| BOOT::|pfImport| + BOOT::|d02gafSolve,fb| BOOT::|pfListOf?| + BOOT::|pfFreeItems| BOOT::|pf0TLambdaArgs| + BOOT::|d02gafSolve,fa| BOOT::|pfTLambdaArgs| + BOOT::|pfTLambdaBody| BOOT::|pfExitNoCond| + BOOT::|pf0WrongRubble| BOOT::|pfWrongRubble| + BOOT::|pfTLambdaRets| BOOT::|pfWrongWhy| + BOOT::|pfIterateFrom| BOOT::|pfLocalItems| + BOOT::|pfAttributeExpr| BOOT::|d02cjfSolve,fb| + BOOT::|pfAttribute?| BOOT::|pfLoop| BOOT::|d02cjfSolve,fa| + BOOT::|pfDo| BOOT::|pfWDeclareDoc| BOOT::|pfSecond| + BOOT::|pfWDeclareSignature| BOOT::|pfWDeclare?| + BOOT::|pfCheckInfop| BOOT::|d03edfSolve,fd| + BOOT::|pf0CollectIterators| BOOT::|pfExport?| + BOOT::|d03edfSolve,fc| BOOT::|pfDeclPart?| + BOOT::|d03edfSolve,fa| IDENTITY BOOT::|pfDWhere?| + BOOT::|pfImport?| BOOT::|pfTyping?| BOOT::|pfSuchthat| + BOOT::|pfComDefinition?| BOOT::|pfTLambda?| BOOT::|pfWhile| + BOOT::|pfAdd?| BOOT::|pf0ExportItems| BOOT::|pfExportItems| + BOOT::|pfExpr?| BOOT::|pfWith?| BOOT::|e01sefSolve,f| + BOOT::|pf0TypingItems| BOOT::|pfTypingItems| + BOOT::|pfGetLineObject| BOOT::|lnFileName?| + BOOT::|e01bgfSolve,g| BOOT::|e01bgfSolve,f| + BOOT::|pfNopos?| BOOT::|lnExtraBlanks| + BOOT::|pfPlaceOfOrigin| BOOT::|ravel| + BOOT::|poPlaceOfOrigin| BOOT::|e01bafSolve,f| + BOOT::|pfFileName?| BOOT::|poFileName?| + BOOT::|parseAndEval| BOOT::|getDomainHash| BOOT::|aplTran1| + BOOT::|hasAplExtension| BOOT::|htpDomainConditions| + BOOT::|aplTranList| BOOT::|postDefArgs| + BOOT::|postTranScripts| BOOT::|getHtMacroItem| + BOOT::|postTranScripts,fn| BOOT::|unTuple| + BOOT::|isPackageType| BOOT::|buttonNames| + BOOT::|postcheckTarget| BOOT::|postcheck| + BOOT::|dbNonEmptyPattern| BOOT::|postBlockItemList| + VMLISP:|last| BOOT::|postBlockItem| BOOT::|postQuote| + BOOT::|postSequence| BOOT::|postTranList| + BOOT::|checkWarning| VMLISP:HASHTABLE-CLASS + BOOT::|downlinkSaturn| BOOT::|decodeScripts,fn| + BOOT::|mkUnixPattern| BOOT::|tuple2List| + BOOT::|postCapsule| BOOT::|patternCheck| BOOT::|postElt| + BOOT::|postSEGMENT| BOOT::|e04nafSolve,ff| + BOOT::|postIteratorList| BOOT::|npEqPeek| BOOT::|postForm| + BOOT::|htAllOrNum| BOOT::|postOp| BOOT::|stringize| + VMLISP:LISTOFFREES BOOT::|postTuple| BOOT::|postExit| + BOOT::|parseWord| BOOT::|postMapping| VMLISP:GENSYMP + BOOT::|postMDef| BOOT::|pfAttribute| BOOT::|postDef| + BOOT::|npRestore| BOOT::|postCategory| BOOT::|aplTran| + BOOT::|containsBang| BOOT::|htMakePathKey| BOOT::|postJoin| + BOOT::|npWConditional| BOOT::|postTransformCheck| + BOOT::|npBraced| VMLISP:PAPPP + BOOT::|chkAllNonNegativeInteger| BOOT::|postIf| + BOOT::|chkNonNegativeInteger| BOOT::|postPretend| + BOOT::|pfId?| BOOT::|postAtSign| BOOT::|npBracketed| + BOOT::|postColon| BOOT::|chkDirectory| + BOOT::|postColonColon| BOOT::|postWhere| + BOOT::|npZeroOrMore| BOOT::|postSemiColon| + BOOT::|postBlock| BOOT::|pfParts| BOOT::|deepestExpression| + BOOT::|translateYesNo2TrueFalse| BOOT::|postComma| + BOOT::|pfEnSequence| BOOT::|comma2Tuple| + BOOT::|npParenthesized| BOOT::|chkOutputFileName| + BOOT::|postReduce| BOOT::|chkPosInteger| BOOT::|postAdd| + BOOT::|pfUnSequence| BOOT::|postTupleCollect| + BOOT::|postCollect| BOOT::|postRepeat| BOOT::|postIn| + BOOT::|htShowCount| BOOT::|satisfiesUserLevel| + BOOT::|postin| BOOT::|postQUOTE| BOOT::|pfListOf| + BOOT::|postScripts| BOOT::|translateTrueFalse2YesNo| + BOOT::|postWith| BOOT::|e02dffSolve,fp| VMLISP:CHARP + BOOT::|chkNameList| BOOT::|isSymbol| BOOT::INFIXTOK + BOOT::|npQualified| BOOT::SKIP-TO-ENDIF + BOOT::|npConditional| BOOT::|stackMessageIfNone| + BOOT::PREPARSEREADLINE BOOT::|npElse| + BOOT::|translateYesNoToTrueFalse| BOOT::|npMissing| + BOOT::PREPARSEREADLINE1 BOOT::|npDDInfKey| VMLISP:RPACKFILE + BOOT::SKIP-IFBLOCK BOOT::|tokPart| BOOT::|npInfKey| + VMLISP:RECOMPILE-LIB-FILE-IF-NECESSARY BOOT::|npWith| + BOOT::|optimizeFunctionDef| BOOT::PREPARSE-ECHO + BOOT::|npCompMissing| VMLISP::LIBSTREAM-DIRNAME + BOOT::ATENDOFUNIT BOOT::PARSEPRINT BOOT::|npAdd| + BOOT::PREPARSE1 BOOT::|e02defSolve,fp| + BOOT::|htpRadioButtonAlist| BOOT::MONITOR-DATA-COUNT + BOOT::MONITOR-DATA-NAME BOOT::|htpDomainPvarSubstList| + BOOT::MONITOR-DATA-SOURCEFILE BOOT::|profileTran| + BOOT::MONITOR-DELETE BOOT::|pfSequenceToList| + BOOT::MONITOR-DATA-MONITORP BOOT::|pfSequenceArgs| + BOOT::|renamePatternVariables| BOOT::|pfSequence?| + BOOT:|LispEval| BOOT::|pfNovalueExpr| + BOOT::MONITOR-EXPOSEDP BOOT::|pfNovalue?| + BOOT::|htpDomainVariableAlist| BOOT::|pfNotArg| + BOOT::MONITOR-APROPOS BOOT::|pfNot?| BOOT::MONITOR-DATA-P + BOOT::|pfOrRight| BOOT::|pfOrLeft| BOOT::MONITOR-LIBNAME + BOOT::|pfOr?| BOOT::MONITOR-FILE BOOT::|pfAndRight| + BOOT::|pfAndLeft| BOOT::|pfAnd?| BOOT::MONITOR-SPADFILE + BOOT::|getDomainsInScope| BOOT::|pfWrong?| + BOOT::MONITOR-PARSE BOOT::|pf0LocalItems| + BOOT::MONITOR-DECR BOOT::|pfLocal?| BOOT::|pfNovalue| + BOOT::|pf0FreeItems| BOOT::|npItem1| BOOT::|pfFree?| + BOOT::|pfRestrictType| BOOT::MONITOR-INCR + BOOT::|pfRestrictExpr| BOOT::|npLetQualified| + BOOT::|isConstructorForm| BOOT::|pfRestrict?| + BOOT::|library| BOOT::MONITOR-NRLIB BOOT::|pfDefinition?| + BOOT::|unknownTypeError| BOOT::|pfAssignRhs| + BOOT::|pf0AssignLhsItems| BOOT::|pfAssign?| BOOT::|quotify| + BOOT::|pfDoBody| BOOT::|reportHashCacheStats| + BOOT::MONITOR-DIRNAME BOOT::|pfDo?| + BOOT::|mkHashCountAlist| BOOT::|pfSuchthatCond| + BOOT::|displayCacheFrequency| BOOT::|pfSuchthat?| + BOOT::MONITOR-CHECKPOINT BOOT::|pfWhileCond| + BOOT::|pfWhile?| BOOT::|pfForinWhole| + BOOT::|outputDomainConstructor| BOOT::|e02dffSolve,fmu| + BOOT::|pf0ForinLhs| BOOT::|typeTimePrin| + BOOT::|pfCheckMacroOut| BOOT::|isSomeDomainVariable| + BOOT::|pfForin?| BOOT::|displayHashtable| + BOOT::|pfCollect?| BOOT::|removeZeroOne| BOOT::|npEncAp| + BOOT::|pf0LoopIterators| BOOT::|addBlanks| + BOOT::|compHasFormat| BOOT::|loopIters2Sex| + BOOT::|noBlankBeforeP| BOOT::|pfLoop?| + BOOT::|stopTimingProcess| BOOT::|noBlankAfterP| + BOOT::|?comp| BOOT::|pfExitExpr| BOOT::|pfExitCond| + BOOT::|compileQuietly| BOOT::|sayLongOperation| + BOOT::|isAlmostSimple,setAssignment| BOOT::|pfExit?| + BOOT::|compileInteractive| BOOT::|say2PerLineThatFit| + BOOT::?COMP BOOT::|npBracked| BOOT::|pfFromdomDomain| + BOOT::|startTimingProcess| BOOT::|prEnv| + BOOT::|pfFromdomWhat| BOOT::|operationLink| BOOT::|opTran| + BOOT::|pfFromdom?| BOOT::|hasType,fn| BOOT::|pfPretendType| + BOOT::|clearCategoryCache| BOOT::|pfTuple| + BOOT::|pfPretendExpr| BOOT::|clearConstructorCache| + BOOT::|qModemap| BOOT::|pfPretend?| + BOOT::|splitListSayBrightly| BOOT::|formatModemap| + BOOT::|pfCoercetoType| BOOT::|printEnv| + BOOT::|pfCoercetoExpr| BOOT::|tabber| BOOT::|pfCoerceto?| + BOOT::|decExitLevel| BOOT::|pfTaggedExpr| + BOOT::|splitSayBrightly| BOOT::|pfTaggedTag| + BOOT::|brightPrintRightJustify| BOOT::|pfTagged?| + BOOT::|pfIfElse| BOOT::|splitSayBrightlyArgument| + BOOT::DATABASE-ABBREVIATION BOOT::|pfIfThen| + BOOT::|mkDomainConstructor| BOOT::|pfIfCond| + BOOT::|brightPrint1| BOOT::SET-FILE-GETTER BOOT::|mkList| + BOOT::|pfIf?| BOOT::|brightPrint| BOOT::|pf0TupleParts| + BOOT::|pfTuple?| BOOT::DATABASE-SOURCEFILE + BOOT::|minimalise| BOOT::|minimalise,min| + BOOT::|pfLiteral?| BOOT::|mkDevaluate| + BOOT::|minimalise,HashCheck| BOOT::|pfSymbolSymbol| + BOOT::|numberOfEmptySlots| BOOT::|pfSymbol?| + BOOT::|sayBrightlyLength1| BOOT::|hasOptArgs?| + BOOT::|npFromdom1| BOOT::|pfSuchThat2Sex| + BOOT::|CDRwithIncrement| BOOT::|npPush| + BOOT::|segmentedMsgPreprocess| BOOT::|pfOp2Sex| + BOOT::SHOWDATABASE BOOT::|pmDontQuote?| BOOT::|initCache| + BOOT::|blankIndicator| BOOT::|pfDefinitionRhs| + BOOT::|npEqKey| BOOT::|pf0DefinitionLhsItems| + BOOT::|pfApplicationArg| BOOT::SQUEEZE + BOOT::|rulePredicateTran| BOOT::|pfRuleRhs| BOOT::UNSQUEEZE + BOOT::|npDotted| BOOT::|pfRuleLhsItems| + BOOT::|constructor2ConstructorForm| BOOT::|npAngleBared| + BOOT::|pfCollectBody| BOOT::DATABASE-SPARE + BOOT::|pfCollectIterators| BOOT::|remHashEntriesWith0Count| + BOOT::|float2Sex| BOOT::DATABASE-DEFAULTDOMAIN + BOOT::|npListing| BOOT::|pfLiteralString| + BOOT::DATABASE-NILADIC BOOT::|pfLeafToken| + BOOT::DATABASE-CONSTRUCTORCATEGORY BOOT::|pfLiteralClass| + BOOT::DATABASE-OBJECT BOOT::DATABASE-MODEMAPS + BOOT::DATABASE-OPERATIONALIST BOOT::DATABASE-DEPENDENTS + BOOT::DATABASE-USERS BOOT::DATABASE-PARENTS BOOT::|tokPosn| + BOOT::|pileColumn| BOOT::|underDomainOf| + BOOT::DATABASE-PREDICATES BOOT::|underDomainOf;| + BOOT::|pileCforest| BOOT::DATABASE-ATTRIBUTES + BOOT::|enPile| BOOT::|separatePiles| + BOOT::DATABASE-DOCUMENTATION BOOT::|pilePlusComments| + BOOT::|pilePlusComment| BOOT::|insertpile| + BOOT::|lastTokPosn| BOOT::|firstTokPosn| + BOOT::|pileComment| BOOT::|isValidType;| + BOOT::|lnGlobalNum| BOOT::|lnLocalNum| + BOOT::|pfSourcePositionlist| BOOT::|isPartialMode| + BOOT::|pfSourcePositions| + BOOT::|makeOldAxiomDispatchDomain| BOOT::|lnString| + BOOT::DATABASE-ANCESTORS BOOT::|poNoPosition?| + BOOT::|poImmediate?| BOOT::|poIsPos?| BOOT::|hashString| + BOOT::DATABASE-CONSTRUCTOR BOOT::|pfPosn| + BOOT::|isLegitimateRecordOrTaggedUnion| + BOOT::|lnImmediate?| BOOT::|listOfDuplicates| + BOOT::|pfPosImmediate?| BOOT::|isPolynomialMode| + BOOT::|pfSourceToken| BOOT::|equiType| BOOT::|pfFirst| + BOOT::|getUnderModeOf| FOAM::PROCESS-IMPORT-ENTRY + BOOT::|deconstructT| BOOT::|attribute?| BOOT::TRARGPRINT + BOOT::|makeLazyOldAxiomDispatchDomain| BOOT::|eqType| + BOOT::DATABASE-P BOOT::LINE-ADVANCE-CHAR + BOOT::DATABASE-COSIG BOOT::LINE-AT-END-P BOOT::TRBLANKS + BOOT::MAKE-STRING-ADJUSTABLE BOOT::|sayMessage| + BOOT::|dropPrefix| BOOT::TRMETA1 BOOT::|mkDatabasePred| + BOOT::TRY-GET-TOKEN BOOT::TRMETA BOOT::|namestring| + BOOT::|isFreeFunctionFromMmCond| BOOT::|isSharpVarWithNum| + BOOT::|isFreeFunctionFromMm| + BOOT::|mkAlistOfExplicitCategoryOps| BOOT::LINE-P + BOOT::|mkAlistOfExplicitCategoryOps,atomizeOp| + BOOT::|flattenSignatureList| BOOT::|collectAndDeleteAssoc| + BOOT::|checkSplitBrace| BOOT::|getFirstArgTypeFromMm| + BOOT::|checkSplitPunctuation| BOOT::|checkSplitOn| + BOOT::|checkSplitBackslash| BOOT::STACK-POP + BOOT::|checkAlphabetic| BOOT::|isDomainSubst| + BOOT::UNDERSCORE BOOT::|collectComBlock| + BOOT::|getDomainFromMm| BOOT::/MDEF BOOT::STACK-TOP + BOOT::|formal2Pattern| BOOT::|finalizeDocumentation,hn| + BOOT::STACK-P BOOT::LINE-NEXT-CHAR BOOT::REDUCTION-RULE + BOOT::|checkExtractItemList| + BOOT::|recordHeaderDocumentation| BOOT::|checkIeEgfun| + BOOT::|appendOver| BOOT::|rebuild| BOOT::|checkInteger| + BOOT::|spool| BOOT::|setOutputCharacters| + BOOT::/VERSIONCHECK BOOT::INTERP-MAKE-DIRECTORY + BOOT::CACHEKEYEDMSG BOOT::XDR-STREAM-HANDLE + BOOT::|normalizeArgFileName| BOOT::|checkTrim,trim| + BOOT::XDR-STREAM-P BOOT::|checkDocError| BOOT::|bootFind| + BOOT::|checkTrim,wherePP| BOOT::|checkDecorateForHt| + BOOT::XDR-STREAM-NAME BOOT::|checkRecordHash| + BOOT::|checkIsValidType| BOOT::|normalizeTimeAndStringify| + BOOT::SETLETPRINTFLAG BOOT::|checkGetParse| + BOOT::|checkGetStringBeforeRightBrace| + BOOT::|checkGetLispFunctionName| BOOT::MAKE-DIRECTORY + BOOT::|checkLookForRightBrace| + BOOT::|checkLookForLeftBrace| BOOT::|checkFixCommonProblem| + BOOT::|checkArguments| BOOT::SHAREDITEMS BOOT::|checkTexht| + BOOT::|isVowel| BOOT::|getOfCategoryArgument| + BOOT::|checkAddPeriod| BOOT::|newMKINFILENAM| + BOOT::|getFunctionSourceFile1| BOOT::|checkDecorate| + BOOT::|pathname?| BOOT::|hasNoVowels| BOOT::|checkBalance| + BOOT::|checkSayBracket| BOOT::|pfSequence2Sex| + BOOT::|checkBeginEnd| BOOT::|pf2Sex1| BOOT::|checkIeEg| + BOOT::|pfSequence2Sex0| BOOT::|checkDocError1| + BOOT::|ruleLhsTran| BOOT::|patternVarsOf| + BOOT::|checkAddMacros| BOOT::|pfLambdaTran| + BOOT::|pfLambdaBody| BOOT::|checkSplit2Words| + BOOT::|pfLambdaRets| BOOT::|checkAddSpaces| + BOOT::|pfTypedType| BOOT::|newString2Words| + BOOT::|pfCollectArgTran| BOOT::|checkGetArgs| + BOOT::|pfTyped?| BOOT::|pfRhsRule2Sex| + BOOT::|pfLhsRule2Sex| BOOT::|checkDocMessage| + BOOT::|checkRemoveComments| BOOT::|pfRule2Sex| + BOOT::|checkTrimCommented| BOOT::|pfLambda2Sex| + BOOT::|pfDefinition2Sex| BOOT::|leftTrim| + BOOT::|pfCollect2Sex| BOOT::|checkGetMargin| + BOOT::|pfApplication2Sex| BOOT::|whoOwns| + BOOT::|pfLiteral2Sex| BOOT::|pfWhereExpr| + BOOT::|pf0WhereContext| BOOT::|pfIterate?| + BOOT::|pfReturnExpr| BOOT::|pfReturn?| BOOT::|setOutStream| + BOOT::|pfBreakFrom| BOOT::|pfBreak?| BOOT::|pfRule?| + BOOT::DATABASE-CONSTRUCTORMODEMAP BOOT::|%key| BOOT::|ppos| + BOOT::|porigin| BOOT::|pfLinePosn| BOOT::|pfCharPosn| + BOOT::|pfImmediate?| BOOT::|pfNoPosition?| BOOT::|%pos| + BOOT::|processPackage,setPackageCode| BOOT::|%fname| + BOOT::|pfname| BOOT::|%origin| BOOT::|mkRepititionAssoc| + BOOT::|%id| BOOT::|pkey| BOOT::|getCaps| + BOOT::|constructorCategory| BOOT::|evalDomain| + BOOT::|parseAtom| BOOT::|systemErrorHere| + BOOT::|coerceMap2E| BOOT::|parseConstruct| + BOOT::|parseTran,g| BOOT::|parseWhere| BOOT::|parseVCONS| + BOOT::|parseSeq| BOOT::|transSeq| BOOT::|postError| + BOOT::|parseSegment| BOOT::|parseReturn| + BOOT::|parsePretend| BOOT::|parseType| BOOT::|RecordInner| + BOOT::|parseTypeEvaluate| BOOT::|isRecord| + BOOT::|parseMDEF| BOOT::|parseLETD| BOOT::|parseLET| + BOOT::|transIs| BOOT::|CatEval| BOOT::|transUnCons| + BOOT::|parseLeave| BOOT::|mkCategory,Prepare| + BOOT::|parseJoin| BOOT::|parseJoin,fn| BOOT::|parseIsnt| + BOOT::|parseBigelt| BOOT::|parseIs| + BOOT::|DropImplementations| BOOT::|parseInBy| + BOOT::|parseIn| BOOT::|FindFundAncs| BOOT::|parseHas| + BOOT::|parseHas,mkand| BOOT::|TruthP| BOOT::|parseHas,fn| + BOOT::|parseExit| BOOT::|isCategory| BOOT::|parseDEF| + BOOT::|setDefOp| BOOT::|mkCategory,Prepare2| + BOOT::|transIs1| BOOT::|isListConstructor| + BOOT::|parseCategory| BOOT::|parseDropAssertions| + BOOT::|parseAtSign| BOOT::|parseHasRhs| BOOT::|parseCoerce| + BOOT::|getCategoryExtensionAlist0| BOOT::|parseColon| + BOOT::|getCategoryExtensionAlist| BOOT::|sayMSG| + BOOT::|parseDollarGreaterThan| BOOT::|squeeze1| + BOOT::|squeezeList| BOOT::|parseGreaterThan| + BOOT::|categoryParts,exportsOf| + BOOT::|makeSimplePredicateOrNil| BOOT::|simpHasPred,eval| + BOOT::|simpHasPred,simp| BOOT::|specialModeTran| + BOOT::|compressHashTable| BOOT::|simpOrUnion| + BOOT::|clearCategoryTable| BOOT::|transCategoryItem| + BOOT::|parseCases| BOOT::TOKEN-PRINT BOOT::|getConstrCat| + BOOT::LINE-CURRENT-SEGMENT + BOOT::|mkCategoryExtensionAlistBasic| BOOT::STACK-CLEAR + BOOT::|macrop| BOOT::|showCategoryTable| + BOOT::|clearTempCategoryTable| BOOT::TOKEN-P + BOOT::|addToCategoryTable| + BOOT::|simpHasPred,simpDevaluate| + BOOT::|mkCategoryExtensionAlist| + BOOT::|updateCategoryTableForCategory| + BOOT::|isFormalArgumentList| BOOT::|defaultingFunction| + BOOT::|getOperationAlistFromLisplib| + BOOT::|getConstructorAbbreviation| + BOOT::|predicateBitIndex| BOOT::|encodeCatform| + BOOT::|evalableConstructor2HtString,unquote| + BOOT::|orderByContainment| BOOT::|stripOutNonDollarPreds| + BOOT::|isHasDollarPred| BOOT::|transHasCode| + BOOT::|removeAttributePredicates| BOOT::|getCatAncestors| + BOOT::|makeCompactDirect1,fn| BOOT::|depthAssoc| + BOOT::|depthAssocList| BOOT::|fromHeading| + BOOT::|htAddHeading| BOOT::|infovec| BOOT::|dcData1| + BOOT::|dbDoesOneOpHaveParameters?| BOOT::|ppTemplate| + BOOT::|dbOuttran| BOOT::|bitsOf| BOOT::|mathform2HtString| + BOOT::|conname2StringList| BOOT::|dcData| + BOOT::|predicateBitIndexRemop| BOOT::|form2StringList| + BOOT::|dbConform| BOOT::|dbMapping2StringList| + BOOT::|htTab| BOOT::|orderBySubsumption| BOOT::|dcCats| + BOOT::|dcCats1| BOOT::|getLookupFun| + BOOT::|listOfCategoryEntries| BOOT::|niladicHack| + BOOT::|dbGatherDataImplementation,fn| BOOT::|NRTcatCompare| + BOOT::|dbGatherDataImplementation,gn| BOOT::|template| + BOOT::|dcAtts| BOOT::|dcSlots| BOOT::|dcOpTable| + BOOT::|getConstructorArgs| BOOT::|dbNewConname| + BOOT::|escapeString| BOOT::|nodeSize| BOOT::|fortexp0| + BOOT::|vectorSize| BOOT::|myLastAtom| + BOOT::|isDefaultPackageForm?| BOOT::|numberOfNodes| + BOOT::|dcOps| BOOT::|removeAttributePredicates,fn| + BOOT::|removeAttributePredicates,fnl| + BOOT::DATABASE-CONSTRUCTORFORM BOOT::|makeCompactDirect| + BOOT::|htSayTuple| BOOT::|dcPreds| BOOT::|htSayArgument| + BOOT::|makeDomainTemplate| BOOT::|hashTable2Alist| + BOOT::|stuffDomainSlots| BOOT::|getExportCategory| + BOOT::|koCatOps1| BOOT::|simplifyAttributeAlist| + BOOT::|hasPatternVar| BOOT::|dcAll| + BOOT::|findSubstitutionOrder?| BOOT::|isInstantiated| + BOOT::|modemap2SigConds| BOOT::|getSubstCandidates| + BOOT::|htSayExplicitExports| + BOOT::|fortFormatCharacterTypes| BOOT::|opPageFastPath| + BOOT::|fortFormatCharacterTypes,mkParameterList2| + BOOT::|exp2FortOptimizeCS1,popCsStacks| + BOOT::|kFormatSlotDomain,fn| + BOOT::|fortFormatTypes,unravel| BOOT::|formatSlotDomain| + BOOT::|getSubstSignature| BOOT::|getfortexp1| + BOOT::|fortran2Lines1| BOOT::|koOps,trim| + BOOT::|isPatternVar| BOOT::|dispfortexp1| + BOOT::|displayBreakIntoAnds| VMLISP::LIBRARY-FILE + VMLISP::GET-DIRECTORY-LIST VMLISP::PROBE-NAME + VMLISP::SPAD-FIXED-ARG VMLISP::LIBSTREAM-INDEXSTREAM + VMLISP::LIBSTREAM-INDEXTABLE VMLISP::LIBSTREAM-MODE + VMLISP::GETINDEXTABLE VMLISP::GET-INDEX-TABLE-FROM-STREAM + VMLISP::LIBSTREAM-P BOOT::|NRTassocIndexAdd| + BOOT::|optDeltaEntry,quoteSelector| BOOT::|NRToptimizeHas| + BOOT::|listOfBoundVars| BOOT::|slot1Filter,fn| + BOOT::|reverseCondlist| BOOT::|c05pbfSolve,fb| + BOOT::|genDeltaSig| BOOT::|c05pbfSolve,fa| + BOOT::|c05nbfSolve,fb| + BOOT::|NRTsubstDelta,replaceSlotTypes| + BOOT::|c05nbfSolve,fa| BOOT::|slot1Filter| + BOOT::|NRTsubstDelta| BOOT::|c06ebfSolve,f| + BOOT::|catList2catPackageList,fn| BOOT::|addConsDB| + BOOT::|changeDirectoryInSlot1,fn| + BOOT::|changeDirectoryInSlot1,sigloc| + BOOT::|NRTreplaceAllLocalReferences| BOOT::|mkSlot1sublis| + BOOT::|NRTputInLocalReferences| BOOT::|NRTputInHead| + BOOT::|NRTcheckVector| BOOT::|NRTmakeSlot1| + BOOT::|NRTisExported?| BOOT::|makePredicateBitVector| + BOOT::|catList2catPackageList| BOOT::|c06eafSolve,f| + BOOT::|NRTgetAddForm| BOOT::|c06frfSolve,h| + BOOT::|NRTaddInner| BOOT::|c06ekfSolve,f| + BOOT::|updateSlot1DataBase| BOOT::|genDeltaSpecialSig| + BOOT::|c06gbfSolve,f| BOOT::|newHasTest,evalCond| + BOOT::|c06fufSolve,hn| BOOT::|c06gcfSolve,f| + BOOT::|c06fufSolve,hm| BOOT::|c06fpfSolve,h| + BOOT::|c06fqfSolve,h| BOOT::|c06ecfSolve,f| BOOT:|length1?| + BOOT:|ListRemoveDuplicatesQ| BOOT:|ListNReverse| + BOOT::|d01gbfSolve,f| BOOT:|TableKeys| + BOOT::|ncParseAndInterpretString| BOOT::|pfPrintSrcLines| + BOOT::TERMINATOR VMLISP::MAKE-BVEC + BOOT::|exp2FortOptimizeCS| BOOT::|exp2FortOptimizeCS1| + BOOT::|expression2Fortran| BOOT::|fortranCleanUp| + BOOT::|exp2FortOptimize| BOOT::|fortPre| BOOT::|incRgen| + BOOT::|segment| BOOT::|exp2Fort1| FOAM:|printNewLine| + FOAM:|formatDFloat| FOAM:|formatSFloat| FOAM:|formatBInt| + BOOT::|npNull| FOAM:|formatSInt| BOOT::|isFloat| + BOOT::|fortExpSize| BOOT::|parseAndEval1| + BOOT::|printStats| BOOT::|mkParameterList| + BOOT::|unStackWarning| BOOT::|fortFormatIntrinsics| + BOOT::?M BOOT::|displayLines| BOOT::|?m| BOOT::|addCommas| + BOOT::|unErrorRef| BOOT::|fortran2Lines| BOOT::|uppretend| + BOOT::|typeOfType| BOOT::|checkLines| BOOT::|uptypeOf| + BOOT::|statement2Fortran| BOOT::|displayLines1| + BOOT::|upQUOTE| BOOT::|dispStatement| + BOOT::|makeCommonEnvironment,interLocalE| BOOT::|upSEQ| + BOOT::|mkMat| BOOT::|makeCommonEnvironment,interC| + BOOT::|fortSize,elen| BOOT::|quote2Wrapped| + BOOT::|deltaContour,eliminateDuplicatePropertyLists| + BOOT::|fortSize| BOOT::|checkType| BOOT::|interpOnlyREPEAT| + BOOT::|upREPEAT1| BOOT::|old2NewModemaps| BOOT::|upREPEAT0| + BOOT::|displayModemaps| BOOT::|uplocal| + BOOT::|fortFormatElseIf| BOOT::|upfree| + BOOT::|indentFortLevel| FOAM:|Halt| BOOT::|upREPEAT| + BOOT::|?modemaps| BOOT::|fortFormatIf| BOOT::|upDEF| + BOOT::|upreturn| BOOT::|uperror| BOOT::|what| + BOOT::?MODEMAPS BOOT::|whatSpad2Cmd| BOOT::|stackAndThrow| + BOOT::|makeCommonEnvironment,interE| BOOT::|constructor| + BOOT::|alqlGetParams| BOOT::|makeNonAtomic| + BOOT::|alqlGetOrigin| BOOT::|alqlGetKindString| + BOOT::|npboot| BOOT::|compAndTrace| VMLISP::SIMPLE-ARGLIST + BOOT::|string2BootTree| VMLISP::REMOVE-FLUIDS + BOOT::|f04qafSolve,f| BOOT::|getBrowseDatabase| + BOOT::|wrapSEQExit| BOOT::|compileSpadLispCmd| + BOOT::|incExitLevel| BOOT::ASEC BOOT::|mkErrorExpr,bracket| + BOOT::|displayProperties,sayFunctionDeps| BOOT::ACOT + BOOT::|displayMacro| VMLISP::QUOTESOF BOOT::|genDeltaEntry| + BOOT::|displayParserMacro| VMLISP::DEQUOTE + BOOT::|compilerMessage| BOOT::MANEXP + BOOT::|asharpConstructorName?| VMLISP::ISQUOTEDP + BOOT::|f04mcfSolve,gj| BOOT::|f04arfSolve,h| VMLISP::VARP + BOOT::|f04mcfSolve,fd| BOOT::|dbpHasDefaultCategory?| + BOOT::|stackMessage| BOOT::|dbAddChainDomain| + BOOT::|listOfIdentifiersIn| BOOT::|knownInfo| + BOOT::|outerProduct| BOOT::|f04jgfSolve,h| + BOOT::|helpSpad2Cmd| BOOT::|f04mcfSolve,fal| + BOOT::|sayAsManyPerLineAsPossible| BOOT::|extractHasArgs| + BOOT::|read| BOOT::|readSpad2Cmd| BOOT::|displayMacros| + BOOT::|warnLiteral| BOOT::|getConstructorModemap| + BOOT::GCOPY BOOT::|koAttrs,fn| BOOT::|displayOperations| + BOOT::|libConstructorSig| BOOT::|f04asfSolve,h| + BOOT::|libConstructorSig,fn| BOOT::|npProcessSynonym| + BOOT::|listOfSharpVars| BOOT::|compileAsharpLispCmd| + BOOT::|isAlmostSimple| BOOT::|libdbTrim| + BOOT::|isAlmostSimple,fn| BOOT::|isFunctor| + BOOT::|stripLisp| BOOT::|parentsOfForm| + BOOT::|isSideEffectFree| BOOT::|ltrace| BOOT::|dbMkForm| + BOOT::|trace| BOOT::|compileAsharpCmd| BOOT::MSORT + BOOT::|displayProplist,fn| BOOT::|removeEnv| BOOT::|load| + BOOT::|loadSpad2Cmd| BOOT::|dbReadLines| BOOT::?VALUE + BOOT::|help| BOOT::|?value| BOOT::|trimComments| + BOOT::|f04atfSolve,h| BOOT::|f04fafSolve,h| + BOOT::|spreadGlossText| BOOT::?PROPERTIES + BOOT::|asyExtractAbbreviation| BOOT::|getGlossLines| + BOOT::|?properties| BOOT::|asyTypeUnit| + BOOT::|getParentsForDomain| BOOT::|f04fafSolve,g| + BOOT::|prModemaps| BOOT::|asyTypeItem| + BOOT::|f04fafSolve,f| BOOT::|importFromFrame| + BOOT::|decExitLevel,removeExit0| + BOOT::|closeInterpreterFrame| BOOT::|f04mbfSolve,f| + BOOT::|tokTran| BOOT::?MODE BOOT::|parseSystemCmd| + BOOT::|?mode| BOOT::|dumbTokenize| BOOT::|edit| + BOOT::|editSpad2Cmd| BOOT::|getDefaultPackageClients| + BOOT::|displayOperationsFromLisplib| BOOT::|say2PerLine| + BOOT::|getArgumentConstructors,fn| + BOOT::|getArgumentConstructors,gn| BOOT::|display| + BOOT::|displaySpad2Cmd| BOOT::|frameEnvironment| + BOOT::|getArgumentConstructors| BOOT::|buildLibAttrs| + BOOT::|buildLibOps| BOOT::|splitIntoOptionBlocks| + BOOT::|writedb| BOOT::|getFirstWord| BOOT::|f07aefSolve,fp| + BOOT::|isSharpVar| BOOT::HAS_SHARP_VAR + BOOT::|dbHasExamplePage| BOOT::|isExistingFile| + BOOT::|mkHasArgsPred| BOOT::|lefts| BOOT::|findEqualFun| + BOOT::|dbFromConstructor?| BOOT::|f01mafSolve,f| + BOOT::|dbShowKind| BOOT::|unAbbreviateIfNecessary| + BOOT:|DeepCopy| BOOT::|evalDomainOpPred,convertCatArg| + BOOT::|dbOpsForm| BOOT::|form2Fence| BOOT::|devaluateList| + BOOT::|dbConstructorDoc,fn| FOAM:|fiStrHash| + BOOT::|dbGetInputString| BOOT::|pmTransFilter| + BOOT::|dbExtractUnderlyingDomain| FOAM:|fiGetDebugger| + BOOT::|isValidType| BOOT:|ByteFileReadLine| BOOT::RENAME + BOOT::|isExposedConstructor| FOAM:|fiSetDebugVar| + BOOT:|InputStream?| BOOT::|ncParseFromString| + BOOT:|OutputStream?| BOOT:|StreamSize| + BOOT:|StreamGetPosition| BOOT:|StreamEnd?| + BOOT:|StreamClose| BOOT::|dbConstructorDoc,gn| + BOOT::|digits2Names| BOOT::|dbCompositeWithMap| + BOOT::|extractFileNameFromPath| BOOT:|ToPathname| + BOOT::IDENT-CHAR-LIT BOOT::IS-CONSOLE-NOT-XEDIT + BOOT::|dbAddChain| BOOT::MESSAGEPRINT + BOOT:|PathnameDirectory| BOOT::MESSAGEPRINT-2 + BOOT::|kFormatSlotDomain| BOOT:|PathnameName| + BOOT::MESSAGEPRINT-1 BOOT::|devaluate| BOOT:|PathnameType| + BOOT::|simpCatPredicate| BOOT:|PathnameString| + BOOT::|dbInfovec| BOOT:|PathnameAbsolute?| + BOOT:|PathnameWithoutType| BOOT::|getImports| + BOOT:|PathnameWithoutDirectory| BOOT::|saySpadMsg| + BOOT::|mkConArgSublis| BOOT:|PathnameToUsualCase| + BOOT:|PathnameDirectoryOfDirectoryPathname| BOOT::|sayTeX| + BOOT::|getUsersOfConstructor| BOOT:|Bit?| BOOT::EQUABLE + BOOT::|makeTemplate| BOOT::|dbShowConsKinds| + BOOT::|makeOpDirect| BOOT:|Vector?| BOOT::|bcConTable| + BOOT::|makeOpDirect,fn| BOOT::|mkUniquePred| + BOOT::PARTCODET BOOT::|bcAbbTable| BOOT::|putPredHash| + BOOT::|bcNameConTable| BOOT::|NRTinnerGetLocalIndex| + BOOT::|breakIntoLines| BOOT::|dbConstructorKind| + BOOT::BLANKP BOOT::|setLoadTimeQ| BOOT:|CharDigit?| + BOOT::|dbConstructorDoc,hn| BOOT::|setLoadTime| + BOOT::NONBLANKLOC BOOT::|extendVectorSize| + BOOT::|markUnique| BOOT:|Cset| BOOT::INDENT-POS + BOOT::|addConsDB,min| BOOT::NEXT-TAB-LOC + BOOT:|CsetComplement| BOOT::|measureCommon| + BOOT:|CsetString| BOOT::|getDependentsOfConstructor| + BOOT::|htMakeSaturnFilterPage| BOOT::|writeSaturnLines| + BOOT::|hasIdent| BOOT::|addConsDB,HashCheck| + BOOT::|parseNoMacroFromString| BOOT::|mapConsDB| + BOOT::|pf2Sex| BOOT::|squeezeConsDB| BOOT::|StreamNull| + BOOT::|squeezeConsDB,fn| BOOT::|mkBold| BOOT::|incString| + BOOT::|postSignature| BOOT::|killColons| BOOT:|ToString| + BOOT::|e02dffSolve,flam| BOOT::|removeSuperfluousMapping| + BOOT:|StringImage| BOOT::|dbShowConstructorLines| + BOOT:|String?| BOOT::|postAtom| BOOT::|dbName| + BOOT::|makeSpadConstant| BOOT::|postType| + BOOT::|childrenOf| BOOT::|htBcLispLinks| + BOOT::|typeCheckInputAreas| BOOT::|kisValidType| + BOOT::|kCheckArgumentNumbers| BOOT:|StringUpperCase| + BOOT:|StringLowerCase| BOOT::|topicCode| + BOOT::|htMakePage1| BOOT::|string2OpAlist| + BOOT::|htProcessDoitButton| BOOT::|blankLine?| + BOOT::|htProcessDoneButton| BOOT::|e02defSolve,fmu| + BOOT::|topics| BOOT::|htProcessBcButtons| + BOOT::|topLevelInterpEval| BOOT::|tdPrint| + BOOT::|htProcessToggleButtons| + BOOT::|htProcessDomainConditions| + BOOT::|getConstructorSignature| BOOT::|getDefaultProps| + BOOT::|htInputStrings| BOOT::GET-A-LINE + BOOT::|getConstructorDocumentation| + BOOT::|htBcRadioButtons| BOOT::KILL-COMMENTS + BOOT::|topicCode,fn| BOOT::|htRadioButtons| + BOOT::|listOfTopics| BOOT::|htLispMemoLinks| + BOOT::PRINT-RULE BOOT::|code2Classes| BOOT::SET-PREFIX + BOOT::PRINT-FLUIDS BOOT::|td| BOOT::|unabbrev| + BOOT::|prTriple| BOOT::|htEndMenu| BOOT::GET-META-TOKEN + BOOT::|hasNewInfoAlist| BOOT::|addTraceItem| + BOOT::GET-BSTRING-TOKEN BOOT::|untraceAllDomainLocalOps| + BOOT::|bright| BOOT::GET-STRING-TOKEN + BOOT::|formatUnabbreviated| BOOT::GET-IDENTIFIER-TOKEN + BOOT::BVEC-NOT BOOT::TOKEN-LOOKAHEAD-TYPE + BOOT::|orderBySlotNumber| BOOT::|traceSpad2Cmd| + BOOT::|compArgumentConditions| BOOT::|e02defSolve,flam| + BOOT::|trace1| BOOT::LINE-PRINT BOOT::|saveMapSig| + BOOT::LINE-PAST-END-P BOOT::|untrace| + BOOT::|stripOffArgumentConditions| + BOOT::DATABASE-CONSTRUCTORKIND BOOT::SPAD_ERROR_LOC + BOOT::|getTraceOptions| BOOT::|transTraceItem| + BOOT::BOOT-PARSE-1 BOOT::|genSearchTran| + BOOT::REDUCTION-VALUE BOOT::|removeSurroundingStars| + BOOT::|getTraceOption| BOOT::|checkFilter| BOOT::PREPARSE + BOOT::|getMapSubNames| BOOT::|getPreviousMapSubNames| + BOOT::|coerceSpadArgs2E| BOOT::|clear| + BOOT::|whatConstructors| BOOT::|stupidIsSpadFunction| + BOOT::|sayBrightlyLength| BOOT::|stackTraceOptionError| + BOOT::GET-BOOT-TOKEN BOOT::|reportOpsFromUnitDirectly| + BOOT::|coerceSpadFunValue2E| BOOT::|searchCount| + BOOT::GET-SPECIAL-TOKEN BOOT::|domainToGenvar| + BOOT::|searchDropUnexposedLines| BOOT::GET-SPADSTRING-TOKEN + BOOT::|compileAsharpArchiveCmd| BOOT::|genDomainTraceName| + BOOT::GET-NUMBER-TOKEN BOOT::GET-ARGUMENT-DESIGNATOR-TOKEN + BOOT::|spadReply,printName| BOOT::|abbreviations| + BOOT::|getTraceOption,hn| BOOT::BOOT-TOKEN-LOOKAHEAD-TYPE + BOOT::|changeToNamedInterpreterFrame| + BOOT::|removeTracedMapSigs| BOOT::|findFrameInRing| + BOOT::|isListOfIdentifiers| BOOT::|string2Constructor| + BOOT::|isListOfIdentifiersOrStrings| BOOT::|dbString2Words| + BOOT::|conLowerCaseConTran| BOOT::|emptyInterpreterFrame| + BOOT::|string2Words| BOOT::|whatCommands| + BOOT::BUMPERRORCOUNT BOOT::|commandsForUserLevel| + BOOT::MAKE-ADJUSTABLE-STRING BOOT::|dnForm| BOOT::|pp2Cols| + BOOT::|dnForm,negate| BOOT::|dbGetCommentOrigin| + BOOT::|whatSpad2Cmd,fixpat| BOOT::DEF-PROCESS + BOOT::|synonymsForUserLevel| BOOT::DEF-RENAME + BOOT::|postTransform| + BOOT::|processSynonymLine,removeKeyFromLine| + BOOT::|pmPreparse,hn| BOOT::|new2OldLisp| + BOOT::|processSynonymLine| BOOT::PRINT-PACKAGE + BOOT::|printSynonyms| BOOT::INITIALIZE-PREPARSE + BOOT::|clearParserMacro| + BOOT::|dbScreenForDefaultFunctions| BOOT::S-PROCESS + BOOT::|newHelpSpad2Cmd| BOOT::|dbChooseOperandName| + BOOT::|zsystemDevelopmentSpad2Cmd| BOOT::|parseFromString| + BOOT::|checkPmParse,fn| BOOT::|dbRead| + BOOT::|string2SpadTree| BOOT::|checkPmParse| SYSTEM:PNAME + BOOT::|htCopyProplist| BOOT::|pathnameTypeId| + BOOT::|capitalize| BOOT::|htSayValue| + BOOT::|clearCmdExcept| BOOT::|getSubstSigIfPossible| + BOOT::|workfilesSpad2Cmd| BOOT::|isIntegerString| + BOOT::|cd| BOOT::|dbGetExpandedOpAlist| + BOOT::|dbAddDocTable| BOOT::|zsystemdevelopment| + BOOT::|getConstructorForm| BOOT::|workfiles| + BOOT::|originsInOrder| BOOT::|getInfoAlist| + BOOT::|parentsOf| BOOT::|listOrVectorElementMode| + BOOT::|zeroOneConvertAlist| BOOT::|dbInfoSig| + BOOT::|numberize| BOOT::|hasNewInfoText| + BOOT::|splitConTable| BOOT::|dbGetDocTable,gn| + BOOT::|string2Integer| BOOT::|recordFrame| + BOOT::|issueHTSaturn| BOOT::|kTestPred| + BOOT::|segmentKeyedMsg| BOOT::|htpPageDescription| + BOOT::|dbDocTable| BOOT::|saturnTran| BOOT::|bcUnixTable| + BOOT::|mkTabularItem| BOOT::|printAsTeX| + BOOT::|isAsharpFileName?| BOOT::|isMenuItemStyle?| + BOOT::|saturnTranText| BOOT::|bcError| + BOOT::|transOnlyOption| BOOT::|kPageContextMenu| + BOOT::|bcString2WordList| BOOT::|unTab1| + BOOT::|shortenForPrinting| BOOT::|getBpiNameIfTracedMap| + BOOT::|recordAndPrintTest| BOOT::|mkTabularItem,fn| + BOOT::|PullAndExecuteSpadSystemCommand| BOOT::|htNewPage| + BOOT::|htpName| BOOT::|prTraceNames,fn| + BOOT::|htMakePageSaturn| BOOT::|e02zafSolve,flam| + BOOT::|isCapitalWord| BOOT::|zagSuper| BOOT::|height| + BOOT::|zagSub| BOOT::|inputPrompt| + BOOT::|flattenOperationAlist| BOOT::|variableNumber| + BOOT::|spadTrace,g| BOOT::|mkPredList,fn| + BOOT::|isTraceGensym| BOOT::|htPopSaturn| + BOOT::|htMakePageStandard| BOOT::|undo| BOOT::|dbKind| + BOOT::|undoCount| BOOT::|stringer| BOOT::|outputTranIf| + BOOT::|htInitPageNoHeading| BOOT::|undoLocalModemapHack| + BOOT::|saturnHasExamplePage| BOOT::|reportUndo| BOOT::|iht| + BOOT::|bcIssueHt| BOOT::|bcConform1| BOOT::|keyp| + BOOT::|bcConform1,hd| BOOT::|binomialWidth| + BOOT::|htSaySourceFile| BOOT::|basicStringize| + BOOT::|mapStringize| BOOT::|binomialSuper| + BOOT::|bcConform1,mapping| + BOOT::|outputTranMatrix,outtranRow| + BOOT::PLAIN-PRINT-FORMAT-STRING BOOT::|bcConform1,tuple| + BOOT::|binomialSub| BOOT::|vConcatWidth| BOOTTRAN::BOOTTOCL + BOOT::|bcConform1,tl| BOOT::|deMatrix| BOOT::TRANSLIST + BOOT::|sumWidthA| BOOT::TRANSLATE BOOT::|htSayItalics| + BOOT::|dbGetDocTable,hn| BOOT::|absym| + BOOT::|dbEvalableConstructor?| BOOT::|getCallBack| + BOOT::|texFormat1| BOOT::|unTab| + BOOT::RETRANSLATE-DIRECTORY BOOT::|kPageContextMenuSaturn| + BOOT::|maPrin| BOOT::RETRANSLATE-FILE-IF-NECESSARY + BOOT::|saturnExampleLink| BOOT::|explainLinear| + BOOT::RECOMPILE-ALL-LIBS BOOT::|htSayCold| + BOOT::RECOMPILE-LIB-DIRECTORY + BOOT::RECOMPILE-NRLIB-IF-NECESSARY BOOT::|writeSaturnTable| + BOOT::|maprinRows| BOOT::RECOMPILE-ALL-FILES + BOOT::|writeSaturn| BOOT::|maprinChk| + BOOT::|writeSaturnPrint| BOOT::RECOMPILE-ALL-ALGEBRA-FILES + BOOT::|bcConform1,say| BOOT::|escapeSpecialIds| + BOOT::|vConcatSub| BOOT::LOAD-DIRECTORY + BOOT::|postDoubleSharp| BOOT::|sumoverlist| + BOOT::|htProcessBcStrings| BOOT::|matSuperList| + BOOT::|superSubWidth| BOOT::CHAPTER-NAME BOOT::|isQuotient| + BOOT::|matSubList| BOOT::|superSubSuper| + BOOT::|isRationalNumber| BOOT::|matLSum| + BOOT::|superSubSub| BOOT::BLANKCHARP + BOOT::SPADTAGS-FROM-FILE BOOT::|matLSum2| + BOOT::OUR-WRITE-DATE BOOT::LIFT-NRLIB-NAME + BOOT::RECOMPILE-FILE-IF-NECESSARY BOOT::|suScWidth| + BOOT::|bcLinearSolveMatrixInhomo,f| BOOT::LIBCHECK + BOOT::|bcLinearExtractMatrix| BOOT::|printMap| + BOOT::|isInitialMap| BOOT::SPAD-CLEAR-INPUT + BOOT::|bcString2HyString| + BOOT::|NeedAtLeastOneFunctionInThisFile| BOOT::|pfSequence| + BOOT::|npPileBracketed| BOOT::|npAnyNo| BOOT::|bcOptional| + VMLISP::EQUABLE VMLISP::*LAM BOOT::|subSub| VMLISP::RCQEXP + BOOT::|flattenOps| BOOT::|npInfGeneric| BOOT::|slashWidth| + BOOT::|slashSuper| VMLISP::COMPILE1 BOOT::|slashSub| + BOOT::|pfPile| BOOT::|npParened| BOOT::BVEC-COPY + BOOT::|letWidth| VMLISP::FLAT-BV-LIST BOOT::|sortCarString| + BOOT::|pfAppend| VMLISP::PLIST2ALIST BOOT::|pfFix| + BOOT::|outputConstructTran| BOOT::|pfTyping| + BOOT::|outputTranSEQ| BOOT::|outputTranRepeat| + BOOT::|outputTranReduce| BOOT::|outputTranCollect| + BOOT::|outputMapTran| BOOT::|npSemiListing| + BOOT::|pfExport| BOOT::|pfLocal| + BOOT::|optSEQ,getRidOfTemps| BOOT::|optSPADCALL| + BOOT::|pfFree| BOOT::|optXLAMCond| BOOT::|optCONDtail| + BOOT::|optPredicateIfTrue| BOOT::|optCons| BOOT::|optSEQ| + BOOT::|pfBreak| BOOT::|optSEQ,tryToRemoveSEQ| + BOOT::|optSEQ,SEQToCOND| BOOT::|optimize,opt| + BOOT::|optCond| BOOT::|pfReturnNoName| BOOT::|optMkRecord| + BOOT::|npListAndRecover| BOOT::|optCatch| BOOT::|npTuple| + BOOT::|pf0SequenceArgs| BOOT::|compileTimeBindingOf| + BOOT::|optimizeFunctionDef,removeTopLevelCatch| + BOOT::|optEQ| BOOT::|optLESSP| BOOT::|pfIterate| + BOOT::|opt-| BOOT::|optQSMINUS| BOOT::|pfLoop1| + BOOT::|optMINUS| BOOT::|optSuchthat| BOOT::|optRECORDCOPY| + BOOT::|optSETRECORDELT| BOOT::|npParse| + BOOT::|timedEVALFUN| BOOT::|pfDocument| + BOOT::|updateTimedName| BOOT::|pfTweakIf| + BOOT::|timedOptimization| BOOT::|pfCheckItOut| + BOOT::|timedAlgebraEvaluation| BOOT::|pushTimedName| + BOOT::|significantStat| BOOT::|printNamedStats| + BOOT::|htpDestroyPage| BOOT::|splitIntoBlocksOf200| + BOOT::|incIgen| BOOT::|e02dafSolve,flam| + BOOT::|e04nafSolve,fe| BOOT::|str2Tex| + BOOT::|e04nafSolve,fd| BOOT::|wrap| BOOT::|e04nafSolve,fc| + BOOT::|e04ycfSolve,fa| BOOT::|str2Outform| + BOOT::|parse2Outform| BOOT::|e04nafSolve,fj| + BOOT::|e04nafSolve,fg| BOOT::|e04dgfSolve,fb| + BOOT::|e04mbfSolve,fg| BOOT::|evalLoopIter| + BOOT::|formatUnabbreviatedTuple| BOOT::|e04mbfSolve,fe| + BOOT::|length2?| BOOT::|Identity| BOOT::|upADEF| + BOOT::|bool| BOOT::|e04mbfSolve,fd| BOOT::|orderList| + BOOT::|e04mbfSolve,fc| BOOT::|upLoopIters| BOOT::NMSORT + BOOT::|pr| BOOT::|e04fdfSolve,fb| BOOT::|interpIter| + BOOT::|functionp| BOOT::|quoteCatOp| BOOT::|e04fdfSolve,fa| + BOOT::|isLetter| BOOT::|mkNestedElts| BOOT::|charRangeTest| + BOOT::|instantiate| BOOT::|isUpperCaseLetter| + BOOT::|e04gcfSolve,fb| BOOT::|flattenSexpr| + BOOT::|e04gcfSolve,fa| BOOT::|isStreamCollect| + BOOT::|removeZeroOneDestructively| BOOT::|StringToCompStr| + BOOT::|boolODDP| BOOT::|rightTrim| + BOOT::|dropLeadingBlanks| BOOT::|getDomainByteVector| + BOOT::|interpOnlyCOLLECT| BOOT::|e04jafSolve,fc| + BOOT::|upCOLLECT| BOOT::|upAlgExtension| + BOOT::|e04jafSolve,fb| BOOT::|eq2AlgExtension| + BOOT::|e04jafSolve,fa| BOOT::|clearCmdParts| + BOOT::|upCOLLECT0| BOOT::|loadLib| BOOT::|upCOLLECT1| + BOOT::|upand| BOOT::|upDeclare| BOOT:|pp| + BOOT::|f01rdfSolve,fz| BOOT::|mkZipCode| BOOT:ATOM2STRING + BOOT::|orderCatAnc| BOOT::|f01mcfSolve,g| + BOOT::|isOkInterpMode| BOOT::|f01mcfSolve,f| + BOOT::|mkAndApplyPredicates| BOOT:MATCH-STRING + BOOT::|upCOERCE| BOOT::|upStreamIters| BOOT::|upconstruct| + BOOT::|upTARGET| BOOT::|falseFun| BOOT::|upLET| + BOOT::|closeOldAxiomFunctor| BOOT::|f01refSolve,fz| + BOOT::|upLETWithPatternOnLhs| BOOT::|isTupleForm| + BOOT::|f01qefSolve,fz| BOOT::|e02zafSolve,fxy| + BOOT::|shoeStrings| BOOT::|removeConstruct| BOOT:|break| + BOOT::|shoeIntern| BOOT::|isLocalPred| + BOOT::|shoeInternFile| BOOT::|upequation| + BOOT::|SpadInterpretFile| BOOT::|intInterpretPform| + BOOT::|altSeteltable| BOOT::|packageTran| + BOOT::|isHomogeneous| BOOT::|zeroOneTran| + BOOT::|intProcessSynonyms| BOOT::|upbreak| + BOOT::|f01brfSolve,f| BOOT::|intnplisp| BOOT::|upDollar| + BOOT::|nplisp| BOOT::|setCurrentLine| + BOOT::|f01qdfSolve,fz| BOOT::|copyHack| BOOT::|copyHack,fn| + BOOT:ADJCURMAXINDEX BOOT::|upTuple| BOOT::|ncloopParse| + BOOT::|ncloopIncFileName| BOOT::|phBegin| + BOOT::|ncloopEscaped| BOOT::|upiterate| BOOT::|upIF| + BOOT::|upisnt| BOOT::|upisAndIsnt| BOOT::|phInterpret| + BOOT::|isHomogeneousArgs| BOOT:LASTATOM BOOT::|uphas| + BOOT::|phMacro| BOOT::|macroExpanded| BOOT::|upis| + BOOT::|ncConversationPhase,wrapup| BOOT:CONSOLEINPUTP + BOOT::|upwhere| BOOT::|serverReadLine| + BOOT::|ncloopPrintLines| BOOT::|mkLineList| + BOOT::|nonBlank| BOOT:|MakeSymbol| BOOT::|intloopEchoParse| + BOOT::|incBiteOff| BOOT::|SkipEnd?| BOOT::|incFileName| + BOOT::|Else?| BOOT::|Elseif?| BOOT::|If?| + BOOT::|inclmsgNoSuchFile| BOOT::|inclmsgPrematureFin| + BOOT::|incFileInput| BOOT::|Top?| + BOOT::|inclmsgPrematureEOF| BOOT::|SkipPart?| + BOOT::|KeepPart?| BOOT:COMP BOOT:GETGENSYM + BOOT::|incNConsoles| BOOT::|Skipping?| BOOT::|incClassify| + BOOT::EXPAND-TABS BOOT::|incCommand?| BOOT::|incRenumber| + BOOT::|incFile| BOOT::|incPos| + BOOT:|initializeSetVariables| BOOT::|inclmsgSay| + BOOT::|inclmsgConStill| BOOT::|incStringStream| + BOOT::|inclmsgConActive| BOOT:NUMOFNODES FOAM::TYPE2INIT + BOOT:TRANSPGVAR FOAM::FOAM-FUNCTION-INFO BOOT::|GetValue| + BOOT::|hasToInfo| FOAM::INSERT-TYPES BOOT::|formatPred| + BOOT::|chaseInferences,foo| BOOT::|liftCond| + FOAM::FOAMPROGINFOSTRUCT-P BOOT::|formatInfo| + BOOT:TOKEN-TYPE BOOT::|addInformation,info| + BOOT:|updateSourceFiles| BOOT::|infoToHas| BOOT::|addInfo| + BOOT::|formatPredParts| BOOT::|printInfo| + BOOT::|linearFormat| BOOT::|formatOperationAlistEntry| + BOOT::|formatIf| BOOT:MKQ BOOT::|linearFormatName| + BOOT::|dollarPercentTran| BOOT::|string2Float| + BOOT::|specialChar| BOOT:TOKEN-SYMBOL BOOT::|hashCode?| + BOOT::|formatArgList| BOOT::|listOfPredOfTypePatternIds| + BOOT::|script2String| BOOT::|form2Fence1| + BOOT::|replaceGoGetSlot| BOOT::|constructorName| + BOOT::|sayModemap| BOOT:ACTION BOOT::|opIsHasCat| + BOOT::|isNewWorldDomain| BOOT::|formCollect2String| + BOOT::|DNameToSExpr1| BOOT::|tuple2String| + BOOT::|DNameFixEnum| BOOT::|formJoin2String| BOOT:ASSOCLEFT + BOOT::|DNameToSExpr| BOOT:|sayALGEBRA| + BOOT::|CompStrToString| BOOT::|record2String| + FOAM-USER::|AXL-spitSInt| BOOT::|computedMode| + BOOT::|formWrapId| BOOT::|getIProplist| + BOOT::|isBinaryInfix| BOOT::|mkAtreeValueOf| + BOOT::|collectDefTypesAndPreds| BOOT::|formatSignature| + BOOT::|freeOfSharpVars| BOOT::|unVectorize| + BOOT::|formatSignature0| BOOT::|isInternalFunctionName| + BOOT::|objEnv| BOOT:NREVERSE0 BOOT::|formatMapping| + BOOT::|canRemoveIsDomain?| BOOT:|sayFORTRAN| + BOOT::|formIterator2String| BOOT:|IS_#GENVAR| + BOOT::|removeIsDomains| BOOT:LISTOFATOMS + BOOT::|formatAttribute| BOOT::|formTuple2String| + BOOT::|numOfSpadArguments| BOOT::|args2Tuple| + BOOT::|blankList| BOOT::|removeBodyFromEnv| + BOOT::|form2StringWithWhere| BOOT::|reportOpSymbol| + BOOT::|apropos| BOOT::|formatModemap,fn| + BOOT::|listOfVariables| BOOT::|isFreeVar| + BOOT::|isLocalVar| BOOT::|expr2String| + BOOT::|isInternalMapName| BOOT::|atom2String|)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) *) VMLISP:MAKE-APPENDSTREAM + VMLISP:MAKE-INSTREAM VMLISP:MAKE-OUTSTREAM + VMLISP:COMPILE-LIB-FILE BOOT:|OsRunProgram| + BOOT:|OsRunProgramToStream| BOOT::ASHARP + FOAM:COMPILE-AS-FILE BOOT:|Prompt| BOOT:|sayBrightlyNT|)) +(PROCLAIM + '(FTYPE (FUNCTION (T T T) (VALUES T T)) BOOT::|getScriptName| + FOAM:AXIOMXL-GLOBAL-NAME BOOT::|spadTraceAlias|)) +(PROCLAIM '(FTYPE (FUNCTION (T T *) (VALUES T T)) VMLISP:MDEF)) +(PROCLAIM '(FTYPE (FUNCTION (T *) STRING) VMLISP:MAKE-FULL-CVEC)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) *) BOOT::|bcInputMatrixByFormula| + BOOT::|bcInputExplicitMatrix| BOOT::|htStringPad| + BOOT::|evalAndRwriteLispForm| BOOT::|mkAtreeWithSrcPos| + BOOT::|rwriteLispForm| BOOT::COMPILE-DEFUN BOOT::|doIt| + BOOT::BPIUNTRACE VMLISP:QUOTIENT BOOT::|print| + BOOT::|compilerDoitWithScreenedLisplib| + BOOT::|compilerDoit| BOOT::MONITOR-PRINVALUE BOOT::/TRACE-2 + VMLISP:|LAM,FILEACTQ| BOOT::|hasFormalMapVariable| + BOOT::|ScanOrPairVec| VMLISP:SUFFIX BOOT::PRINMATHOR0 + BOOT::|spadTrace| BOOT::|output| BOOT::|e01bffDefaultSolve| + BOOT::|e01safDefaultSolve| BOOT::|popUpNamedHTPage| + BOOT::|e01dafDefaultSolve| BOOT::|replaceNamedHTPage| + BOOT::|e02bafDefaultSolve| BOOT::|e02bdfDefaultSolve| + BOOT::|e02defDefaultSolve| BOOT::|sockSendFloat| + BOOT::SOCK-SEND-SIGNAL BOOT::SOCK-SEND-FLOAT + BOOT::SOCK-SEND-STRING BOOT::SOCK-SEND-INT BOOT::ERASE + BOOT::|sayErrorly| BOOT::|saturnSayErrorly| BOOT::|set1| + BOOT::|displaySetOptionInformation| BOOT::|mkGrepPattern| + BOOT::|showDoc| BOOT::|genSearchSayJump| BOOT::|oPageFrom| + BOOT::|showConstruct| BOOT::|htCommandToInputLine,fn| + BOOT::|grepConstructorSearch| BOOT::|showNamedDoc| + BOOT::|form2HtString,fnTail| BOOT::|xdrWrite| + BOOT::|spleI1| BOOT::|readData,xdrRead1| BOOT::|xdrRead| + BOOT::|sockSendSignal| BOOT::|htpLabelFilteredInputString| + BOOT::|e01bgfDefaultSolve| BOOT::|e01befDefaultSolve| + BOOT::|e01bafDefaultSolve| BOOT::|htGlossSearch| + BOOT::|htSetSystemVariable| BOOT::|htSetSystemVariableKind| + BOOT::|htSetNotAvailable| BOOT::|htShowLiteralsPage| + BOOT::|htCheck| BOOT::|htShowIntegerPage| + BOOT::|htShowFunctionPage| BOOT::|htSetFunCommandContinue| + BOOT::|htKill| BOOT::|htFunctionSetLiteral| + BOOT::|htShowSetPage| BOOT::ADDCLOSE BOOT::|htSetLiteral| + BOOT:|LispCompileFileQuietlyToObject| + ; BOOT::|findStringInFile| + BOOT::|ppPair| + BOOT::|getMinimalVarMode| BOOT::|checkAddSpaceSegments| + BOOT::|checkAddIndented| BOOT::|alistSize,count| + BOOT::|dbConformGen1| BOOT::|pickitForm| + BOOT::|koaPageFilterByCategory1| VMLISP::COPY-FILE + VMLISP::COPY-LIB-DIRECTORY BOOT::|c06ebfDefaultSolve| + BOOT::|c06gsfDefaultSolve| BOOT::|c06eafDefaultSolve| + BOOT::|c06gbfDefaultSolve| BOOT::|c06gqfDefaultSolve| + BOOT::|c06ecfDefaultSolve| BOOT::|c06gcfDefaultSolve| + BOOT::|d01gafDefaultSolve| BOOT::|spadcall2| + BOOT::|sublisV| BOOT::|sublisV,suba| BOOT::|fortError| + BOOT::|f04adfDefaultSolve| BOOT::|f04arfDefaultSolve| + BOOT::|koPageFromKKPage| BOOT::|kArgPage| BOOT::|npsystem| + BOOT::|f04asfDefaultSolve| + BOOT::|handleParsedSystemCommands| + BOOT::|handleTokensizeSystemCommands| + BOOT::|f07fdfDefaultSolve| BOOT::|tokenSystemCommand| + BOOT::|reportOpsFromLisplib1| BOOT::|handleNoParseCommands| + BOOT::|f07aefDefaultSolve| BOOT::|f07fefDefaultSolve| + BOOT::|f07adfDefaultSolve| BOOT::|addPatchesToLongLines| + BOOT::|kArgumentCheck| BOOT::COERCE-FAILURE-MSG + BOOT::|kxPage| BOOT::|kcnPage| BOOT::SAYBRIGHTLYNT1 + BOOT::|kcuPage| BOOT::|ksPage| BOOT::|conOpPage| + BOOT::|kcdoPage| BOOT::|kcdePage| BOOT::|kcdPage| + BOOT::|kccPage| BOOT::|patternCheck,subWild| + BOOT::|kcaPage| BOOT::|kcpPage| BOOT::|htDoneButton| + BOOT::|sockSendInt| BOOT::|kePage| BOOT::|sockSendString| + BOOT::|koaPageFilterByName| BOOT::|koaPageFilterByCategory| + BOOT::|koPageAux1| BOOT::|kcPage| BOOT::|getmode| + BOOT::|docSearch1| BOOT::|grepSearchQuery| + BOOT::|repeatSearch| BOOT::|reportOpsFromLisplib0| + BOOT::|reportOperations| BOOT::|generalSearchDo| + BOOT::|grepSearchJump| BOOT::|mkDetailedGrepPattern,conc| + BOOT::|kiPage| BOOT::|errorPage| + BOOT::|dbShowConsKindsFilter| BOOT::|koPage| + BOOT::|dbInfoChoose| BOOT::|kciPage| + BOOT::|dbInfoChooseSingle| BOOT::|dbSort| BOOT::|msgText| + BOOT::|bcSeriesByFormula| BOOT::|bcRealLimitGen1| + BOOT::|bcSeriesExpansion| BOOT::|ncloopInclude| + BOOT::|bcComplexLimit| BOOT::|bcRealLimit| + BOOT::|htFilterPage| BOOT::|bcPuiseuxSeries| + BOOT::KCL-OS-RUN-PROGRAM-TO-STREAM BOOT::|bcLaurentSeries| + BOOT::KCL-OS-RUN-PROGRAM BOOT::|bcTaylorSeries| + BOOT::|bcLinearSolveMatrix| BOOT::|bcMakeEquations| + BOOT::|bcMakeLinearEquations| BOOT::|bcLinearSolveEqns| + BOOT::|bcSolveSingle| BOOT::|bcInputEquations| BOOT::FC + BOOT::|bcSystemSolve| BOOT::|bcSolveEquationsNumerically| + BOOT::|bcSolveEquations| BOOT::|bcLinearSolve| + BOOT::|bcLinearMatrixGen| + BOOT::|bcLinearSolveMatrixInhomoGen| + BOOT::|bcLinearSolveMatrixInhomo| + BOOT::|bcLinearSolveMatrixHomo| BOOT::|finalExactRequest| + BOOT::|printMap1| BOOT::|htMkName| + BOOT::|makeLongSpaceString| BOOT::|makeLongTimeString| + BOOT::|nrtEval| BOOT::|f01mcfDefaultSolve| + BOOT::|f01rcfDefaultSolve| BOOT::|ncloopCommand| + BOOT::|ncloopInclude1| BOOT::|ncConversationPhase| + BOOT:DEFSTREAM BOOT::|inclHandleBug| BOOT::|evalSlotDomain| + BOOT::|ncEltQ| BOOT::|formArguments2String,fn|)) +(PROCLAIM + '(FTYPE (FUNCTION (T *) T) BOOT:|sayBrightly| BOOT:BLANKS + BOOT:MATCH-NEXT-TOKEN BOOT::|desiredMsg| + BOOT:|sayBrightlyI| BOOT:MATCH-CURRENT-TOKEN + VMLISP:RDEFIOSTREAM VMLISP:CATCHALL VMLISP:TAB + VMLISP:|F,PRINT-ONE| VMLISP:VMPRINT BOOT::FINDTAG + VMLISP:MAKE-HASHTABLE VMLISP:MAKE-FILENAME VMLISP:MACERR + VMLISP:PRETTYPRINT BOOT::|pfExpression| BOOT::|pfSymbol| + VMLISP:|LAM,EVALANDFILEACTQ| VMLISP:PRETTYPRIN0 + BOOT::|pfSymb| VMLISP::MAKE-INPUT-FILENAME + BOOT:|LispReadFromString| BOOT::MONITOR-ADD BOOT::|cpCms| + VMLISP::MAKE-FULL-NAMESTRING BOOT:|PrettyPrint| + BOOT:|PlainPrintOn| BOOT:|WriteLispExpr| BOOT:|WriteLine| + BOOT:|WriteString| BOOT:|ReadLineIntoString| + BOOT:|ReadBytesIntoVector| BOOT:|Pathname| + BOOT:|FullVector| BOOT:|FullBvec| BOOT:|FullString| + BOOT::PRINT-NEW-LINE BOOT::PRINT-FULL + BOOT::GET-BOOT-IDENTIFIER-TOKEN BOOT::COMPSPADFILES)) +(PROCLAIM + '(FTYPE (FUNCTION (T T) T) BOOT::|mkAliasList,fn| BOOT:PREDECESSOR + BOOT::|depthOfRecursion| BOOT::|formatJoinKey| + BOOT::|putBodyInEnv| BOOT::|mapDefsWithCorrectArgCount| + BOOT::|sayModemapWithNumber| BOOT::|addDefaults| BOOT:NLIST + BOOT::|formatOperation| BOOT::|get1defaultOp| + BOOT::|compileBody| BOOT::|makeLocalModemap| BOOT:NSTRCONC + BOOT::|saveDependentMapInfo| BOOT:GETRULEFUNLISTS + BOOT::|axFormatDecl| BOOT::|mkMapAlias| BOOT::|readData| + BOOT::|axFormatConstantOp| BOOT::|axFormatOpSig| + BOOT::|mkFormalArg| BOOT::|writeData| BOOT:POINT + BOOT::|mkValCheck| BOOT::|mkValueCheck| BOOT::|isPointer?| + BOOT::|wt| BOOT::|dqAppend| BOOT::|makePattern| + BOOT::|makeAxFile| BOOT::|clearDependencies| + BOOT::|getEqualSublis,fn| BOOT::|sourceFilesToAxFile| + BOOT::|getLocalVars| BOOT::|simplifyMapPattern| + BOOT::|getMapBody| BOOT:GETTAIL BOOT::|htpLabelInputString| + BOOT::|htpLabelSpadValue| BOOT::|putDependencies| + BOOT::STACK-PUSH BOOT:COMPARE BOOT::|htMakeDoneButton| + BOOT::|putDependencies,removeObsoleteDependencies| + BOOT::|makeNewDependencies| BOOT::|PARSE-Operation| + BOOT::|htInitPage| BOOT::|notCalled| BOOT::|htpProperty| + BOOT::|containsOp| BOOT::|makeRuleForm| + BOOT::|nonRecursivePart| BOOT::|outputFormat| + BOOT::|sayDroppingFunctions| BOOT::|nonRecursivePart1| + BOOT::|expandRecursiveBody| BOOT::|addDefMap| + BOOT::|e04nafSolve,fh| BOOT:FLAG BOOT::|ifCond| + BOOT::|incCommandTail| BOOT::|incTrunc| BOOT::|dollarTran| + BOOT:PAIR BOOT::CHAR-EQ BOOT::|PARSE-rightBindingPowerOf| + BOOT::|e04nafSolve,fi| BOOT:SUBLISNQ + BOOT::|writeInputLines| BOOT::|rempropI| BOOT:DELASC + BOOT::|showInput| BOOT::|showInOut| BOOT::SPADRREAD + BOOT:LASSOC BOOT::|ScanOrPairVec,ScanOrInner| BOOT::|getI| + BOOT::|mergeSignatureAndLocalVarAlists| BOOT::CHAR-NE + BOOT:S+ BOOT::|convertOpAlist2compilerInfo,formatSig| + BOOT::|getLisplibNoCache| BOOT::|getLisplib| + BOOT::|PARSE-leftBindingPowerOf| BOOT:MAKE-PARSE-FUNCTION + BOOT::|spadPrint| BOOT::|getSlotFromCategoryForm| + BOOT::|systemDependentMkAutoload| BOOT:MKPF + BOOT::|mkAutoLoad| BOOT:STRM BOOT::|wordFrom| + FOAM::|magicEq1| BOOT::|throwKeyedMsg1| + BOOT::|saturnThrowKeyedMsg| BOOT::|center| + BOOT::|substituteCategoryArguments| + BOOT::|isDomainConstructorForm| BOOT::|keyedSystemError1| + BOOT::|orderByDependency| BOOT::|saturnKeyedSystemError| + BOOT::|getFunctorOpsAndAtts| BOOT::|breakKeyedMsg| + BOOT::|fastSearchCurrentEnv| BOOT::|putMode| + BOOT::|splitListOn| BOOT::|putFlag| + BOOT::|mkAtreeNodeWithSrcPos| BOOT::|getMsgCatAttr| + BOOT::|DomainSubstitutionFunction| + BOOT::|transferSrcPosInfo| BOOT::|isNestedInstantiation| + BOOT::|DomainSubstitutionFunction,Subst| + BOOT::|mkAtree1WithSrcPos| BOOT::|wrapDomainSub| + BOOT::|listInitialSegment| BOOT::|compCategoryItem| + BOOT::|writeLib| + BOOT::|makeFunctorArgumentParameters,findExtrasP| + BOOT::|loadLibIfNecessary| BOOT::|rep| + BOOT::|collectDefTypesAndPreds,addPred| + BOOT::|setMsgPrefix| BOOT::|setMsgCatlessAttr| + BOOT::|getSignatureFromMode| + BOOT::|makeFunctorArgumentParameters,findExtras| + BOOT::|makeFunctorArgumentParameters,findExtras1| + BOOT::|autoLoad| BOOT::|isMacro| BOOT::|readLib| + BOOT::|getValueFromEnvironment| + BOOT::|unloadOneConstructor| + BOOT::|compileCases,FindNamesFor| BOOT::|asTupleNewCode| + BOOT::|macroExpandList| BOOT::|setMsgForcedAttrList| + BOOT::|macSubstituteId| BOOT::|atree2Tree1| + BOOT::|compileCases,isEltArgumentIn| + BOOT::|makeFunctorArgumentParameters,augmentSig| + BOOT::|mkAtree3,fn| BOOT::|macroExpandInPlace| + BOOT::|getErFromDbL| BOOT::|compJoin,getParms| + BOOT::|pfMapParts| BOOT::|erMsgCompare| + BOOT::|compareposns| BOOT::|pfCopyWithPos| + BOOT::|mkCategoryPackage,fn| BOOT::|getArgumentMode| + BOOT:REMFLAG BOOT::|listDecideHowMuch| + BOOT::|throwEvalTypeMsg| BOOT::|splitEncodedFunctionName| + BOOT:QLASSQ BOOT::|decideHowMuch| BOOT::|getArgValue1| + BOOT::|setMsgText| BOOT::|setMsgUnforcedAttrList| + BOOT::|genDomainViewList0| BOOT::|macLambda,mac| + BOOT::|macWhere,mac| + BOOT::|makeFunctorArgumentParameters,fn| + BOOT::|canCacheLocalDomain| + BOOT::|makeCategoryPredicates,fn| + BOOT::|makeCategoryPredicates,fnl| + BOOT::|getArgValueOrThrow| BOOT::|mac0SubstituteOuter| + BOOT::|insertPos| BOOT::|macLambdaParameterHandling| + BOOT::|genDomainViewName| BOOT::|isKeyQualityP| + BOOT::|queueUpErrors| BOOT::|thisPosIsEqual| + BOOT::|getOpArgTypes1| BOOT::|redundant| + BOOT::|argCouldBelongToSubdomain| BOOT::|thisPosIsLess| + BOOT::APPEND-N BOOT::|putFTText| BOOT::CONS-N + BOOT::|getModemap| BOOT::|sameMsg?| BOOT::EVAL-DEFUN + BOOT::|mkOpVec| BOOT::|resolveTCat| + BOOT::PRINT-AND-EVAL-DEFUN BOOT::|AssocBarGensym| + BOOT::|FromTo| BOOT::|compareMode2Arg| + BOOT::|c02affSolve,f| BOOT::|subCopy| + BOOT::|getOpArgTypes,f| BOOT::|isTowerWithSubdomain| + BOOT::|addEmptyCapsuleIfNecessary| BOOT::|constructM| + BOOT:|delete| BOOT::|c02agfSolve,f| BOOT::|bootStrapError| + BOOT::|getOpArgTypes| BOOT::|dqAddAppend| BOOT::|tracelet| + BOOT::/UNTRACE-2 BOOT:|rassoc| BOOT::|resolveTM1| + BOOT::|matchMmSigTar| BOOT::/UNTRACE-1 BOOT::|deepSubCopy| + BOOT::|CONTAINEDisDomain| BOOT::|hasCatExpression| + BOOT::PAIRTRACE BOOT::|spadUntrace| BOOT:LENGTHENVEC + BOOT::|defaultTypeForCategory| BOOT::DEF-IT BOOT:|breaklet| + BOOT::|mmCatComp| BOOT::|mergeSubs| BOOT::DEF-LET + BOOT::|hasCaty1| BOOT:STRINGPAD BOOT::|mkObjWrap| + BOOT:TRUNCLIST BOOT::|position1| BOOT::DEF-IS2 + BOOT::|defLET| BOOT::|defLETdcq| + BOOT::|sortAndReorderDmpExponents| BOOT::WHDEF + BOOT::|removeListElt| BOOT::|everyNth| BOOT::LET_ERROR + BOOT::|defIS| BOOT::DEF-IS-REV VMLISP:SETDIFFERENCE + BOOT::DEF-SELECT2 BOOT::DEF-SELECT1 BOOT::|addInformation| + BOOT::|varIsOnlyVarInPoly| BOOT::|makeCategoryPredicates| + BOOT::|compDefWhereClause,addSuchthat| VMLISP:DIVIDE + BOOT::NOTEQUALLIBS VMLISP:GETL BOOT::|modemapPattern| + BOOT::|removeVectorElt| BOOT::GETALIST + BOOT::|buildDatabase| BOOT::|mathPrint1| + BOOT::|getInverseEnvironment| BOOT::|getSuccessEnvironment| + BOOT::|getSystemModemaps| BOOT::|insertWOC| + BOOT::|getModemapsFromDatabase| BOOT::|removeCoreModemaps| + BOOT::|SubstWhileDesizing| BOOT::|resolveTTUnion| + BOOT::|resolveTTEq| BOOT::|rightBindingPowerOf| + BOOT::/GETOPTION BOOT::|resolveTTCC| + BOOT::|leftBindingPowerOf| BOOT::|stackSemanticError| + BOOT::/GETTRACEOPTIONS BOOT::|resolveTTRed| + BOOT::/TRACELET-PRINT BOOT::|resolveTTSpecial| + BOOT::MONITOR-PRINT BOOT::|compareTT| BOOT::|opWidth| + BOOT::|isConstantId| BOOT::|acceptableTypesToResolve| + BOOT::|resolveTCat1| BOOT::|getConditionsForCategoryOnType| + BOOT::|resolveTTAny| BOOT::|resolveTMOrCroak| + BOOT::|outputMapTran0| BOOT::|spliceTypeListForEmptyMode| + BOOT::MONITOR-EVALTRAN BOOT::|constructTowerT| + BOOT::|throwKeyedMsg| BOOT::|canCoerceExplicit2Mapping| + BOOT::|term1RWall| BOOT::|absolutelyCannotCoerce| + BOOT::|rassocSub| BOOT::|coerceOrConvertOrRetract| + VMLISP:NCONC2 BOOT::|term1RW| BOOT::|coerceOrRetract| + BOOT::|resolveTMTaggedUnion| BOOT::|canCoerceUnion| + BOOT::|acceptableTypesToResolve1| BOOT::|canCoercePermute| + BOOT::|computeTTTranspositions| BOOT::|resolveTM2| + BOOT::|newCanCoerceCommute| BOOT::|coerceIntCommute| + BOOT::|resolveTMRed| BOOT::|coerceInt1| BOOT::|pmatch| + BOOT::/TRACE-1 BOOT::|resolveTMEq| BOOT::|getUnionMode| + BOOT::|resolveTMEq1| BOOT::|isUnionMode| + BOOT::|coerceInt2Union| BOOT::|resolveTMSpecial| + BOOT::|coerceIntFromUnion| VMLISP:REMAINDER + BOOT::|resolveTMRecord| BOOT::|resolveTMUnion| + BOOT::|isFunction| BOOT::|coerceIntAlgebraicConstant| + BOOT::|coerceIntTower| BOOT::|coerceRetract| + BOOT::|compareTypeLists| BOOT::|modifyModeStack| + BOOT::|replaceSymbols| BOOT::|coerceIntTableOrFunction| + BOOT::|isDomainForm| BOOT::|coerceIntSpecial| + BOOT::/TRACELET-2 BOOT::|SubstWhileDesizingList| + BOOT::|coerceIntPermute| BOOT::|getProplist| + BOOT::|coerceBranch2Union| BOOT::ASSOCIATER + BOOT::/TRACELET-1 BOOT::|retractByFunction| + BOOT::|constructT| BOOT::MONITOR-PRINARGS-1 + BOOT::|outputComp| VMLISP:GGREATERP BOOT::|isDomainInScope| + BOOT::|canConvertByFunction| VMLISP:CGREATERP + BOOT::|canCoerceLocal| BOOT::|maxSuperType| + BOOT::|canCoerceTower| BOOT::/UPDATE-1 BOOT::|coerceInt0| + BOOT::|objSetMode| VMLISP:SORTBY BOOT::MONITOR-GETVALUE + VMLISP:|member| BOOT::MONITOR-EVALTRAN1 + BOOT::|coerceIntByMapInner| BOOT::|getConstantFromDomain| + BOOT::|valueArgsEqual?| BOOT::|traceDomainConstructor| + BOOT::|coerceIntByMap| BOOT::|equalZero| + BOOT::|replaceLast| BOOT::|coerceIntTest| VMLISP:ADDOPTIONS + BOOT::|isSubTowerOf| BOOT::|starstarcond| BOOT::|equalOne| + VMLISP:|assoc| VMLISP:SETSIZE BOOT::|evalSharpOne| + VMLISP:EFFACE BOOT::|canCoerceCommute| + BOOT::|clearDependentMaps| BOOT::|constantInDomain?| + VMLISP:EMBED BOOT::|translateMpVars2PVars| + VMLISP:LEXGREATERP VMLISP:RPLPAIR + BOOT::|addDmpLikeTermsAsTarget| VMLISP:HPUT* + BOOT::|genMpFromDmpTerm| VMLISP:STRING2ID-N + BOOT::|htMakeTemplates,substLabel| BOOT::|doDoitButton| + VMLISP:$FINDFILE BOOT::|keyedMsgCompFailure| BOOT::|objNew| + BOOT::|putValue| BOOT::|getAtree| BOOT::|putModeSet| + VMLISP:$SHOWLINE VMLISP:RDROPITEMS BOOT::|bottomUpType| + BOOT::|bottomUpIdentifier| BOOT::|transferPropsToNode| + BOOT::|getArgValue| BOOT::|bottomUpCompilePredicate| + BOOT::|bottomUpPredicate| BOOT::|putTarget| + BOOT::|getMinimalVariableTower| + BOOT::|computeTypeWithVariablesTarget| + BOOT::|removeUnionsAtStart| BOOT::|pushDownOp?| + BOOT::|e02gafSolve,fc| BOOT::|e02gafSolve,fr| + BOOT::|sayIntelligentMessageAboutOpAvailability| + BOOT::|getBasicMode0| BOOT::|mkObjCode| + BOOT::|intCodeGenCOERCE| BOOT::|canCoerceByMap| + BOOT::|canCoerceByFunction| BOOT::|isSubDomain| + BOOT::|absolutelyCanCoerceByCheating| + BOOT::|e04ucfSolve,fa| BOOT::|coerceCommuteTest| + BOOT::|asyGetAbbrevFromComments,fn| BOOT::|asySplit| + BOOT::|asyWrap| BOOT::GETDATABASE + BOOT::|asyAbbreviation,chk| BOOT::|asyTypeJoinPart| + BOOT::|setVector4part3| BOOT::|sublisProp| + BOOT::|setVector12,freeof| BOOT::|setVector4Onecat,form| + BOOT::|asyDisplay| BOOT::ERROR-FORMAT + BOOT::|asyAbbreviation| BOOT::|asyCattranConstructors| + BOOT::|DomainPrint| BOOT::|makeSF| BOOT::|asySimpPred| + BOOT::|setVector0| BOOT::|setVector3| BOOT::DIVIDE2 + BOOT::QUOTIENT2 BOOT::|htpSetName| BOOT::|sort| + BOOT::|defLET2| BOOT::|defLetForm| BOOT::|asyMapping| + BOOT::|defIS1| BOOT::|asySig| BOOT::|defISReverse| + BOOT::|addCARorCDR| BOOT::|defLET1| + BOOT::|asyExportAlist,fn| BOOT::|displayDatabase,fn| + BOOT::|quickAnd| BOOT::|asyCattranSig| BOOT::|asySigTarget| + BOOT::|asyMkSignature| BOOT::|asCategoryParts,build| + BOOT::/COMPINTERP BOOT::|unabbrevRecordComponent| + BOOT::|unabbrev1| BOOT::|makeByteWordVec2| + BOOT::|condAbbrev| BOOT::|unabbrevUnionComponent| + BOOT::|constructorNameConflict| BOOT::SPAD-PRINTTIME + BOOT::|htpLabelType| BOOT::|errorSupervisor| + BOOT::|sayErrorly1| BOOT::INTEGER-BIT BOOT::|chebeval| + BOOT::|rPsi| BOOT::|cpsireflect| BOOT::|cPsi| + BOOT::|BesselJRecur| BOOT::|substFromAlist| + BOOT::|BesselJAsymptOrder| BOOT::|BesselJAsympt| + BOOT::|PsiXotic| BOOT::|f01| BOOT::|brutef01| + BOOT::RBESSELJ BOOT::CPSI BOOT::RPSI BOOT::CHYPER0F1 + BOOT::CBESSELI BOOT::RBESSELI BOOT::CBESSELJ + BOOT::|formatLazyDomainForm| BOOT::|formatLazyDomain| + BOOT::|getDomainSigs1| BOOT::|showDomainsOp1| + BOOT::|devaluateSlotDomain| BOOT::|getDomainRefName| + BOOT::|andDnf| BOOT::|ordUnion| BOOT::|coafAndDnf| + BOOT::|orDel| BOOT::|orDnf| BOOT::|dnfContains,fn| + BOOT::|andReduce| BOOT::|simpBoolGiven| BOOT::|dnfContains| + BOOT::|coafAndCoaf| BOOT::|ordIntersection| + BOOT::|ordSetDiff| BOOT::|coafOrDnf| BOOT::|predCircular| + BOOT::|clearAllSlams,fn| BOOT::|assocCircular| + BOOT::|recurrenceError| BOOT::|countCircularAlist| + BOOT::|displaySetVariableSettings| BOOT::|sayCacheCount| + BOOT::|chebstareval| BOOT::|BesselIAsymptOrder| + BOOT::|horner| BOOT::|BesselKAsymptOrder| BOOT::|cbeta| + BOOT::|PsiAsymptotic| BOOT::|PsiEps| BOOT::|FloatError| + BOOT::|cgammaG| BOOT::|besselIback| BOOT::|rPsiW| + BOOT::|firstNonDelim| BOOT::|chebf01| BOOT::|BesselJ| + BOOT::|BesselI| BOOT::|grepSplit| BOOT::|grepConstruct1| + BOOT::|grepConstructDo| BOOT::|mkGrepPattern1,h| + BOOT::|pfCoerceto| BOOT::|stripOffSegments| + BOOT::|pfFromdom| BOOT::|pfRetractTo| BOOT::|pfRestrict| + BOOT::|mkGrepPattern1,split| BOOT::|testInput2Output| + BOOT::|hyperize| BOOT::|testPrin| BOOT::|grepCombine| + BOOT::|subMatch| BOOT::|bcAbb| BOOT::|lfrinteger| + BOOT::|getFortranType| BOOT::|wl| BOOT::|scanIgnoreLine| + BOOT::|makeVector| BOOT::|htPred2English,fn| BOOT::|posend| + BOOT::|functionAndJacobian,DF| BOOT::|isString?| + BOOT::|bcOpTable| BOOT::|xdrOpen| BOOT::|scanExponent| + BOOT::|scanCheckRadix| BOOT::|coerceUn2E| + BOOT::|inFirstNotSecond| BOOT::|coerceVal2E| + BOOT::|EnumPrint| BOOT::|scanInsert| VMLISP::WRAP + BOOT::|RecordPrint| BOOT::|coerceRe2E| + BOOT::|syIgnoredFromTo| BOOT::|sySpecificErrorHere| + BOOT::|pfTree| BOOT::|makeList| + BOOT::|setVector4Onecat,Supplementaries| BOOT::|pfSuch| + BOOT::|compCategories1| BOOT::|pfParen| BOOT::|pfPretend| + BOOT::|pfComDefinition| BOOT::|pfMLambda| + BOOT::|resolvePatternVars| BOOT::|cons5| + BOOT::|makeMissingFunctionEntry| BOOT::|pfHide| + BOOT::|setVector5| BOOT::|d02kefSolve,fd| + BOOT::|mkVectorWithDeferral| BOOT::|d02kefSolve,fe| + BOOT::|d02gbfSolve,ff| BOOT::|pfBracketBar| + BOOT::|d02gbfSolve,fg| BOOT::|pfIdPos| BOOT::|ProcessCond| + BOOT::|DescendCodeAdd| BOOT::|LookUpSigSlots| + BOOT::|DomainPrintSubst| BOOT::|d02gbfSolve,fc| + BOOT::|partPessimise| BOOT::|d02gbfSolve,fd| + BOOT::|pfBraceBar| BOOT::|sublisProp,inspect| + BOOT::|pfTagged| BOOT::|HasCategory| BOOT::|d02gbfSolve,fa| + BOOT::|HasSignature| BOOT::|d02gbfSolve,fb| + BOOT::|HasAttribute| BOOT::|pfWDeclare| + BOOT::|InvestigateConditions,Conds| BOOT::|pfBracket| + BOOT::|pfDWhere| BOOT::|NewbFVectorCopy| + BOOT::|DescendCodeVarAdd| BOOT::|getDomainView| + BOOT::|pfBrace| BOOT::|d02gafSolve,fe| + BOOT::|d02gafSolve,fc| BOOT::|pfOr| BOOT::|pfAnd| + BOOT::|d03edfSolve,fb| BOOT::|pfTLam| + BOOT::|stringChar2Integer| BOOT::|reshape| + BOOT::|e01dafSolve,h| BOOT::|hashCombine| + BOOT::|e01dafSolve,k| BOOT::|hashType| VMLISP:$REPLACE + VMLISP:UNIONQ BOOT::|spadSysBranch| + BOOT::|htSystemVariables,gn| BOOT::|postFlatten| + BOOT::|gatherGlossLines| VMLISP:|intersection| + BOOT::|postFlattenLeft| BOOT::|postTranSegment| + VMLISP:DEFINE-FUNCTION BOOT::SEGMENT BOOT::|pfTyped| + BOOT::|postScriptsForm| BOOT::|htCheckList| + BOOT::|htSetvarDoneButton| BOOT::|htMakePathKey,fn| + BOOT::|npLeftAssoc| VMLISP:SETDIFFERENCEQ + BOOT::|htMarkTree| BOOT::|pfCollect| BOOT::|pfQualType| + BOOT::|deltaContour| BOOT::ADD-PARENS-AND-SEMIS-TO-LINE + BOOT::|getUniqueSignature| VMLISP:INTERSECTIONQ + BOOT::|AMFCR,redefinedList| BOOT::|putDomainsInScope| + BOOT::INITIAL-SUBSTRING BOOT::|compFormMatch,match| + BOOT::STOREBLANKS BOOT::|compFormMatch| BOOT::ESCAPED + BOOT::PARSEPILES BOOT::|addNewDomain| BOOT::|htDoNothing| + BOOT::|AMFCR,redefined| BOOT::|domainMember| + BOOT::|e04ycfSolve,fb| BOOT::MONITOR-WRITE + BOOT::|htpSetDomainPvarSubstList| BOOT::|coerceByModemap| + BOOT::|htpLabelFilter| BOOT::|profileDisplayOp| + BOOT::|htpLabelSpadType| BOOT::|pfAssign| + BOOT::|htpSetDomainVariableAlist| BOOT::|convertOrCroak| + BOOT::|htpSetDomainConditions| + BOOT::|intersectionEnvironment| BOOT::|pfRule| + BOOT::|coerceExit| BOOT::|resolveTM| + BOOT::|autoCoerceByModemap| BOOT::|coerceExtraHard| + BOOT::|hasType| BOOT::|getConstructorMode| + BOOT::|getConstructorFormOfMode| BOOT::|pfWhere| + BOOT::|coerceHard| BOOT::|npRightAssoc| + BOOT::|coerceSubset| BOOT::|reportCircularCacheStats| + BOOT::|mkCircularCountAlist| BOOT::|pfPushMacroBody| + BOOT::|pfMacro| BOOT::|coerceEasy| BOOT::|keyedSystemError| + BOOT::|chaseInferences| BOOT::|say2PerLineWidth| + BOOT::|getFormModemaps| BOOT::|prEnv,tran| BOOT::|qArg| + BOOT::|npMissingMate| BOOT::|canFit2ndEntry| + BOOT::|sayKeyedMsgLocal| BOOT::|mkUnion| + BOOT::|printEnv,tran| BOOT::|listTruncate| + BOOT::|newHasTest| BOOT::|makeCategoryForm| + BOOT::ADDOPERATIONS BOOT::ASHARPMKAUTOLOADFUNCTION + BOOT::|HGETandCount| BOOT::|consForHashLookup| + BOOT::|sayKeyedMsgAsTeX| BOOT::|SymMemQ| BOOT::|addToSlam| + BOOT::|throwPatternMsg| BOOT::DELDATABASE + BOOT::|sayPatternMsg| BOOT::|getKeyedMsgInDb| + BOOT::|lassocShift| BOOT::|htMakeTemplates| + BOOT::|isKeyedMsgInDb| BOOT::|patternVarsOf1| + BOOT::GETCONSTRUCTOR BOOT::|pfFromDom| BOOT::|symEqual| + BOOT::|domainEqualList| BOOT::SET-LIB-FILE-GETTER + BOOT::|pfApplication| BOOT::|rightJustifyString| + BOOT::|remHashEntriesWith0Count,fn| + BOOT::|globalHashtableStats| BOOT::|lassocShiftQ| + BOOT::|pfWDec| BOOT::|pileForest| BOOT::|canCoerce;| + BOOT::|pileForest1| BOOT::|canCoerce1| BOOT::DAASENAME + BOOT::|pileTree| BOOT::|eqpileTree| BOOT::|pileCtree| + BOOT::|resolveTT;| BOOT::WRAPDOMARGS BOOT::|evalCategory| + BOOT::|replaceSharps| BOOT::|ofCategory| + BOOT::|canCoerceFrom;| BOOT::|canCoerceFrom0| + BOOT::|isEqualOrSubDomain| BOOT::|hasCorrectTarget| + BOOT::MAKE-DATABASES BOOT::|resolveTT1| + BOOT::|applyWithOutputToString| BOOT::|isDomainSubst,fn| + BOOT::|isDomainSubst,findSub| BOOT::|insertModemap| + BOOT::|makeBigFloat| BOOT::REDUCTION-PRINT + BOOT::|mkAlistOfExplicitCategoryOps,fn| BOOT::REMOVER + BOOT::STACK-LOAD BOOT::ESCAPE-KEYWORDS BOOT::|allLASSOCs| + BOOT::MAKE-PARSE-FUNCTION1 BOOT::|pairList| + BOOT::INITIAL-SUBSTRING-P BOOT::|finalizeDocumentation,fn| + BOOT::|formatOpSignature| BOOT::|sayKeyedMsg| + BOOT::|transDocList| BOOT::MAKE-PARSE-FUNC-FLATTEN + BOOT::|recordAttributeDocumentation| + BOOT::|recordDocumentation| + BOOT::|recordSignatureDocumentation| BOOT::|macroExpand| + BOOT::|checkRewrite| BOOT::|checkComments| + BOOT::|checkExtract| BOOT::|checkTrim| + BOOT::|spadSysChoose| BOOT::|testError| + BOOT::|spadtestValueHook| BOOT::|checkIsValidType,fn| + BOOT::|transDoc| BOOT::|checkIndentedLines| + BOOT::SAYBRIGHTLY1 BOOT::|pvarPredTran| BOOT::|mkAbbrev| + BOOT::|addSuffix| BOOT::|processPackage,opt| + BOOT::|subTree| BOOT::|mkRepititionAssoc,mkRepfun| + BOOT::|setPackageLocals| BOOT::|UnionPrint| + BOOT::|JoinInner| BOOT::|objNewWrap| + BOOT::|coerceByFunction| BOOT::|MappingPrint| + BOOT::|parseTypeEvaluateArgs| BOOT::|createEnum| + BOOT::|parseTranCheckForRecord| BOOT::|installConstructor| + BOOT::|AncestorP| BOOT::|SourceLevelSubset| + BOOT::|JoinInner,AddPredicate| BOOT::|mkAnd| BOOT::|mkOr| + BOOT::|SigListUnion| BOOT::|PredImplies| + BOOT::|DescendantP| BOOT::|mkOr2| BOOT::|SigOpsubsume| + BOOT::|SourceLevelSubsume| BOOT::|compMakeCategoryObject| + BOOT::|MachineLevelSubset| BOOT::|MachineLevelSubsume| + BOOT::|SigListOpSubsume| BOOT::|SigEqual| + BOOT::|SigListMember| BOOT::|CategoryPrint| BOOT::|mkAnd2| + BOOT::|categoryParts,build| + BOOT::|catPairUnion,addConflict| + BOOT::|clearCategoryTable1| BOOT::|parseCases,casefn| + BOOT::|hasCat| BOOT::|superSub| BOOT::|encodeCategoryAlist| + BOOT::|simpCategoryOr| BOOT::|tempExtendsCat| + BOOT::CONVERSATION1 BOOT::|addDomainToTable| + BOOT::|mkCategoryOr| BOOT::/EMBED-Q + BOOT::|formalSubstitute| + BOOT::|updateCategoryTableForDomain| + BOOT::|simpCatHasAttribute| BOOT::|testExtend| + BOOT::|mergeOr| BOOT::|newHasTest,fn| BOOT::|simpOrUnion1| + BOOT::|updateCategoryTable| BOOT::|substDomainArgs| + BOOT::|NRTreplaceLocalTypes| BOOT::|dcOpPrint| + BOOT::|predicateBitIndex,pn| BOOT::|augmentPredCode| + BOOT::|mungeAddGensyms| BOOT::|htSayExpose| + BOOT::|makeCompactSigCode| BOOT::|evalDomainOpPred,process| + BOOT::|makeGoGetSlot| BOOT::|dbShowOpHeading| + BOOT::|makePrefixForm| BOOT::|dbShowOperationLines| + BOOT::|buildBitTable,fn| BOOT::|makeCompactDirect1| + BOOT::|augmentPredVector| BOOT::|simpOrDumb| + BOOT::|dbReduceByForm| BOOT::|dbContrivedForm| + BOOT::|dbReduceByOpSignature| BOOT::|dcOpLatchPrint| + BOOT::|reduceByGroup| BOOT::|dbGetCondition| + BOOT::|dbGetOrigin| BOOT::|koCatOps| BOOT::|modemap2Sig| + BOOT::|substInOrder| BOOT::|pairlis| BOOT::|getDcForm| + BOOT::|koCatAttrsAdd| BOOT::|getSubstInsert| + BOOT::|integerAssignment2Fortran1| BOOT::|koOps,fn| + BOOT::|getAllModemapsFromDatabase| BOOT::|koOps,merge| + BOOT::|exp2FortOptimizeCS1,pushCsStacks| + BOOT::|fortFormatTypes| BOOT::|segment2| BOOT::|whoUses| + BOOT::|fortranifyIntrinsicFunctionName| + BOOT::|expression2Fortran1| BOOT::|dispfortarrayexp| + BOOT::|fortFormatIfGoto| BOOT::|koCatAttrs| + BOOT::|dbGetContrivedForm| BOOT::|dispfortexpj| + BOOT::|assignment2Fortran1| BOOT::|beenHere| + BOOT::|dispfortexpf| BOOT::|htSayConstructor| + BOOT::|stringPrefix?| VMLISP::PUTINDEXTABLE + VMLISP::WRITE-INDEXTABLE BOOT::|NRTsetVector4Part2| + BOOT::|consDomainName| BOOT::|NRTencode| + BOOT::|consDomainForm| BOOT::|deltaTran| BOOT::|consSig| + BOOT::|NRTaddToSlam| BOOT::|deepChaseInferences| + BOOT::|c06gsfSolve,g| BOOT::|c06gsfSolve,f| + BOOT::|NRTdescendCodeTran| BOOT::|mergeAppend| + BOOT::|NRTgetLocalIndex1| BOOT::|vectorLocation| + BOOT::|c06frfSolve,fy| BOOT::|c06frfSolve,gy| + BOOT::|c06frfSolve,fx| BOOT::|c06frfSolve,gx| + BOOT::|c06gqfSolve,g| BOOT::|c06gqfSolve,f| + BOOT::|c06fpfSolve,f| BOOT::|c06fpfSolve,g| + BOOT::|c06fqfSolve,f| BOOT::|c06fqfSolve,g| + BOOT::|c06fufSolve,fy| BOOT::|c06fufSolve,gy| + BOOT::|c06fufSolve,fx| BOOT::|c06fufSolve,gx| + BOOT:|ListIsLength?| BOOT:|ListMemberQ?| BOOT:|ListMember?| + BOOT:|ListRemoveQ| BOOT:|ListNRemoveQ| BOOT:|ListUnion| + BOOT:|ListUnionQ| BOOT:|ListIntersection| + BOOT:|ListIntersectionQ| BOOT:|ListAdjoin| + BOOT:|ListAdjoinQ| BOOT:|AlistAssoc| BOOT:|AlistRemove| + BOOT:|AlistAssocQ| BOOT:|AlistRemoveQ| BOOT:|AlistAdjoinQ| + BOOT:|AlistUnionQ| BOOT::|rePackageTran| + BOOT::|ncINTERPFILE| BOOT:|TableUnset| + BOOT::|updateSymbolTable| FOAM:|printDFloat| + FOAM:|printSFloat| FOAM:|fputs| FOAM:|printBInt| + FOAM:|fputc| FOAM:|printSInt| FOAM:|printString| + FOAM:|printChar| BOOT::|incAppend| BOOT::|segment1| + BOOT::|intersectionContour,unifiable| BOOT::|getStatement| + BOOT::|deltaContour,contourDifference| + BOOT::|makeCommonEnvironment,makeSameLength| BOOT::DELLASOS + BOOT::|addContour,fn| BOOT::|fortranifyFunctionName| + BOOT::|displayOpModemaps| BOOT::|fortFormatTypes1| + BOOT::|f02aefSolve,l| FOAM:|PtrMagicEQ| BOOT::|hasOption| + BOOT::|intersectionContour| BOOT::|commandErrorIfAmbiguous| + BOOT::|intersectionContour,computeIntersection| + BOOT::|f04adfSolve,f| BOOT::|f04adfSolve,g| + BOOT::|makeCommonEnvironment| BOOT::|makeLiteral| + BOOT::|isLiteral| BOOT::|f04mcfSolve,f| + BOOT::|f04mcfSolve,g| BOOT::|f04qafSolve,h| BOOT::|mapInto| + BOOT::|f04qafSolve,k| BOOT::|stringMatches?| + BOOT::|basicMatch?| BOOT::|optionError| + BOOT::|displayProperties| BOOT::|mkErrorExpr,highlight| + BOOT::|f04adfSolve,fb| BOOT::|mkErrorExpr,highlight1| + BOOT::|coerce| BOOT::|numOfOccurencesOf| BOOT::|sublisR| + BOOT::|compMapCond''| BOOT::|getAndSay| + BOOT::|intersectionContour,interProplist| BOOT::|position| + BOOT::|satDownLink| BOOT::|getmodeOrMapping| + BOOT::|intersectionContour,compare| + BOOT::|intersectionContour,modeCompare| + BOOT::|getAbbreviation| BOOT::|koAttrs| + BOOT::|GEQNSUBSTLIST,GSUBSTinner| BOOT::|isCategoryForm| + BOOT::|resolve| BOOT::|convert| BOOT::|flatten| + BOOT::|f04jgfSolve,f| BOOT::|npsynonym| + BOOT::|f04jgfSolve,g| BOOT::|getImports,import| + BOOT::|f04arfSolve,f| BOOT::|f04arfSolve,g| + BOOT::|modeEqual| BOOT::|f04mbfSolve,l| + BOOT::|displayWarning| BOOT::|f04mbfSolve,o| + BOOT::|addContour| BOOT::|f04asfSolve,f| + BOOT::|f04asfSolve,g| BOOT::|deleteAssoc| + BOOT::|purgeNewConstructorLines| + BOOT::|filterListOfStrings| BOOT::|asyDocumentation,fn| + BOOT::|satisfiesRegularExpressions| BOOT::|displayProplist| + BOOT::|transformAndRecheckComments| + BOOT::|displaySemanticError| BOOT::|asySignature| + BOOT::|f04mbfSolve,h| BOOT::|asyTypeUnitDeclare| + BOOT::|f04mbfSolve,k| BOOT::|asyCatSignature| + BOOT::|dbSpreadComments| BOOT::|computeAncestorsOf| + BOOT::|descendantsOf| BOOT::|f04atfSolve,f| + BOOT::|f04atfSolve,g| BOOT::|f04adfSolve,gb| + BOOT::|reportOpsFromLisplib| BOOT::|f07fdfSolve,fa| + BOOT::|f07fdfSolve,fb| BOOT::|f07aefSolve,fa| + BOOT::|f07aefSolve,faa| BOOT::|f07adfSolve,fa| + BOOT::|f07adfSolve,fb| BOOT::|childArgCheck| + BOOT::|f07aefSolve,fb| BOOT::POSN1 BOOT::|assocCar| + BOOT::|childAssoc| BOOT::|f07fefSolve,fb| + BOOT::|f07fefSolve,fbb| BOOT::|ancestorsAdd| + BOOT::|f07fefSolve,fa| BOOT::|quickOr| + BOOT::|f07fefSolve,faa| BOOT::|f07aefSolve,fbb| + BOOT::|explodeIfs,gn| BOOT::|f01qdfSolve,fa| + BOOT::|f01qdfSolve,ga| BOOT::|dbGatherDataImplementation| + BOOT::|dbMakeSignature| BOOT::|dbExposed?| + BOOT::|getRegistry| BOOT::|opAlistCount| + BOOT::|f01rdfSolve,gb| BOOT::|bcStarSpaceOp| + BOOT::|evalDomainOpPred,convert| BOOT::|f02aefSolve,f| + BOOT:|Sort| BOOT::|f02aefSolve,g| BOOT:|SortInPlace| + BOOT::|evalDomainOpPred,evpred| BOOT::|f02aefSolve,h| + BOOT::|evalDomainOpPred,evpred1| BOOT::|f02abfSolve,f| + BOOT::|f02abfSolve,g| BOOT::|f02aafSolve,f| + BOOT::|f02aafSolve,g| BOOT::|evalDomainOpPred| + BOOT::|getDomainOpTable,memq| BOOT::|f02ajfSolve,h| + BOOT::|f02ajfSolve,l| BOOT::|superMatch?| + BOOT::|f02affSolve,f| BOOT::|f02affSolve,g| + BOOT:|ByteFileWriteLine| BOOT::NREVERSE-N + BOOT::|f02adfSolve,h| BOOT::|f02adfSolve,l| + FOAM:|fiSetDebugger| BOOT::TRUNCLIST-1 + BOOT::|f02bjfSolve,h| BOOT::-REDUCE-OP + BOOT::|f02bjfSolve,l| BOOT::OR2 BOOT::|f02axfSolve,h| + BOOT::AND2 BOOT::|f02axfSolve,l| BOOT::|f02ajfSolve,f| + BOOT::REPEAT-TRAN BOOT::|f02ajfSolve,g| BOOT::MKPFFLATTEN + BOOT::|f02akfSolve,h| BOOT:|StreamSetPosition| + BOOT::|f02akfSolve,l| BOOT::MKPF1 BOOT::|f02axfSolve,f| + BOOT::|f02axfSolve,g| BOOT::-REPEAT BOOT::|f02xefSolve,fb| + BOOT::|CONTAINED,EQUAL| BOOT::|f02xefSolve,gb| + BOOT::|CONTAINED,EQ| BOOT::|f02awfSolve,h| + BOOT::|f02awfSolve,l| BOOT::|kPageArgs| + BOOT::|dbSubConform| BOOT::|f02akfSolve,f| + BOOT::|f02akfSolve,g| BOOT:|PathnameWithType| + BOOT::MARKHASH BOOT:|PathnameWithDirectory| + BOOT::|f02bjfSolve,f| BOOT::|f02bjfSolve,g| + BOOT::|f02adfSolve,f| BOOT::|f02adfSolve,g| BOOT::|,MIN| + BOOT:|PathnameWithinDirectory| + BOOT::|domainDescendantsOf,jfn| + BOOT::|domainDescendantsOf,catScreen| BOOT::|,MAX| + BOOT:|PathnameWithinOsEnvVar| BOOT::LEXLESSEQP + BOOT::|,DIFFERENCE| BOOT::GLESSEQP BOOT::MAKE-INIT-VECTOR + BOOT::|,TIMES| BOOT::|,PLUS| BOOT::|f02awfSolve,f| + BOOT::|f02awfSolve,g| BOOT::SUBB BOOT::|getCDTEntry| + BOOT::|f02xefSolve,fa| BOOT::|f02xefSolve,ga| + BOOT::|stuffSlots| BOOT::|domainDescendantsOf| BOOT::DO_LET + BOOT::|f02agfSolve,f| BOOT:|CsetMember?| + BOOT::|f02agfSolve,g| BOOT::|measureCommon,fn| + BOOT:|CsetUnion| BOOT::|f02wefSolve,fb| + BOOT::|f02wefSolve,gb| BOOT::|deleteWOC| + BOOT::|f02bbfSolve,f| BOOT::|next| BOOT::|f02bbfSolve,g| + BOOT::|suffix?| BOOT::|list2LongerVec| + BOOT::|f02wefSolve,fa| BOOT::|mkCurryFun| + BOOT::|f02wefSolve,ga| BOOT::|logicalMatch?| + BOOT::|subCopy0| BOOT::|patternCheck,wild| + BOOT:|StringFromToEnd| BOOT::|beforeAfter| + BOOT::|deepSubCopyOrNil| BOOT::|patternCheck,pos| + BOOT:|StringGreater?| BOOT::|deepSubCopy0| BOOT::|prefix?| + BOOT:|StringPrefix?| BOOT::|subCopyOrNil| + BOOT::|htpSetInputAreaAlist| BOOT::|termRW1| + BOOT::|processInteractive| BOOT::|termRW| + BOOT::|maskMatch?| BOOT::|tdAdd| BOOT::|filterByTopic| + BOOT::|addTopic2Documentation| BOOT::|addStats| + BOOT::|transferCodeCon| BOOT::|compileCases| + BOOT::|transferClassCodes| BOOT::|addArgumentConditions| + BOOT::|NRTassignCapsuleFunctionSlot| + BOOT::|reportSpadTrace| BOOT::BVEC-NOR BOOT::BVEC-NAND + BOOT::|addDomain| BOOT::|giveFormalParametersValues| + BOOT::PRINT-DEFUN BOOT::|augmentTraceNames| + BOOT::|stripOffSubdomainConditions| + BOOT::|untraceDomainLocalOps| BOOT::TRANSLABEL1 + BOOT::|getOption| BOOT::TRANSLABEL BOOT::|traceOptionError| + BOOT::GET-GLIPH-TOKEN BOOT::|funfind,LAM| + BOOT::|mergePathnames| BOOT::|subTypes| BOOT::|lassocSub| + BOOT::|dbWordFrom| BOOT::|commandUserLevelError| + BOOT::|applyGrep| BOOT::|htButtonOn?| + BOOT::|generalSearchString| BOOT::|zsystemdevelopment1| + BOOT::|grepForAbbrev| BOOT::|match?| BOOT::|commandError| + BOOT::|optionUserLevelError| BOOT::|firstDelim| BOOT::/READ + BOOT::|kciReduceOpAlist| BOOT::|dbInfoTran| + BOOT::|koPageInputAreaUnchanged?| BOOT::|dbInfoWrapOrigin| + BOOT::|insert| BOOT::|dbInfoSigMatch| BOOT::|ancestorsOf| + BOOT::|compIterator| BOOT::|getIdentity| + BOOT::|augmentHasArgs| BOOT::|processInteractive1| + BOOT::|recordAndPrint| BOOT::|interpretTopLevel| + BOOT::|substituteSegmentedMsg| + BOOT::|dbSpecialExpandIfNecessary| BOOT::|sameUnionBranch| + BOOT::|htpSetPageDescription| BOOT::|testBitVector| + BOOT::|dbShowConsDoc| BOOT::|printTypeAndTimeNormal| + BOOT::|satTypeDownLink| BOOT::|printTypeAndTimeSaturn| + BOOT::|mkDocLink| BOOT::|addParameterTemplates| + BOOT::|hasPair| BOOT::|htpAddToPageDescription| + BOOT::|getAliasIfTracedMapParameter| BOOT::|pfAbSynOp?| + BOOT::|printTypeAndTime| BOOT::|phReportMsgs| + BOOT::|untraceDomainConstructor,keepTraced?| + BOOT::|htpButtonValue| BOOT::|htSayConstructorName| + BOOT::|getMapSig| BOOT::|spadTrace,isTraceable| + BOOT::|removeOption| BOOT::|screenLocalLine| + BOOT::|undoSteps| BOOT::|agg| BOOT::|diffAlist| + BOOT::|undoSingleStep| BOOT::|htSayBind| + BOOT::|bcConstructor| BOOT::|checkArgs| + BOOT::SPADTAGS-FROM-DIRECTORY BOOT::|matSuperList1| + BOOT::|getBindingPowerOf| BOOT::|matSubList1| + BOOT::|matWList1| BOOT::NAG-FILES BOOT::|htpLabelDefault| + BOOT::GET-NAG-CHAPTER BOOT::|setNAGBootAutloadProperties| + BOOT::|htpLabelErrorMsg| BOOT::|setBootAutloadProperties| + BOOT::|setUpDefault| BOOT::|setBootAutoLoadProperty| + BOOT::|mkBootAutoLoad| BOOT::|matWList| VMLISP::ECQEXP + BOOT::|npTypedForm1| BOOT::|htMakeDoitButton| BOOT::|prnd| + BOOT::|reportAO| BOOT::BVEC-XOR BOOT::BVEC-OR + VMLISP::DCQEXP BOOT::BVEC-AND BOOT::BVEC-GREATER + BOOT::BVEC-EQUAL BOOT::BVEC-CONCAT BOOT::|stringLE1| + BOOT::BVEC-MAKE-FULL BOOT::|scylla| BOOT::|mkSuperSub| + BOOT::|EqualBarGensym| BOOT::|pfReturn| BOOT::|pfSpread| + BOOT::|npTypedForm| BOOT::|after| + BOOT::|optCatch,changeThrowToGo| + BOOT::|optCatch,hasNoThrows| + BOOT::|optCatch,changeThrowToExit| + BOOT::|optimizeFunctionDef,replaceThrowByReturn| + BOOT::|optCallSpecially,lookup| BOOT::|EqualBarGensym,fn| + BOOT::|pfLp| BOOT::|optimizeFunctionDef,fn| + BOOT::|htpSetRadioButtonAlist| BOOT::|pfWrong| + BOOT::|pfForin| BOOT::|pfDefinition| BOOT::|pfReturnTyped| + BOOT::|pfLam| BOOT::|pfIfThenOnly| BOOT::|pfExit| + BOOT::|printNamedStatsByProperty| BOOT::|Delay| + BOOT::|initializeTimedNames| BOOT::|searchTailEnv| + BOOT::|searchCurrentEnv| BOOT::|search| + BOOT::|e04ycfSolve,fc| BOOT::|insertWOC,fn| BOOT::|mkObj| + VMLISP:|union| BOOT::|coerceInt| BOOT::|deleteAssocWOC| + BOOT::|e04nafSolve,fa| BOOT::|deleteAssocWOC,fn| + BOOT::|e04nafSolve,fb| BOOT::|deleteLassoc| BOOT::REMALIST + BOOT::|sublisNQ| BOOT::|BooleanEquality| + BOOT::|sublisNQ,fn| BOOT::|modemapsHavingTarget| + BOOT::|PPtoFile| BOOT::|positionInVec| + BOOT::|e04mbfSolve,fa| BOOT::|e04mbfSolve,fb| + BOOT::|mkIterVarSub| BOOT::|lazyOldAxiomDomainDevaluate| + BOOT::|lazyOldAxiomDomainHashCode| BOOT::|declare| + BOOT::|declareMap| BOOT::|concat1| BOOT::|upfreeWithType| + BOOT::|uplocalWithType| BOOT::|deleteAll| + BOOT::|oldAxiomCategoryDevaluate| BOOT::|SExprToDName| + BOOT::|oldAxiomPreCategoryDevaluate| + BOOT::|checkForFreeVariables| BOOT::|f01rdfSolve,fa| + BOOT::|f01rdfSolve,ga| BOOT::|oldAxiomDomainDevaluate| + BOOT::|newHasCategory| BOOT::|orderedDefaults| + BOOT::|f01rdfSolve,fb| BOOT::|attributeNthParent| BOOT:DROP + BOOT::|oldAxiomDomainHashCode| BOOT::|attributeHashCode| + BOOT::|oldAxiomPreCategoryHashCode| + BOOT::|attributeDevaluate| BOOT::|f01refSolve,fa| + BOOT::|f01refSolve,ga| BOOT::|oldAxiomCategoryHashCode| + BOOT:APPLYR BOOT::|f01qcfSolve,f| BOOT::|evalLET| + BOOT::|f01qcfSolve,g| BOOT::|domainEqual| BOOT:STRINGSUFFIX + BOOT::|f01qefSolve,fa| BOOT::|compileIs| + BOOT::|f01qefSolve,ga| BOOT::|f01rcfSolve,fa| + BOOT::|f01rcfSolve,ga| BOOT:CONVERSATION + BOOT::|evalLETchangeValue| BOOT::|isPatternMatch| + BOOT::|seteltable| BOOT::|intSayKeyedMsg| + BOOT::|upLispCall| BOOT::|genIFvalCode| BOOT::|evalLETput| + BOOT::|f01qdfSolve,fb| BOOT::|f01qdfSolve,gb| + BOOT::|intloopProcessString| BOOT::|ncloopDQlines| + BOOT::|intloopInclude1| BOOT::|intloopInclude| + BOOT::|upIFgenValue| BOOT::|putPvarModes| + BOOT::|ncloopPrefix?| BOOT::|intloopPrefix?| + BOOT::|phIntReportMsgs| BOOT::|processMsgList| + BOOT::|phParse| BOOT:TAKE BOOT::|isPatMatch| + BOOT::|intloopReadConsole| BOOT::|streamChop| + BOOT::|inclFname| BOOT::|incDrop| BOOT:SETANDFILE + BOOT:PUSH-REDUCTION BOOT::|inclmsgFileCycle| + BOOT::|assertCond| BOOT::|incActive?| BOOT:TAILFN + BOOT:RPLACW BOOT::|incStream| BOOT::|inclHandleSay| + BOOT::|inclHandleWarning| BOOT:FLAGP + BOOT::|inclHandleError| BOOT:?ORDER BOOT::|incRenumberLine| + BOOT::|incRenumberItem| BOOT::|lnSetGlobalNum| BOOT:S* + FOAM::ALLOC-PROG-INFO BOOT::|liftCond,lcAnd| + BOOT::|actOnInfo| BOOT::|mkJoin| BOOT::|plural| + BOOT::|e04ucfSolve,fb| BOOT:MAKENEWOP BOOT::|has| + BOOT::|containedRight| BOOT::|hashTypeForm| BOOT:CONTAINED + BOOT::|oldAxiomPreCategoryParents| + BOOT::|oldAxiomCategoryDefaultPackage| BOOT:POINTW + BOOT::|linearFormatForm| BOOT::|newHasAttribute| + BOOT::|oldAxiomCategoryParentCount| + BOOT::|findSubstitutionOrder?,fn| BOOT::|app2StringConcat0| + BOOT::|formDecl2String| BOOT::|sayLooking1| + BOOT::|formJoin1| BOOT::|app2StringWrap| BOOT:S- + BOOT::|mkLessOrEqual| BOOT::|formArguments2String| + BOOT::|putValueValue| BOOT::|asTupleNew| BOOT::|objSetVal| + BOOT::|objNewCode| FOAM-USER::H-ERROR BOOT::|displayRule| + BOOT::|coerceInteractive| BOOT::|canMakeTuple| + FOAM-USER::H-STRING BOOT:CARCDREXPAND + BOOT::|formatOpSymbol| FOAM-USER::H-INTEGER + BOOT::|addPatternPred| BOOT::|interpMap| BOOT::|mkLocalVar| + BOOT:/EMBED-1 BOOT::|findLocalVars1| + BOOT::|queryUserKeyedMsg| BOOT::|mkFreeVar| + BOOT::|findLocalVars|)) +(PROCLAIM + '(FTYPE (FUNCTION NIL FIXNUM) BOOT::HEAPELAPSED + BOOT:|OsProcessNumber| BOOT::KCL-OS-PROCESS-NUMBER)) +(PROCLAIM + '(FTYPE (FUNCTION NIL (VALUES T T)) BOOT::MAKE-CLOSEDFN-NAME + BOOT::|genVariable| BOOT::|genSomeVariable| + BOOT::|genDomainVar| BOOT:GENVAR)) diff --git a/src/interp/intfile.boot b/src/interp/intfile.boot deleted file mode 100644 index 883047da..00000000 --- a/src/interp/intfile.boot +++ /dev/null @@ -1,61 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -shoeInternFile(fn)== - a:=shoeInputFile fn - if null a - then WRITE_-LINE (CONCAT(fn,'" not found"),_*TERMINAL_-IO_*) - else shoeIntern incRgen a - -shoeIntern (s)== - StreamNull s => nil - f:=CAR s - # f < 8 => shoeIntern CDR s - f.0=char " " =>shoeIntern CDR s - a:=INTERN SUBSTRING (f,0,8) - [b,c]:= shoeStrings CDR s - SETF(GET (a,"MSGS"),b) - shoeIntern c - -shoeStrings (stream)== - StreamNull stream => ['"",stream] - a:=CAR stream - if a.0^=char " " - then ['"",stream] - else - [h,t]:=shoeStrings(cdr stream) - [CONCAT(a,h),t] - ---fetchKeyedMsg(key,b)== GET(key,"MSGS") ---shoeInternFile '"/usr/local/scratchpad/cur/doc/msgs/co-eng.msgs" diff --git a/src/interp/intfile.boot.pamphlet b/src/interp/intfile.boot.pamphlet new file mode 100644 index 00000000..1dcdcf2d --- /dev/null +++ b/src/interp/intfile.boot.pamphlet @@ -0,0 +1,83 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp intfile.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +shoeInternFile(fn)== + a:=shoeInputFile fn + if null a + then WRITE_-LINE (CONCAT(fn,'" not found"),_*TERMINAL_-IO_*) + else shoeIntern incRgen a + +shoeIntern (s)== + StreamNull s => nil + f:=CAR s + # f < 8 => shoeIntern CDR s + f.0=char " " =>shoeIntern CDR s + a:=INTERN SUBSTRING (f,0,8) + [b,c]:= shoeStrings CDR s + SETF(GET (a,"MSGS"),b) + shoeIntern c + +shoeStrings (stream)== + StreamNull stream => ['"",stream] + a:=CAR stream + if a.0^=char " " + then ['"",stream] + else + [h,t]:=shoeStrings(cdr stream) + [CONCAT(a,h),t] + +--fetchKeyedMsg(key,b)== GET(key,"MSGS") +--shoeInternFile '"/usr/local/scratchpad/cur/doc/msgs/co-eng.msgs" +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/intint.lisp b/src/interp/intint.lisp deleted file mode 100644 index 0e53d571..00000000 --- a/src/interp/intint.lisp +++ /dev/null @@ -1,146 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(in-package "BOOT") - -(defun |intSayKeyedMsg| (key args) - (|sayKeyedMsg| (|packageTran| key) (|packageTran| args))) - -;;(defun |intMakeFloat| (int frac len exp) -;; (MAKE-FLOAT int frac len exp)) - -;;(defun |intSystemCommand| (command) -;; (catch 'SPAD_READER -;; (|systemCommand| (|packageTran| command)))) - -;;(defun |intUnAbbreviateKeyword| (keyword) -;; (|unAbbreviateKeyword| (|packageTran| keyword))) - -(defun |intProcessSynonyms| (str) - (let ((LINE str)) - (declare (special LINE)) - (|processSynonyms|) - LINE)) - -;; (defun |intNoParseCommands| () -;; |$noParseCommands|) - -;;(defun |intTokenCommands| () -;; |$tokenCommands|) - -(defun |intInterpretPform| (pf) - (|processInteractive| (|zeroOneTran| (|packageTran| (|pf2Sex| pf))) pf)) - -;;(defun |intSpadThrow| () -;; (|spadThrow|)) - -;;(defun |intMKPROMPT| (should? step) -;; (if should? (PRINC (MKPROMPT)))) - -(defvar |$intCoerceFailure| '|coerceFailure|) -(defvar |$intTopLevel| '|top_level|) -(defvar |$intSpadReader| 'SPAD_READER) -(defvar |$intRestart| '|restart|) - -;;(defun |intString2BootTree| (str) -;; (|string2BootTree| str)) - -;;(defun |intPackageTran| (sex) -;; (|packageTran| sex)) - -;;--------------------> NEW DEFINITION (override in i-syscmd.boot.pamphlet) -(defun |stripSpaces| (str) - (string-trim '(#\Space) str)) - -;;(defvar |$SessionManager| |$SessionManager|) -;;(defvar |$EndOfOutput| |$EndOfOutput|) - -;;(defun |intServerReadLine| (foo) -;; (|serverReadLine| foo)) - -;; (defun |intProcessSynonym| (str) -;; (|npProcessSynonym| str)) - -(defun |SpadInterpretFile| (fn) - (|SpadInterpretStream| 1 fn nil) ) - -(defun |intNewFloat| () - (list '|Float|)) - -;; (defun |intDoSystemCommand| (string) -;; (|doSystemCommand| string)) - -(defun |intSetNeedToSignalSessionManager| () - (setq |$NeedToSignalSessionManager| T)) - -;; (defun |intKeyedSystemError| (msg args) -;; (|keyedSystemError| msg args)) - -;;#-:CCL -;;(defun |stashInputLines| (l) -;; (|stashInputLines| l)) - -;;(defun |setCurrentLine| (s) -;; (setq |$currentLine| s)) - -(defun |setCurrentLine| (s) - (setq |$currentLine| - (cond ((null |$currentLine|) s) - ((stringp |$currentLine|) - (cons |$currentLine| - (if (stringp s) (cons s nil) s))) - (t (rplacd (last |$currentLine|) - (if (stringp s) (cons s nil) s)) - |$currentLine|)))) - -(defun |intnplisp| (s) - (setq |$currentLine| s) - (|nplisp| |$currentLine|)) - -;; (defun |intResetStackLimits| () (|resetStackLimits|)) - -(defun |intSetQuiet| () - (setq |$QuietCommand| T)) - -(defun |intUnsetQuiet| () - (setq |$QuietCommand| NIL)) - -;; (defun |expandTabs| (s) -;; (expand-tabs s)) - -;; #-:CCL -;; (defun |leaveScratchpad| () -;; (|leaveScratchpad|)) - -;;(defun |readingFile?| () -;; |$ReadingFile|) - diff --git a/src/interp/intint.lisp.pamphlet b/src/interp/intint.lisp.pamphlet new file mode 100644 index 00000000..d132ad87 --- /dev/null +++ b/src/interp/intint.lisp.pamphlet @@ -0,0 +1,168 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp intint.lisp} +\author{Timothy Daly} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(in-package "BOOT") + +(defun |intSayKeyedMsg| (key args) + (|sayKeyedMsg| (|packageTran| key) (|packageTran| args))) + +;;(defun |intMakeFloat| (int frac len exp) +;; (MAKE-FLOAT int frac len exp)) + +;;(defun |intSystemCommand| (command) +;; (catch 'SPAD_READER +;; (|systemCommand| (|packageTran| command)))) + +;;(defun |intUnAbbreviateKeyword| (keyword) +;; (|unAbbreviateKeyword| (|packageTran| keyword))) + +(defun |intProcessSynonyms| (str) + (let ((LINE str)) + (declare (special LINE)) + (|processSynonyms|) + LINE)) + +;; (defun |intNoParseCommands| () +;; |$noParseCommands|) + +;;(defun |intTokenCommands| () +;; |$tokenCommands|) + +(defun |intInterpretPform| (pf) + (|processInteractive| (|zeroOneTran| (|packageTran| (|pf2Sex| pf))) pf)) + +;;(defun |intSpadThrow| () +;; (|spadThrow|)) + +;;(defun |intMKPROMPT| (should? step) +;; (if should? (PRINC (MKPROMPT)))) + +(defvar |$intCoerceFailure| '|coerceFailure|) +(defvar |$intTopLevel| '|top_level|) +(defvar |$intSpadReader| 'SPAD_READER) +(defvar |$intRestart| '|restart|) + +;;(defun |intString2BootTree| (str) +;; (|string2BootTree| str)) + +;;(defun |intPackageTran| (sex) +;; (|packageTran| sex)) + +;;--------------------> NEW DEFINITION (override in i-syscmd.boot.pamphlet) +(defun |stripSpaces| (str) + (string-trim '(#\Space) str)) + +;;(defvar |$SessionManager| |$SessionManager|) +;;(defvar |$EndOfOutput| |$EndOfOutput|) + +;;(defun |intServerReadLine| (foo) +;; (|serverReadLine| foo)) + +;; (defun |intProcessSynonym| (str) +;; (|npProcessSynonym| str)) + +(defun |SpadInterpretFile| (fn) + (|SpadInterpretStream| 1 fn nil) ) + +(defun |intNewFloat| () + (list '|Float|)) + +;; (defun |intDoSystemCommand| (string) +;; (|doSystemCommand| string)) + +(defun |intSetNeedToSignalSessionManager| () + (setq |$NeedToSignalSessionManager| T)) + +;; (defun |intKeyedSystemError| (msg args) +;; (|keyedSystemError| msg args)) + +;;#-:CCL +;;(defun |stashInputLines| (l) +;; (|stashInputLines| l)) + +;;(defun |setCurrentLine| (s) +;; (setq |$currentLine| s)) + +(defun |setCurrentLine| (s) + (setq |$currentLine| + (cond ((null |$currentLine|) s) + ((stringp |$currentLine|) + (cons |$currentLine| + (if (stringp s) (cons s nil) s))) + (t (rplacd (last |$currentLine|) + (if (stringp s) (cons s nil) s)) + |$currentLine|)))) + +(defun |intnplisp| (s) + (setq |$currentLine| s) + (|nplisp| |$currentLine|)) + +;; (defun |intResetStackLimits| () (|resetStackLimits|)) + +(defun |intSetQuiet| () + (setq |$QuietCommand| T)) + +(defun |intUnsetQuiet| () + (setq |$QuietCommand| NIL)) + +;; (defun |expandTabs| (s) +;; (expand-tabs s)) + +;; #-:CCL +;; (defun |leaveScratchpad| () +;; (|leaveScratchpad|)) + +;;(defun |readingFile?| () +;; |$ReadingFile|) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/iterator.boot b/src/interp/iterator.boot deleted file mode 100644 index bdcea85b..00000000 --- a/src/interp/iterator.boot +++ /dev/null @@ -1,293 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% ITERATORS - -compReduce(form,m,e) == - compReduce1(form,m,e,$formalArgList) - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == - [collectOp,:itl,body]:= collectForm - if STRINGP op then op:= INTERN op - ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => - systemError ["illegal reduction form:",form] - $sideEffectsList: local - $until: local - $initList: local - $endTestList: local - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - acc:= GENSYM() - afterFirst:= GENSYM() - bodyVal:= GENSYM() - [part1,m,e]:= comp(["LET",bodyVal,body],m,e) or return nil - [part2,.,e]:= comp(["LET",acc,bodyVal],m,e) or return nil - [part3,.,e]:= comp(["LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil - identityCode:= - id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil - ["IdentityError",MKQ op] - finalCode:= - ["PROGN", - ["LET",afterFirst,nil], - ["REPEAT",:itl, - ["PROGN",part1, - ["IF", afterFirst,part3, - ["PROGN",part2,["LET",afterFirst,MKQ true]]]]], - ["IF",afterFirst,acc,identityCode]] - if $until then - [untilCode,.,e]:= comp($until,$Boolean,e) - finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode) - [finalCode,m,e] - -getIdentity(x,e) == - GETL(x,"THETA") is [y] => y - -numberize x == - x=$Zero => 0 - x=$One => 1 - atom x => x - [numberize first x,:numberize rest x] - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTVEC - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u - ["PrimitiveArray",m'] - repeatOrCollect="COLLECTVEC" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' - coerceExit([form',m'',e'],targetMode) - ---constructByModemap([x,source,e],target) == --- u:= --- [cexpr --- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [ --- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil --- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil --- [["call",fn,x],target,e] - -listOrVectorElementMode x == - x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - $formalArgList:= [x,:$formalArgList] - [mOver,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - [y'',m'',e] := coerce([y',m,e], mOver) or return nil - [["IN",x,y''],e] - it is ["ON",x,y] => - $formalArgList:= [x,:$formalArgList] - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [mOver,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [y'',m'',e] := coerce([y',m,e], mOver) or return nil - [["ON",x,y''],e] - it is ["STEP",index,start,inc,:optFinal] => - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil - (start':= comp(start,$SmallInteger,e)) and - (inc':= comp(inc,$NonNegativeInteger,start'.env)) and - (not (optFinal is [final]) or - (final':= comp(final,$SmallInteger,inc'.env))) => - indexmode:= - comp(start,$NonNegativeInteger,e) => - $NonNegativeInteger - $SmallInteger - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - if final' then optFinal:= [final'.expr] - [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] - [start,.,e]:= - comp(start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - [["STEP",index,start,inc,:optFinal],e] - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - [["WHILE",p'],e] - it is ["UNTIL",p] => ($until:= p; ['$until,e]) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - [["|",u.expr],u.env] - nil - ---isAggregateMode(m,e) == --- m is [c,R] and MEMQ(c,'(Vector List)) => R --- name:= --- m is [fn,:.] => fn --- m="$" => "Rep" --- m --- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R - -modeIsAggregateOf(ListOrVector,m,e) == - m is [ =ListOrVector,R] => [m,R] ---m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + - m is ["Union",:l] => - mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] - 1=#mList => first mList - name:= - m is [fn,:.] => fn - m="$" => "Rep" - m - get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] - ---% VECTOR ITERATORS - ---the following 4 functions are not currently used - ---compCollectV(form,m,e) == --- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where --- fn(form,$exitModeStack,$leaveLevelStack,e) == --- [repeatOrCollect,it,body]:= form --- [it',e]:= compIteratorV(it,e) or return nil --- m:= first $exitModeStack --- [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode --- [body',m',e']:= compOrCroak(body,mUnder,e) or return nil --- form':= ["COLLECTV",it',body'] --- {n:= --- it' is ("STEP",.,s,i,f) or it' is ("ISTEP",.,s,i,f) => --- computeMaxIndex(s,f,i); --- return nil} --- coerce([form',mOver,e'],m) --- ---compIteratorV(it,e) == --- it is ["STEP",index,start,inc,final] => --- (start':= comp(start,$Integer,e)) and --- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and --- (final':= comp(final,$Integer,inc'.env)) => --- indexmode:= --- comp(start,$NonNegativeInteger,e) => $NonNegativeInteger --- $Integer --- if null get(index,"mode",e) then [.,.,e]:= --- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or --- return nil --- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) --- [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] --- [start,.,e]:= --- comp(start,$Integer,e) or return --- stackMessage ["start value of index: ",start," is not an integer"] --- [inc,.,e]:= --- comp(inc,$NonNegativeInteger,e) or return --- stackMessage ["index increment: ",inc," must be a non-negative integer"] --- [final,.,e]:= --- comp(final,$Integer,e) or return --- stackMessage ["final value of index: ",final," is not an integer"] --- indexmode:= --- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger --- $Integer --- if null get(index,"mode",e) then [.,.,e]:= --- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil --- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) --- [["STEP",index,start,inc,final],e] --- nil --- ---computeMaxIndex(s,f,i) == --- i^=1 => cannotDo() --- s=1 => f --- exprDifference(f,exprDifference(s,1)) --- ---exprDifference(x,y) == --- y=0 => x --- FIXP x and FIXP y => DIFFERENCE(x,y) --- ["DIFFERENCE",x,y] - diff --git a/src/interp/iterator.boot.pamphlet b/src/interp/iterator.boot.pamphlet new file mode 100644 index 00000000..52dae4f7 --- /dev/null +++ b/src/interp/iterator.boot.pamphlet @@ -0,0 +1,319 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/iterator.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% ITERATORS + +compReduce(form,m,e) == + compReduce1(form,m,e,$formalArgList) + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == + [collectOp,:itl,body]:= collectForm + if STRINGP op then op:= INTERN op + ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => + systemError ["illegal reduction form:",form] + $sideEffectsList: local + $until: local + $initList: local + $endTestList: local + $e:= e + itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] + itl="failed" => return nil + e:= $e + acc:= GENSYM() + afterFirst:= GENSYM() + bodyVal:= GENSYM() + [part1,m,e]:= comp(["LET",bodyVal,body],m,e) or return nil + [part2,.,e]:= comp(["LET",acc,bodyVal],m,e) or return nil + [part3,.,e]:= comp(["LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil + identityCode:= + id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil + ["IdentityError",MKQ op] + finalCode:= + ["PROGN", + ["LET",afterFirst,nil], + ["REPEAT",:itl, + ["PROGN",part1, + ["IF", afterFirst,part3, + ["PROGN",part2,["LET",afterFirst,MKQ true]]]]], + ["IF",afterFirst,acc,identityCode]] + if $until then + [untilCode,.,e]:= comp($until,$Boolean,e) + finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode) + [finalCode,m,e] + +getIdentity(x,e) == + GETL(x,"THETA") is [y] => y + +numberize x == + x=$Zero => 0 + x=$One => 1 + atom x => x + [numberize first x,:numberize rest x] + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTVEC + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= + -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or + compOrCroak(body,bodyMode,e) or return nil + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u + ["PrimitiveArray",m'] + repeatOrCollect="COLLECTVEC" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' + coerceExit([form',m'',e'],targetMode) + +--constructByModemap([x,source,e],target) == +-- u:= +-- [cexpr +-- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [ +-- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil +-- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil +-- [["call",fn,x],target,e] + +listOrVectorElementMode x == + x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + $formalArgList:= [x,:$formalArgList] + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of some mode"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["IN",x,y''],e] + it is ["ON",x,y] => + $formalArgList:= [x,:$formalArgList] + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of other modes"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["ON",x,y''],e] + it is ["STEP",index,start,inc,:optFinal] => + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil + (start':= comp(start,$SmallInteger,e)) and + (inc':= comp(inc,$NonNegativeInteger,start'.env)) and + (not (optFinal is [final]) or + (final':= comp(final,$SmallInteger,inc'.env))) => + indexmode:= + comp(start,$NonNegativeInteger,e) => + $NonNegativeInteger + $SmallInteger + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + if final' then optFinal:= [final'.expr] + [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] + [start,.,e]:= + comp(start,$Integer,e) or return + stackMessage ["start value of index: ",start," must be an integer"] + [inc,.,e]:= + comp(inc,$Integer,e) or return + stackMessage ["index increment:",inc," must be an integer"] + if optFinal is [final] then + [final,.,e]:= + comp(final,$Integer,e) or return + stackMessage ["final value of index: ",final," must be an integer"] + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + [["STEP",index,start,inc,:optFinal],e] + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage ["WHILE operand: ",p," is not Boolean valued"] + [["WHILE",p'],e] + it is ["UNTIL",p] => ($until:= p; ['$until,e]) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] + [["|",u.expr],u.env] + nil + +--isAggregateMode(m,e) == +-- m is [c,R] and MEMQ(c,'(Vector List)) => R +-- name:= +-- m is [fn,:.] => fn +-- m="$" => "Rep" +-- m +-- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R + +modeIsAggregateOf(ListOrVector,m,e) == + m is [ =ListOrVector,R] => [m,R] +--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + + m is ["Union",:l] => + mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] + 1=#mList => first mList + name:= + m is [fn,:.] => fn + m="$" => "Rep" + m + get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] + +--% VECTOR ITERATORS + +--the following 4 functions are not currently used + +--compCollectV(form,m,e) == +-- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where +-- fn(form,$exitModeStack,$leaveLevelStack,e) == +-- [repeatOrCollect,it,body]:= form +-- [it',e]:= compIteratorV(it,e) or return nil +-- m:= first $exitModeStack +-- [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode +-- [body',m',e']:= compOrCroak(body,mUnder,e) or return nil +-- form':= ["COLLECTV",it',body'] +-- {n:= +-- it' is ("STEP",.,s,i,f) or it' is ("ISTEP",.,s,i,f) => +-- computeMaxIndex(s,f,i); +-- return nil} +-- coerce([form',mOver,e'],m) +-- +--compIteratorV(it,e) == +-- it is ["STEP",index,start,inc,final] => +-- (start':= comp(start,$Integer,e)) and +-- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and +-- (final':= comp(final,$Integer,inc'.env)) => +-- indexmode:= +-- comp(start,$NonNegativeInteger,e) => $NonNegativeInteger +-- $Integer +-- if null get(index,"mode",e) then [.,.,e]:= +-- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or +-- return nil +-- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +-- [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] +-- [start,.,e]:= +-- comp(start,$Integer,e) or return +-- stackMessage ["start value of index: ",start," is not an integer"] +-- [inc,.,e]:= +-- comp(inc,$NonNegativeInteger,e) or return +-- stackMessage ["index increment: ",inc," must be a non-negative integer"] +-- [final,.,e]:= +-- comp(final,$Integer,e) or return +-- stackMessage ["final value of index: ",final," is not an integer"] +-- indexmode:= +-- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger +-- $Integer +-- if null get(index,"mode",e) then [.,.,e]:= +-- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil +-- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +-- [["STEP",index,start,inc,final],e] +-- nil +-- +--computeMaxIndex(s,f,i) == +-- i^=1 => cannotDo() +-- s=1 => f +-- exprDifference(f,exprDifference(s,1)) +-- +--exprDifference(x,y) == +-- y=0 => x +-- FIXP x and FIXP y => DIFFERENCE(x,y) +-- ["DIFFERENCE",x,y] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot deleted file mode 100644 index 4075f572..00000000 --- a/src/interp/lisplib.boot +++ /dev/null @@ -1,686 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Standard Library Creation Functions - -readLib(fn,ft) == readLib1(fn,ft,"*") - -readLib1(fn,ft,fm) == - -- see if it exists first - p := pathname [fn,ft,fm] - readLibPathFast p - -readLibPathFast p == - -- assumes 1) p is a valid pathname - -- 2) file has already been checked for existence - RDEFIOSTREAM([['FILE,:p], '(MODE . INPUT)],false) - -writeLib(fn,ft) == writeLib1(fn,ft,"*") - -writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] - -putFileProperty(fn,ft,id,val) == - fnStream:= writeLib1(fn,ft,"*") - val:= rwrite( id,val,fnStream) - RSHUT fnStream - val - -lisplibWrite(prop,val,filename) == - -- this may someday not write NIL keys, but it will now - if $LISPLIB then - rwrite128(prop,val,filename) - -rwrite128(key,value,stream) == - rwrite(key,value,stream) - -evalAndRwriteLispForm(key,form) == - eval form - rwriteLispForm(key,form) - -rwriteLispForm(key,form) == - if $LISPLIB then - rwrite( key,form,$libFile) - LAM_,FILEACTQ(key,form) - -getLisplib(name,id) == - -- this version does cache the returned value - getFileProperty(name,$spadLibFT,id,true) - -getLisplibNoCache(name,id) == - -- this version does not cache the returned value - getFileProperty(name,$spadLibFT,id,false) - -getFileProperty(fn,ft,id,cache) == - fn in '(DOMAIN SUBDOM MODE) => nil - p := pathname [fn,ft,'"*"] - cache => hasFileProperty(p,id,fn) - hasFilePropertyNoCache(p,id,fn) - -hasFilePropertyNoCache(p,id,abbrev) == - -- it is assumed that the file exists and is a proper pathname - -- startTimingProcess 'diskread - fnStream:= readLibPathFast p - NULL fnStream => NIL - -- str:= object2String id - val:= rread(id,fnStream, nil) - RSHUT fnStream - -- stopTimingProcess 'diskread - val - ---% Uninstantiating - -unInstantiate(clist) == - for c in clist repeat - clearConstructorCache(c) - killNestedInstantiations(clist) - -killNestedInstantiations(deps) == - for key in HKEYS($ConstructorCache) - repeat - for [arg,count,:inst] in HGET($ConstructorCache,key) repeat - isNestedInstantiation(inst.0,deps) => - HREMPROP($ConstructorCache,key,arg) - -isNestedInstantiation(form,deps) == - form is [op,:argl] => - op in deps => true - or/[isNestedInstantiation(x,deps) for x in argl] - false - ---% Loading - -loadLibIfNotLoaded libName == - -- replaces old SpadCondLoad - -- loads is library is not already loaded - $PrintOnly = 'T => NIL - GETL(libName,'LOADED) => NIL - loadLib libName - -loadLib cname == - startTimingProcess 'load - fullLibName := GETDATABASE(cname,'OBJECT) or return nil - systemdir? := isSystemDirectory(pathnameDirectory fullLibName) - update? := $forceDatabaseUpdate or not systemdir? - not update? => - loadLibNoUpdate(cname, cname, fullLibName) - kind := GETDATABASE(cname,'CONSTRUCTORKIND) - if $printLoadMsgs then - sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) - LOAD(fullLibName) - clearConstructorCache cname - updateDatabase(cname,cname,systemdir?) - installConstructor(cname,kind) - u := GETDATABASE(cname, 'CONSTRUCTORMODEMAP) - updateCategoryTable(cname,kind) - coSig := - u => - [[.,:sig],:.] := u - CONS(NIL,[categoryForm?(x) for x in CDR sig]) - NIL - -- in following, add property value false or NIL to possibly clear - -- old value - if null CDR GETDATABASE(cname,'CONSTRUCTORFORM) then - MAKEPROP(cname,'NILADIC,'T) - else - REMPROP(cname,'NILADIC) - MAKEPROP(cname,'LOADED,fullLibName) - if $InteractiveMode then $CategoryFrame := [[nil]] - stopTimingProcess 'load - 'T - -loadLibNoUpdate(cname, libName, fullLibName) == - kind := GETDATABASE(cname,'CONSTRUCTORKIND) - if $printLoadMsgs then - sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) - if CATCH('VERSIONCHECK,LOAD(fullLibName)) = -1 - then - PRINC('" wrong library version...recompile ") - PRINC(fullLibName) - TERPRI() - TOPLEVEL() - else - clearConstructorCache cname - installConstructor(cname,kind) - MAKEPROP(cname,'LOADED,fullLibName) - if $InteractiveMode then $CategoryFrame := [[nil]] - stopTimingProcess 'load - 'T - -loadIfNecessary u == loadLibIfNecessary(u,true) - -loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) - -loadLibIfNecessary(u,mustExist) == - u = '$EmptyMode => u - null atom u => loadLibIfNecessary(first u,mustExist) - value:= - functionp(u) or macrop(u) => u - GETL(u,'LOADED) => u - loadLib u => u - null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) - or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => - y:= GETDATABASE(u,'CONSTRUCTORKIND) => - y = 'category => - updateCategoryFrameForCategory u - updateCategoryFrameForConstructor u - throwKeyedMsg("S2IL0005",[u]) - value - -convertOpAlist2compilerInfo(opalist) == - "append"/[[formatSig(op,sig) for sig in siglist] - for [op,:siglist] in opalist] where - formatSig(op, [typelist, slot,:stuff]) == - pred := if stuff then first stuff else 'T - impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST - [[op, typelist], pred, [impl, '$, slot]] - -updateCategoryFrameForConstructor(constructor) == - opAlist := GETDATABASE(constructor, 'OPERATIONALIST) - [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) - $CategoryFrame := put(constructor,'isFunctor, - convertOpAlist2compilerInfo(opAlist), - addModemap(constructor, dc, sig, pred, impl, - put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) - -updateCategoryFrameForCategory(category) == - [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) - $CategoryFrame := - put(category, 'isCategory, 'T, - addModemap(category, dc, sig, pred, impl, $CategoryFrame)) - -loadFunctor u == - null atom u => loadFunctor first u - loadLibIfNotLoaded u - u - -makeConstructorsAutoLoad() == - for cnam in allConstructors() repeat - REMPROP(cnam,'LOADED) --- fn:=GETDATABASE(cnam,'ABBREVIATION) - if GETDATABASE(cnam,'NILADIC) - then PUT(cnam,'NILADIC,'T) - else REMPROP(cnam,'NILADIC) - systemDependentMkAutoload(cnam,cnam) - -systemDependentMkAutoload(fn,cnam) == - FBOUNDP(cnam) => "next" - asharpName := GETDATABASE(cnam, 'ASHARP?) => - kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) - cosig := GETDATABASE(cnam, 'COSIG) - file := GETDATABASE(cnam, 'OBJECT) - SET_-LIB_-FILE_-GETTER(file, cnam) - kind = 'category => - ASHARPMKAUTOLOADCATEGORY(file, cnam, asharpName, cosig) - ASHARPMKAUTOLOADFUNCTOR(file, cnam, asharpName, cosig) - SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - -autoLoad(abb,cname) == - if not GETL(cname,'LOADED) then loadLib cname - SYMBOL_-FUNCTION cname - -setAutoLoadProperty(name) == --- abb := constructor? name - REMPROP(name,'LOADED) - SETF(SYMBOL_-FUNCTION name,mkAutoLoad(name, name)) - ---% Compilation - -compileConstructorLib(l,op,editFlag,traceFlag) == - --this file corresponds to /C,1 - MEMQ('_?,l) => return editFile '(_/C TELL _*) - optionList:= _/OPTIONS l - funList:= TRUNCLIST(l,optionList) or [_/FN] - options:= [[UPCASE CAR x,:CDR x] for x in optionList] - infile:= _/MKINFILENAM _/GETOPTION(options,'FROM_=) - outfile:= _/MKINFILENAM _/GETOPTION(options,'TO_=) - res:= [compConLib1(fn,infile,outfile,op,editFlag,traceFlag) - for fn in funList] - SHUT INPUTSTREAM - res - -compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == - $PRETTYPRINT: local := 'T - $LISPLIB: local := 'T - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL - $lisplibForm: local := NIL - $lisplibAbbreviation: local := NIL - $lisplibParents: local := NIL - $lisplibAncestors: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibSlot1 : local := NIL --used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibOpAlist: local:= NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibSignatureAlist: local := NIL - if null atom fun and null CDR fun then fun:= CAR fun -- unwrap nullary - libName:= getConstructorAbbreviation fun - infile:= infileOrNil or getFunctionSourceFile fun or - throwKeyedMsg("S2IL0004",[fun]) - SETQ(_/EDITFILE,infile) - outfile := outfileOrNil or - [libName,'OUTPUT,$listingDirectory] --always QUIET - _$ERASE(libName,'OUTPUT,$listingDirectory) - outstream:= DEFSTREAM(outfile,'OUTPUT) - val:= _/D_,2_,LIB(fun,infile,outstream,auxOp,editFlag,traceFlag) - val - -compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibAbbreviation: local := NIL - $lisplibParents: local := NIL - $lisplibAncestors: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibSlot1 : local := NIL -- used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL --- $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc - $lisplibCategory: local := nil - --for categories, is rhs of definition; otherwise, is target of functor - --will eventually become the "constructorCategory" property in lisplib - --set in compDefineCategory1 if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - BOUNDP '$compileDocumentation and $compileDocumentation => - compileDocumentation libName - sayMSG ['" initializing ",$spadLibFT,:bright libName, - '"for",:bright op] - initializeLisplib libName - sayMSG ['" compiling into ",$spadLibFT,:bright libName] - -- res:= FUNCALL(fn,df,m,e,prefix,fal) - -- sayMSG ['" finalizing ",$spadLibFT,:bright libName] - -- finalizeLisplib libName - -- following guarantee's compiler output files get closed. - ok := false; - UNWIND_-PROTECT( - PROGN(res:= FUNCALL(fn,df,m,e,prefix,fal), - sayMSG ['" finalizing ",$spadLibFT,:bright libName], - finalizeLisplib libName, - ok := true), - RSHUT $libFile) - if ok then lisplibDoRename(libName) - filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) - RPACKFILE filearg - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - LOCALDATABASE(LIST GETDATABASE(op,'ABBREVIATION),NIL) - $newConlist := [op, :$newConlist] ----------> bound in function "compiler" - if $lisplibKind = 'category - then updateCategoryFrameForCategory op - else updateCategoryFrameForConstructor op - res - -compileDocumentation libName == - filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) - $FCOPY(filename,[libName,'DOCLB]) - stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] - lisplibWrite('"documentation",finalizeDocumentation(),stream) --- if $lisplibRelatedDomains then --- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) - RSHUT(stream) - RPACKFILE([libName,'DOCLB]) - $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) - ['dummy, $EmptyMode, $e] - -getLisplibVersion libName == - stream := RDEFIOSTREAM [['FILE,libName,$spadLibFT],['MODE, :'I]] - version:= CADR rread('VERSION, stream,nil) - RSHUT(stream) - version - -initializeLisplib libName == - _$ERASE(libName,'ERRORLIB,$libraryDirectory) - SETQ(ERRORS,0) -- ERRORS is a fluid variable for the compiler - $libFile:= writeLib1(libName,'ERRORLIB,$libraryDirectory) - ADDOPTIONS('FILE,$libFile) - $lisplibForm := nil --defining form for lisplib - $lisplibModemap := nil --modemap for constructor form - $lisplibKind := nil --category, domain, or package - $lisplibModemapAlist := nil --changed in "augmentLisplibModemapsFromCategory" - $lisplibAbbreviation := nil - $lisplibAncestors := nil - $lisplibOpAlist := nil --operations alist for new runtime system - $lisplibOperationAlist := nil --old list of operations for functor/package - $lisplibSuperDomain:= nil - -- next var changed in "augmentLisplibDependents" - $lisplibVariableAlist := nil --this and the next are used by "luke" - $lisplibSignatureAlist := nil - if pathnameTypeId(_/EDITFILE) = 'SPAD - then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION]) - -finalizeLisplib libName == - lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) - lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) - lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) - $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget - -- set to target of modemap for package/domain constructors; - -- to the right-hand sides (the definition) for category constructors - lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) - lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) - lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) - opsAndAtts:= getConstructorOpsAndAtts( - $lisplibForm,kind,$lisplibModemap) - lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) - --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) - --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts - if kind='category then - $pairlis : local := [[a,:v] for a in rest $lisplibForm - for v in $FormalMapVariableList] - $NRTslot1PredicateList : local := [] - NRTgenInitialAttributeAlist CDR opsAndAtts - lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) - lisplibWrite('"signaturesAndLocals", - removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, - $lisplibVariableAlist),$libFile) - lisplibWrite('"attributes",removeZeroOne $lisplibAttributes,$libFile) - lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) - lisplibWrite('"abbreviation",$lisplibAbbreviation,$libFile) - lisplibWrite('"parents",removeZeroOne $lisplibParents,$libFile) - lisplibWrite('"ancestors",removeZeroOne $lisplibAncestors,$libFile) - lisplibWrite('"documentation",finalizeDocumentation(),$libFile) - lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) - if $profileCompiler then profileWrite() - if $lisplibForm and null CDR $lisplibForm then - MAKEPROP(CAR $lisplibForm,'NILADIC,'T) - ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler - sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] - sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] - -lisplibDoRename(libName) == - _$REPLACE([libName,$spadLibFT,$libraryDirectory], - [libName,'ERRORLIB,$libraryDirectory]) - -lisplibError(cname,fname,type,cn,fn,typ,error) == - sayMSG bright ['" Illegal ",$spadLibFT] - error in '(duplicateAbb wrongType) => - sayKeyedMsg("S2IL0007", - [namestring [fname,$spadLibFT],type,cname,typ,cn]) - error is 'abbIsName => - throwKeyedMsg("S2IL0008",[fname,typ,namestring [fn,$spadLibFT]]) - -getPartialConstructorModemapSig(c) == - (s := getConstructorSignature c) => rest s - throwEvalTypeMsg("S2IL0015",[c]) - -mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == - -- this function makes a single Alist for both signatures - -- and local variable types, to be stored in the LISPLIB - -- for the function being compiled - [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for - [funcName, :signature] in signatureAlist] - -Operators u == - ATOM u => [] - ATOM first u => - answer:="union"/[Operators v for v in rest u] - MEMQ(first u,answer) => answer - [first u,:answer] - "union"/[Operators v for v in u] - -getConstructorOpsAndAtts(form,kind,modemap) == - kind is 'category => getCategoryOpsAndAtts(form) - getFunctorOpsAndAtts(form,modemap) - -getCategoryOpsAndAtts(catForm) == - -- returns [operations,:attributes] of CAR catForm - [transformOperationAlist getSlotFromCategoryForm(catForm,1), - :getSlotFromCategoryForm(catForm,2)] - -getFunctorOpsAndAtts(form,modemap) == - [transformOperationAlist getSlotFromFunctor(form,1,modemap), - :getSlotFromFunctor(form,2,modemap)] - -getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == - slot = 1 => $lisplibOperationAlist - t := compMakeCategoryObject(target,$e) or - systemErrorHere '"getSlotFromFunctor" - t.expr.slot - -getSlot1 domainName == - $e: local:= $CategoryFrame - fn:= getLisplibName domainName - p := pathname [fn,$spadLibFT,'"*"] - not isExistingFile(p) => - sayKeyedMsg("S2IL0003",[namestring p]) - NIL - (sig := getConstructorSignature domainName) => - [.,target,:argMml] := sig - for a in $FormalMapVariableList for m in argMml repeat - $e:= put(a,'mode,m,$e) - t := compMakeCategoryObject(target,$e) or - systemErrorHere '"getSlot1" - t.expr.1 - sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) - NIL - -transformOperationAlist operationAlist == - -- this transforms the operationAlist which is written out onto LISPLIBs. - -- The original form of this list is a list of items of the form: - -- (( ) ( (ELT $ n))) - -- The new form is an op-Alist which has entries ( . signature-Alist) - -- where signature-Alist has entries ( . item) - -- where item has form ( ) - -- where = - -- NIL => function - -- CONST => constant ... and others - newAlist:= nil - for [[op,sig,:.],condition,implementation] in operationAlist repeat - kind:= - implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc - implementation is [impOp,:.] => - impOp = 'XLAM => implementation - impOp in '(CONST Subsumed) => impOp - keyedSystemError("S2IL0025",[impOp]) - implementation = 'mkRecord => 'mkRecord - keyedSystemError("S2IL0025",[implementation]) - signatureItem:= - if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] - kind = 'ELT => - condition = 'T => [sig,n] - [sig,n,condition] - [sig,n,condition,kind] - itemList:= [signatureItem,:LASSQ(op,newAlist)] - newAlist:= insertAlist(op,itemList,newAlist) - newAlist - -sayNonUnique x == - sayBrightlyNT '"Non-unique:" - pp x - --- flattenOperationAlist operationAlist == --- --new form is ( ) --- [:[[op,:x] for x in y] for [op,:y] in operationAlist] - -getSlotFromDomain(dom,op,oldSig) == - -- returns the slot number in the domain where the function whose - -- signature is oldSig may be found in the domain dom - oldSig:= removeOPT oldSig - dom:= removeOPT dom - sig:= SUBST("$",dom,oldSig) - loadIfNecessary first dom - isPackageForm dom => getSlotFromPackage(dom,op,oldSig) - domain:= evalDomain dom - n:= findConstructorSlotNumber(dom,domain,op,sig) => - (slot:= domain.n).0 = Undef => - throwKeyedMsg("S2IL0023A",[op,formatSignature sig,dom]) - slot - throwKeyedMsg("S2IL0024A",[op,formatSignature sig,dom]) - -findConstructorSlotNumber(domainForm,domain,op,sig) == - null domain.1 => getSlotNumberFromOperationAlist(domainForm,op,sig) - sayMSG ['" using slot 1 of ",domainForm] - constructorArglist:= rest domainForm - nsig:=#sig - tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and - and/[compare for a in sig for b in sig1]] where compare == - a=b => true - FIXP b => a=constructorArglist.b - isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) - tail is [.,["ELT",.,n]] => n - systemErrorHere '"findSlotNumber" - -bustUnion d == - d is ["Union",domain,utype] and utype='"failed" => domain - d - -getSlotNumberFromOperationAlist(domainForm,op,sig) == - constructorName:= CAR domainForm - constructorArglist:= CDR domainForm - operationAlist:= - GETDATABASE(constructorName, 'OPERATIONALIST) or - keyedSystemError("S2IL0026",[constructorName]) - entryList:= QLASSQ(op,operationAlist) or return nil - tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => - first tail - nil - -sigsMatch(sig,sig1,domainForm) == - -- does signature "sig" match "sig1", where integers 1,2,.. in - -- sig1 designate corresponding arguments of domainForm - while sig and sig1 repeat - partsMatch:= - (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration - FIXP item1 => item = domainForm.item1 --item1=n means nth arg - isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) - null partsMatch => return nil - sig:= rest sig; sig1 := rest sig1 - sig or sig1 => nil - true - -findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain - nsig:=#sig - tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and - and/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) - for a in sig for b in sig1]] - tail is [.,["ELT",.,n]] => n - systemErrorHere '"findDomainSlotNumber" - - -getConstructorModemap form == - GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) - -getConstructorSignature form == - (mm := GETDATABASE(opOf(form),'CONSTRUCTORMODEMAP)) => - [[.,:sig],:.] := mm - sig - NIL - ---% from MODEMAP BOOT - -augModemapsFromDomain1(name,functorForm,e) == - GETL(KAR functorForm,"makeFunctionList") => - addConstructorModemaps(name,functorForm,e) - atom functorForm and (catform:= getmode(functorForm,e)) => - augModemapsFromCategory(name,name,functorForm,catform,e) - mappingForm:= getmodeOrMapping(KAR functorForm,e) => - ["Mapping",categoryForm,:functArgTypes]:= mappingForm - catform:= substituteCategoryArguments(rest functorForm,categoryForm) - augModemapsFromCategory(name,name,functorForm,catform,e) - stackMessage [functorForm," is an unknown mode"] - e - -getSlotFromCategoryForm ([op,:argl],index) == - u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] - null VECP u => - systemErrorHere '"getSlotFromCategoryForm" - u . index - - ---% constructor evaluation --- The following functions are used by the compiler but are modified --- here for use with new LISPLIB scheme - -mkEvalableCategoryForm c == --from DEFINE - c is [op,:argl] => - op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] - op is "DomainSubstitutionMacro" => - --$extraParms :local - --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms - --mkEvalableCategoryForm sublisV($extraParms, catobj) - mkEvalableCategoryForm CADR argl - op is "mkCategory" => c - MEMQ(op,$CategoryNames) => - ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) - --loadIfNecessary op - GETDATABASE(op,'CONSTRUCTORKIND) = 'category or - get(op,"isCategory",$CategoryFrame) => - [op,:[quotifyCategoryArgument x for x in argl]] - [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) - m=$Category => x - MKQ c - -isDomainForm(D,e) == - --added for MPOLY 3/83 by RDJ - MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or - -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or - ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or - isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) - -isDomainConstructorForm(D,e) == - D is [op,:argl] and (u:= get(op,"value",e)) and - u is [.,["Mapping",target,:.],:.] and - isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) - -isFunctor x == - op:= opOf x - not IDENTP op => false - $InteractiveMode => - MEMQ(op,'(Union SubDomain Mapping Record)) => true - MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) - u:= get(op,'isFunctor,$CategoryFrame) - or MEMQ(op,'(SubDomain Union Record)) => u - constructor? op => - prop := get(op,'isFunctor,$CategoryFrame) => prop - if GETDATABASE(op,'CONSTRUCTORKIND) = 'category - then updateCategoryFrameForCategory op - else updateCategoryFrameForConstructor op - get(op,'isFunctor,$CategoryFrame) - nil - - - diff --git a/src/interp/lisplib.boot.pamphlet b/src/interp/lisplib.boot.pamphlet new file mode 100644 index 00000000..bffb777e --- /dev/null +++ b/src/interp/lisplib.boot.pamphlet @@ -0,0 +1,712 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/lisplib.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Standard Library Creation Functions + +readLib(fn,ft) == readLib1(fn,ft,"*") + +readLib1(fn,ft,fm) == + -- see if it exists first + p := pathname [fn,ft,fm] + readLibPathFast p + +readLibPathFast p == + -- assumes 1) p is a valid pathname + -- 2) file has already been checked for existence + RDEFIOSTREAM([['FILE,:p], '(MODE . INPUT)],false) + +writeLib(fn,ft) == writeLib1(fn,ft,"*") + +writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] + +putFileProperty(fn,ft,id,val) == + fnStream:= writeLib1(fn,ft,"*") + val:= rwrite( id,val,fnStream) + RSHUT fnStream + val + +lisplibWrite(prop,val,filename) == + -- this may someday not write NIL keys, but it will now + if $LISPLIB then + rwrite128(prop,val,filename) + +rwrite128(key,value,stream) == + rwrite(key,value,stream) + +evalAndRwriteLispForm(key,form) == + eval form + rwriteLispForm(key,form) + +rwriteLispForm(key,form) == + if $LISPLIB then + rwrite( key,form,$libFile) + LAM_,FILEACTQ(key,form) + +getLisplib(name,id) == + -- this version does cache the returned value + getFileProperty(name,$spadLibFT,id,true) + +getLisplibNoCache(name,id) == + -- this version does not cache the returned value + getFileProperty(name,$spadLibFT,id,false) + +getFileProperty(fn,ft,id,cache) == + fn in '(DOMAIN SUBDOM MODE) => nil + p := pathname [fn,ft,'"*"] + cache => hasFileProperty(p,id,fn) + hasFilePropertyNoCache(p,id,fn) + +hasFilePropertyNoCache(p,id,abbrev) == + -- it is assumed that the file exists and is a proper pathname + -- startTimingProcess 'diskread + fnStream:= readLibPathFast p + NULL fnStream => NIL + -- str:= object2String id + val:= rread(id,fnStream, nil) + RSHUT fnStream + -- stopTimingProcess 'diskread + val + +--% Uninstantiating + +unInstantiate(clist) == + for c in clist repeat + clearConstructorCache(c) + killNestedInstantiations(clist) + +killNestedInstantiations(deps) == + for key in HKEYS($ConstructorCache) + repeat + for [arg,count,:inst] in HGET($ConstructorCache,key) repeat + isNestedInstantiation(inst.0,deps) => + HREMPROP($ConstructorCache,key,arg) + +isNestedInstantiation(form,deps) == + form is [op,:argl] => + op in deps => true + or/[isNestedInstantiation(x,deps) for x in argl] + false + +--% Loading + +loadLibIfNotLoaded libName == + -- replaces old SpadCondLoad + -- loads is library is not already loaded + $PrintOnly = 'T => NIL + GETL(libName,'LOADED) => NIL + loadLib libName + +loadLib cname == + startTimingProcess 'load + fullLibName := GETDATABASE(cname,'OBJECT) or return nil + systemdir? := isSystemDirectory(pathnameDirectory fullLibName) + update? := $forceDatabaseUpdate or not systemdir? + not update? => + loadLibNoUpdate(cname, cname, fullLibName) + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + LOAD(fullLibName) + clearConstructorCache cname + updateDatabase(cname,cname,systemdir?) + installConstructor(cname,kind) + u := GETDATABASE(cname, 'CONSTRUCTORMODEMAP) + updateCategoryTable(cname,kind) + coSig := + u => + [[.,:sig],:.] := u + CONS(NIL,[categoryForm?(x) for x in CDR sig]) + NIL + -- in following, add property value false or NIL to possibly clear + -- old value + if null CDR GETDATABASE(cname,'CONSTRUCTORFORM) then + MAKEPROP(cname,'NILADIC,'T) + else + REMPROP(cname,'NILADIC) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadLibNoUpdate(cname, libName, fullLibName) == + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + if CATCH('VERSIONCHECK,LOAD(fullLibName)) = -1 + then + PRINC('" wrong library version...recompile ") + PRINC(fullLibName) + TERPRI() + TOPLEVEL() + else + clearConstructorCache cname + installConstructor(cname,kind) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadIfNecessary u == loadLibIfNecessary(u,true) + +loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) + +loadLibIfNecessary(u,mustExist) == + u = '$EmptyMode => u + null atom u => loadLibIfNecessary(first u,mustExist) + value:= + functionp(u) or macrop(u) => u + GETL(u,'LOADED) => u + loadLib u => u + null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) + or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => + y:= GETDATABASE(u,'CONSTRUCTORKIND) => + y = 'category => + updateCategoryFrameForCategory u + updateCategoryFrameForConstructor u + throwKeyedMsg("S2IL0005",[u]) + value + +convertOpAlist2compilerInfo(opalist) == + "append"/[[formatSig(op,sig) for sig in siglist] + for [op,:siglist] in opalist] where + formatSig(op, [typelist, slot,:stuff]) == + pred := if stuff then first stuff else 'T + impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST + [[op, typelist], pred, [impl, '$, slot]] + +updateCategoryFrameForConstructor(constructor) == + opAlist := GETDATABASE(constructor, 'OPERATIONALIST) + [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) + $CategoryFrame := put(constructor,'isFunctor, + convertOpAlist2compilerInfo(opAlist), + addModemap(constructor, dc, sig, pred, impl, + put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) + +updateCategoryFrameForCategory(category) == + [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) + $CategoryFrame := + put(category, 'isCategory, 'T, + addModemap(category, dc, sig, pred, impl, $CategoryFrame)) + +loadFunctor u == + null atom u => loadFunctor first u + loadLibIfNotLoaded u + u + +makeConstructorsAutoLoad() == + for cnam in allConstructors() repeat + REMPROP(cnam,'LOADED) +-- fn:=GETDATABASE(cnam,'ABBREVIATION) + if GETDATABASE(cnam,'NILADIC) + then PUT(cnam,'NILADIC,'T) + else REMPROP(cnam,'NILADIC) + systemDependentMkAutoload(cnam,cnam) + +systemDependentMkAutoload(fn,cnam) == + FBOUNDP(cnam) => "next" + asharpName := GETDATABASE(cnam, 'ASHARP?) => + kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) + cosig := GETDATABASE(cnam, 'COSIG) + file := GETDATABASE(cnam, 'OBJECT) + SET_-LIB_-FILE_-GETTER(file, cnam) + kind = 'category => + ASHARPMKAUTOLOADCATEGORY(file, cnam, asharpName, cosig) + ASHARPMKAUTOLOADFUNCTOR(file, cnam, asharpName, cosig) + SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +autoLoad(abb,cname) == + if not GETL(cname,'LOADED) then loadLib cname + SYMBOL_-FUNCTION cname + +setAutoLoadProperty(name) == +-- abb := constructor? name + REMPROP(name,'LOADED) + SETF(SYMBOL_-FUNCTION name,mkAutoLoad(name, name)) + +--% Compilation + +compileConstructorLib(l,op,editFlag,traceFlag) == + --this file corresponds to /C,1 + MEMQ('_?,l) => return editFile '(_/C TELL _*) + optionList:= _/OPTIONS l + funList:= TRUNCLIST(l,optionList) or [_/FN] + options:= [[UPCASE CAR x,:CDR x] for x in optionList] + infile:= _/MKINFILENAM _/GETOPTION(options,'FROM_=) + outfile:= _/MKINFILENAM _/GETOPTION(options,'TO_=) + res:= [compConLib1(fn,infile,outfile,op,editFlag,traceFlag) + for fn in funList] + SHUT INPUTSTREAM + res + +compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == + $PRETTYPRINT: local := 'T + $LISPLIB: local := 'T + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL + $lisplibForm: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibSlot1 : local := NIL --used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibOpAlist: local:= NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibSignatureAlist: local := NIL + if null atom fun and null CDR fun then fun:= CAR fun -- unwrap nullary + libName:= getConstructorAbbreviation fun + infile:= infileOrNil or getFunctionSourceFile fun or + throwKeyedMsg("S2IL0004",[fun]) + SETQ(_/EDITFILE,infile) + outfile := outfileOrNil or + [libName,'OUTPUT,$listingDirectory] --always QUIET + _$ERASE(libName,'OUTPUT,$listingDirectory) + outstream:= DEFSTREAM(outfile,'OUTPUT) + val:= _/D_,2_,LIB(fun,infile,outstream,auxOp,editFlag,traceFlag) + val + +compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibSlot1 : local := NIL -- used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL +-- $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc + $lisplibCategory: local := nil + --for categories, is rhs of definition; otherwise, is target of functor + --will eventually become the "constructorCategory" property in lisplib + --set in compDefineCategory1 if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + BOUNDP '$compileDocumentation and $compileDocumentation => + compileDocumentation libName + sayMSG ['" initializing ",$spadLibFT,:bright libName, + '"for",:bright op] + initializeLisplib libName + sayMSG ['" compiling into ",$spadLibFT,:bright libName] + -- res:= FUNCALL(fn,df,m,e,prefix,fal) + -- sayMSG ['" finalizing ",$spadLibFT,:bright libName] + -- finalizeLisplib libName + -- following guarantee's compiler output files get closed. + ok := false; + UNWIND_-PROTECT( + PROGN(res:= FUNCALL(fn,df,m,e,prefix,fal), + sayMSG ['" finalizing ",$spadLibFT,:bright libName], + finalizeLisplib libName, + ok := true), + RSHUT $libFile) + if ok then lisplibDoRename(libName) + filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) + RPACKFILE filearg + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + LOCALDATABASE(LIST GETDATABASE(op,'ABBREVIATION),NIL) + $newConlist := [op, :$newConlist] ----------> bound in function "compiler" + if $lisplibKind = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + res + +compileDocumentation libName == + filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) + $FCOPY(filename,[libName,'DOCLB]) + stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] + lisplibWrite('"documentation",finalizeDocumentation(),stream) +-- if $lisplibRelatedDomains then +-- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) + RSHUT(stream) + RPACKFILE([libName,'DOCLB]) + $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) + ['dummy, $EmptyMode, $e] + +getLisplibVersion libName == + stream := RDEFIOSTREAM [['FILE,libName,$spadLibFT],['MODE, :'I]] + version:= CADR rread('VERSION, stream,nil) + RSHUT(stream) + version + +initializeLisplib libName == + _$ERASE(libName,'ERRORLIB,$libraryDirectory) + SETQ(ERRORS,0) -- ERRORS is a fluid variable for the compiler + $libFile:= writeLib1(libName,'ERRORLIB,$libraryDirectory) + ADDOPTIONS('FILE,$libFile) + $lisplibForm := nil --defining form for lisplib + $lisplibModemap := nil --modemap for constructor form + $lisplibKind := nil --category, domain, or package + $lisplibModemapAlist := nil --changed in "augmentLisplibModemapsFromCategory" + $lisplibAbbreviation := nil + $lisplibAncestors := nil + $lisplibOpAlist := nil --operations alist for new runtime system + $lisplibOperationAlist := nil --old list of operations for functor/package + $lisplibSuperDomain:= nil + -- next var changed in "augmentLisplibDependents" + $lisplibVariableAlist := nil --this and the next are used by "luke" + $lisplibSignatureAlist := nil + if pathnameTypeId(_/EDITFILE) = 'SPAD + then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION]) + +finalizeLisplib libName == + lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) + lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) + lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) + $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget + -- set to target of modemap for package/domain constructors; + -- to the right-hand sides (the definition) for category constructors + lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) + lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) + lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) + opsAndAtts:= getConstructorOpsAndAtts( + $lisplibForm,kind,$lisplibModemap) + lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) + --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) + --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts + if kind='category then + $pairlis : local := [[a,:v] for a in rest $lisplibForm + for v in $FormalMapVariableList] + $NRTslot1PredicateList : local := [] + NRTgenInitialAttributeAlist CDR opsAndAtts + lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) + lisplibWrite('"signaturesAndLocals", + removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, + $lisplibVariableAlist),$libFile) + lisplibWrite('"attributes",removeZeroOne $lisplibAttributes,$libFile) + lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) + lisplibWrite('"abbreviation",$lisplibAbbreviation,$libFile) + lisplibWrite('"parents",removeZeroOne $lisplibParents,$libFile) + lisplibWrite('"ancestors",removeZeroOne $lisplibAncestors,$libFile) + lisplibWrite('"documentation",finalizeDocumentation(),$libFile) + lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) + if $profileCompiler then profileWrite() + if $lisplibForm and null CDR $lisplibForm then + MAKEPROP(CAR $lisplibForm,'NILADIC,'T) + ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler + sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] + sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] + +lisplibDoRename(libName) == + _$REPLACE([libName,$spadLibFT,$libraryDirectory], + [libName,'ERRORLIB,$libraryDirectory]) + +lisplibError(cname,fname,type,cn,fn,typ,error) == + sayMSG bright ['" Illegal ",$spadLibFT] + error in '(duplicateAbb wrongType) => + sayKeyedMsg("S2IL0007", + [namestring [fname,$spadLibFT],type,cname,typ,cn]) + error is 'abbIsName => + throwKeyedMsg("S2IL0008",[fname,typ,namestring [fn,$spadLibFT]]) + +getPartialConstructorModemapSig(c) == + (s := getConstructorSignature c) => rest s + throwEvalTypeMsg("S2IL0015",[c]) + +mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == + -- this function makes a single Alist for both signatures + -- and local variable types, to be stored in the LISPLIB + -- for the function being compiled + [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for + [funcName, :signature] in signatureAlist] + +Operators u == + ATOM u => [] + ATOM first u => + answer:="union"/[Operators v for v in rest u] + MEMQ(first u,answer) => answer + [first u,:answer] + "union"/[Operators v for v in u] + +getConstructorOpsAndAtts(form,kind,modemap) == + kind is 'category => getCategoryOpsAndAtts(form) + getFunctorOpsAndAtts(form,modemap) + +getCategoryOpsAndAtts(catForm) == + -- returns [operations,:attributes] of CAR catForm + [transformOperationAlist getSlotFromCategoryForm(catForm,1), + :getSlotFromCategoryForm(catForm,2)] + +getFunctorOpsAndAtts(form,modemap) == + [transformOperationAlist getSlotFromFunctor(form,1,modemap), + :getSlotFromFunctor(form,2,modemap)] + +getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == + slot = 1 => $lisplibOperationAlist + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlotFromFunctor" + t.expr.slot + +getSlot1 domainName == + $e: local:= $CategoryFrame + fn:= getLisplibName domainName + p := pathname [fn,$spadLibFT,'"*"] + not isExistingFile(p) => + sayKeyedMsg("S2IL0003",[namestring p]) + NIL + (sig := getConstructorSignature domainName) => + [.,target,:argMml] := sig + for a in $FormalMapVariableList for m in argMml repeat + $e:= put(a,'mode,m,$e) + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlot1" + t.expr.1 + sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) + NIL + +transformOperationAlist operationAlist == + -- this transforms the operationAlist which is written out onto LISPLIBs. + -- The original form of this list is a list of items of the form: + -- (( ) ( (ELT $ n))) + -- The new form is an op-Alist which has entries ( . signature-Alist) + -- where signature-Alist has entries ( . item) + -- where item has form ( ) + -- where = + -- NIL => function + -- CONST => constant ... and others + newAlist:= nil + for [[op,sig,:.],condition,implementation] in operationAlist repeat + kind:= + implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc + implementation is [impOp,:.] => + impOp = 'XLAM => implementation + impOp in '(CONST Subsumed) => impOp + keyedSystemError("S2IL0025",[impOp]) + implementation = 'mkRecord => 'mkRecord + keyedSystemError("S2IL0025",[implementation]) + signatureItem:= + if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] + kind = 'ELT => + condition = 'T => [sig,n] + [sig,n,condition] + [sig,n,condition,kind] + itemList:= [signatureItem,:LASSQ(op,newAlist)] + newAlist:= insertAlist(op,itemList,newAlist) + newAlist + +sayNonUnique x == + sayBrightlyNT '"Non-unique:" + pp x + +-- flattenOperationAlist operationAlist == +-- --new form is ( ) +-- [:[[op,:x] for x in y] for [op,:y] in operationAlist] + +getSlotFromDomain(dom,op,oldSig) == + -- returns the slot number in the domain where the function whose + -- signature is oldSig may be found in the domain dom + oldSig:= removeOPT oldSig + dom:= removeOPT dom + sig:= SUBST("$",dom,oldSig) + loadIfNecessary first dom + isPackageForm dom => getSlotFromPackage(dom,op,oldSig) + domain:= evalDomain dom + n:= findConstructorSlotNumber(dom,domain,op,sig) => + (slot:= domain.n).0 = Undef => + throwKeyedMsg("S2IL0023A",[op,formatSignature sig,dom]) + slot + throwKeyedMsg("S2IL0024A",[op,formatSignature sig,dom]) + +findConstructorSlotNumber(domainForm,domain,op,sig) == + null domain.1 => getSlotNumberFromOperationAlist(domainForm,op,sig) + sayMSG ['" using slot 1 of ",domainForm] + constructorArglist:= rest domainForm + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + and/[compare for a in sig for b in sig1]] where compare == + a=b => true + FIXP b => a=constructorArglist.b + isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findSlotNumber" + +bustUnion d == + d is ["Union",domain,utype] and utype='"failed" => domain + d + +getSlotNumberFromOperationAlist(domainForm,op,sig) == + constructorName:= CAR domainForm + constructorArglist:= CDR domainForm + operationAlist:= + GETDATABASE(constructorName, 'OPERATIONALIST) or + keyedSystemError("S2IL0026",[constructorName]) + entryList:= QLASSQ(op,operationAlist) or return nil + tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => + first tail + nil + +sigsMatch(sig,sig1,domainForm) == + -- does signature "sig" match "sig1", where integers 1,2,.. in + -- sig1 designate corresponding arguments of domainForm + while sig and sig1 repeat + partsMatch:= + (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration + FIXP item1 => item = domainForm.item1 --item1=n means nth arg + isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) + null partsMatch => return nil + sig:= rest sig; sig1 := rest sig1 + sig or sig1 => nil + true + +findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + and/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + for a in sig for b in sig1]] + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findDomainSlotNumber" + + +getConstructorModemap form == + GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) + +getConstructorSignature form == + (mm := GETDATABASE(opOf(form),'CONSTRUCTORMODEMAP)) => + [[.,:sig],:.] := mm + sig + NIL + +--% from MODEMAP BOOT + +augModemapsFromDomain1(name,functorForm,e) == + GETL(KAR functorForm,"makeFunctionList") => + addConstructorModemaps(name,functorForm,e) + atom functorForm and (catform:= getmode(functorForm,e)) => + augModemapsFromCategory(name,name,functorForm,catform,e) + mappingForm:= getmodeOrMapping(KAR functorForm,e) => + ["Mapping",categoryForm,:functArgTypes]:= mappingForm + catform:= substituteCategoryArguments(rest functorForm,categoryForm) + augModemapsFromCategory(name,name,functorForm,catform,e) + stackMessage [functorForm," is an unknown mode"] + e + +getSlotFromCategoryForm ([op,:argl],index) == + u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] + null VECP u => + systemErrorHere '"getSlotFromCategoryForm" + u . index + + +--% constructor evaluation +-- The following functions are used by the compiler but are modified +-- here for use with new LISPLIB scheme + +mkEvalableCategoryForm c == --from DEFINE + c is [op,:argl] => + op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] + op is "DomainSubstitutionMacro" => + --$extraParms :local + --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms + --mkEvalableCategoryForm sublisV($extraParms, catobj) + mkEvalableCategoryForm CADR argl + op is "mkCategory" => c + MEMQ(op,$CategoryNames) => + ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) + --loadIfNecessary op + GETDATABASE(op,'CONSTRUCTORKIND) = 'category or + get(op,"isCategory",$CategoryFrame) => + [op,:[quotifyCategoryArgument x for x in argl]] + [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) + m=$Category => x + MKQ c + +isDomainForm(D,e) == + --added for MPOLY 3/83 by RDJ + MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or + -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) + +isDomainConstructorForm(D,e) == + D is [op,:argl] and (u:= get(op,"value",e)) and + u is [.,["Mapping",target,:.],:.] and + isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) + +isFunctor x == + op:= opOf x + not IDENTP op => false + $InteractiveMode => + MEMQ(op,'(Union SubDomain Mapping Record)) => true + MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) + u:= get(op,'isFunctor,$CategoryFrame) + or MEMQ(op,'(SubDomain Union Record)) => u + constructor? op => + prop := get(op,'isFunctor,$CategoryFrame) => prop + if GETDATABASE(op,'CONSTRUCTORKIND) = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + get(op,'isFunctor,$CategoryFrame) + nil + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/macex.boot b/src/interp/macex.boot deleted file mode 100644 index b638600a..00000000 --- a/src/interp/macex.boot +++ /dev/null @@ -1,189 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - ---% Macro expansion --- Functions to transform parse forms. --- --- Global variables: --- $pfMacros is an alist [[id, state, body-pform], ...] --- (set in newcompInit). --- state is one of: mbody, mparam, mlambda --- --- $macActive is a list of the bodies being expanded. --- $posActive is a list of the parse forms where the bodies came from. - --- Beware: the name macroExpand is used by the old compiler. -macroExpanded pf == - $macActive: local := [] - $posActive: local := [] - - macExpand pf - -macExpand pf == - pfWhere? pf => macWhere pf - pfLambda? pf => macLambda pf - pfMacro? pf => macMacro pf - - pfId? pf => macId pf - pfApplication? pf => macApplication pf - pfMapParts(function macExpand, pf) - -macWhere pf == - mac(pf,$pfMacros) where - mac(pf,$pfMacros) == - -- pfWhereContext is before pfWhereExpr - pfMapParts(function macExpand, pf) - -macLambda pf == - mac(pf,$pfMacros) where - mac(pf,$pfMacros) == - pfMapParts(function macExpand, pf) - -macLambdaParameterHandling( replist , pform ) == - pfLeaf? pform => [] - pfLambda? pform => -- remove ( identifier . replacement ) from assoclist - parlist := [ pfTypedId p for p in pf0LambdaArgs pform ] -- extract parameters - for par in [ pfIdSymbol par for par in parlist ] repeat - replist := AlistRemoveQ(par,replist) - replist - pfMLambda? pform => -- construct assoclist ( identifier . replacement ) - parlist := pf0MLambdaArgs pform -- extract parameter list - [[pfIdSymbol par ,:pfLeaf( pfAbSynOp par,GENSYM(),pfLeafPosition par)] for par in parlist ] - for p in pfParts pform repeat macLambdaParameterHandling( replist , p ) - -macSubstituteId( replist , pform ) == - ex := AlistAssocQ( pfIdSymbol pform , replist ) - ex => - RPLPAIR(pform,CDR ex) - pform - pform - -macSubstituteOuter( pform ) == - mac0SubstituteOuter( macLambdaParameterHandling( [] , pform ) , pform ) - -mac0SubstituteOuter( replist , pform ) == - pfId? pform => macSubstituteId( replist , pform ) - pfLeaf? pform => pform - pfLambda? pform => - tmplist := macLambdaParameterHandling( replist , pform ) - for p in pfParts pform repeat mac0SubstituteOuter( tmplist , p ) - pform - for p in pfParts pform repeat mac0SubstituteOuter( replist , p ) - pform - --- This function adds the appropriate definition and returns --- the original Macro pform. -macMacro pf == - lhs := pfMacroLhs pf - rhs := pfMacroRhs pf - not pfId? lhs => - ncSoftError (pfSourcePosition lhs, 'S2CM0001, [%pform lhs] ) - pf - sy := pfIdSymbol lhs - - mac0Define(sy, if pfMLambda? rhs then 'mlambda else 'mbody, macSubstituteOuter rhs) - - if pfNothing? rhs then pf else pfMacro(lhs, pfNothing()) - -mac0Define(sy, state, body) == - $pfMacros := cons([sy, state, body], $pfMacros) - --- Returns [state, body] or NIL. -mac0Get sy == - IFCDR ASSOC(sy, $pfMacros) - --- Returns [sy, state] or NIL. -mac0GetName body == - name := nil - for [sy,st,bd] in $pfMacros while not name repeat - if st = 'mlambda then - bd := pfMLambdaBody bd - EQ(bd, body) => name := [sy,st] - name - -macId pf == - sy := pfIdSymbol pf - not (got := mac0Get sy) => pf - [state, body] := got - - state = 'mparam => body -- expanded already - state = 'mlambda => pfCopyWithPos( body , pfSourcePosition pf ) -- expanded later - - pfCopyWithPos( mac0ExpandBody(body, pf, $macActive, $posActive) , pfSourcePosition pf ) - -macApplication pf == - pf := pfMapParts(function macExpand, pf) - - op := pfApplicationOp pf - not pfMLambda? op => pf - - args := pf0ApplicationArgs pf - mac0MLambdaApply(op, args, pf, $pfMacros) - -mac0MLambdaApply(mlambda, args, opf, $pfMacros) == - params := pf0MLambdaArgs mlambda - body := pfMLambdaBody mlambda - #args ^= #params => - pos := pfSourcePosition opf - ncHardError(pos,'S2CM0003, [#params,#args]) - for p in params for a in args repeat - not pfId? p => - pos := pfSourcePosition opf - ncHardError(pos, 'S2CM0004, [%pform p]) - mac0Define(pfIdSymbol p, 'mparam, a) - - mac0ExpandBody( body , opf, $macActive, $posActive) - -mac0ExpandBody(body, opf, $macActive, $posActive) == - MEMQ(body,$macActive) => - [.,pf] := $posActive - posn := pfSourcePosition pf - mac0InfiniteExpansion(posn, body, $macActive) - $macActive := [body, :$macActive] - $posActive := [opf, :$posActive] - macExpand body - -mac0InfiniteExpansion(posn, body, active) == - blist := [body, :active] - [fname, :rnames] := [name b for b in blist] where - name b == - got := mac0GetName b - not got => '"???" - [sy,st] := got - st = 'mlambda => CONCAT(PNAME sy, '"(...)") - PNAME sy - ncSoftError (posn, 'S2CM0005, _ - [ [:[n,'"==>"] for n in reverse rnames], fname, %pform body ] ) - - body diff --git a/src/interp/macex.boot.pamphlet b/src/interp/macex.boot.pamphlet new file mode 100644 index 00000000..a275c59b --- /dev/null +++ b/src/interp/macex.boot.pamphlet @@ -0,0 +1,211 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp macex.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +--% Macro expansion +-- Functions to transform parse forms. +-- +-- Global variables: +-- $pfMacros is an alist [[id, state, body-pform], ...] +-- (set in newcompInit). +-- state is one of: mbody, mparam, mlambda +-- +-- $macActive is a list of the bodies being expanded. +-- $posActive is a list of the parse forms where the bodies came from. + +-- Beware: the name macroExpand is used by the old compiler. +macroExpanded pf == + $macActive: local := [] + $posActive: local := [] + + macExpand pf + +macExpand pf == + pfWhere? pf => macWhere pf + pfLambda? pf => macLambda pf + pfMacro? pf => macMacro pf + + pfId? pf => macId pf + pfApplication? pf => macApplication pf + pfMapParts(function macExpand, pf) + +macWhere pf == + mac(pf,$pfMacros) where + mac(pf,$pfMacros) == + -- pfWhereContext is before pfWhereExpr + pfMapParts(function macExpand, pf) + +macLambda pf == + mac(pf,$pfMacros) where + mac(pf,$pfMacros) == + pfMapParts(function macExpand, pf) + +macLambdaParameterHandling( replist , pform ) == + pfLeaf? pform => [] + pfLambda? pform => -- remove ( identifier . replacement ) from assoclist + parlist := [ pfTypedId p for p in pf0LambdaArgs pform ] -- extract parameters + for par in [ pfIdSymbol par for par in parlist ] repeat + replist := AlistRemoveQ(par,replist) + replist + pfMLambda? pform => -- construct assoclist ( identifier . replacement ) + parlist := pf0MLambdaArgs pform -- extract parameter list + [[pfIdSymbol par ,:pfLeaf( pfAbSynOp par,GENSYM(),pfLeafPosition par)] for par in parlist ] + for p in pfParts pform repeat macLambdaParameterHandling( replist , p ) + +macSubstituteId( replist , pform ) == + ex := AlistAssocQ( pfIdSymbol pform , replist ) + ex => + RPLPAIR(pform,CDR ex) + pform + pform + +macSubstituteOuter( pform ) == + mac0SubstituteOuter( macLambdaParameterHandling( [] , pform ) , pform ) + +mac0SubstituteOuter( replist , pform ) == + pfId? pform => macSubstituteId( replist , pform ) + pfLeaf? pform => pform + pfLambda? pform => + tmplist := macLambdaParameterHandling( replist , pform ) + for p in pfParts pform repeat mac0SubstituteOuter( tmplist , p ) + pform + for p in pfParts pform repeat mac0SubstituteOuter( replist , p ) + pform + +-- This function adds the appropriate definition and returns +-- the original Macro pform. +macMacro pf == + lhs := pfMacroLhs pf + rhs := pfMacroRhs pf + not pfId? lhs => + ncSoftError (pfSourcePosition lhs, 'S2CM0001, [%pform lhs] ) + pf + sy := pfIdSymbol lhs + + mac0Define(sy, if pfMLambda? rhs then 'mlambda else 'mbody, macSubstituteOuter rhs) + + if pfNothing? rhs then pf else pfMacro(lhs, pfNothing()) + +mac0Define(sy, state, body) == + $pfMacros := cons([sy, state, body], $pfMacros) + +-- Returns [state, body] or NIL. +mac0Get sy == + IFCDR ASSOC(sy, $pfMacros) + +-- Returns [sy, state] or NIL. +mac0GetName body == + name := nil + for [sy,st,bd] in $pfMacros while not name repeat + if st = 'mlambda then + bd := pfMLambdaBody bd + EQ(bd, body) => name := [sy,st] + name + +macId pf == + sy := pfIdSymbol pf + not (got := mac0Get sy) => pf + [state, body] := got + + state = 'mparam => body -- expanded already + state = 'mlambda => pfCopyWithPos( body , pfSourcePosition pf ) -- expanded later + + pfCopyWithPos( mac0ExpandBody(body, pf, $macActive, $posActive) , pfSourcePosition pf ) + +macApplication pf == + pf := pfMapParts(function macExpand, pf) + + op := pfApplicationOp pf + not pfMLambda? op => pf + + args := pf0ApplicationArgs pf + mac0MLambdaApply(op, args, pf, $pfMacros) + +mac0MLambdaApply(mlambda, args, opf, $pfMacros) == + params := pf0MLambdaArgs mlambda + body := pfMLambdaBody mlambda + #args ^= #params => + pos := pfSourcePosition opf + ncHardError(pos,'S2CM0003, [#params,#args]) + for p in params for a in args repeat + not pfId? p => + pos := pfSourcePosition opf + ncHardError(pos, 'S2CM0004, [%pform p]) + mac0Define(pfIdSymbol p, 'mparam, a) + + mac0ExpandBody( body , opf, $macActive, $posActive) + +mac0ExpandBody(body, opf, $macActive, $posActive) == + MEMQ(body,$macActive) => + [.,pf] := $posActive + posn := pfSourcePosition pf + mac0InfiniteExpansion(posn, body, $macActive) + $macActive := [body, :$macActive] + $posActive := [opf, :$posActive] + macExpand body + +mac0InfiniteExpansion(posn, body, active) == + blist := [body, :active] + [fname, :rnames] := [name b for b in blist] where + name b == + got := mac0GetName b + not got => '"???" + [sy,st] := got + st = 'mlambda => CONCAT(PNAME sy, '"(...)") + PNAME sy + ncSoftError (posn, 'S2CM0005, _ + [ [:[n,'"==>"] for n in reverse rnames], fname, %pform body ] ) + + body +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/match.boot b/src/interp/match.boot deleted file mode 100644 index 95627777..00000000 --- a/src/interp/match.boot +++ /dev/null @@ -1,220 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -SETANDFILEQ($wildCard,char "*") - -maskMatch?(mask,subject) == - null mask => true - if null STRINGP subject then subject := PNAME subject - or/[match?(pattern,subject) for pattern in mask] - -substring?(part, whole, startpos) == ---This function should be replaced by STRING< - np := SIZE part - nw := SIZE whole - np > nw - startpos => false - and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw)) - for ip in 0..np-1 for iw in startpos.. ] - -anySubstring?(part,whole,startpos) == - np := SIZE part - nw := SIZE whole - or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw)) - for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k - -charPosition(c,t,startpos) == - n := SIZE t - startpos < 0 or startpos > n => n - k:= startpos - for i in startpos .. n-1 repeat - c = ELT(t,i) => return nil - k := k+1 - k - -rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost) - k := startpos - for i in startpos..0 by -1 while c ^= ELT(t,i) repeat (k := k - 1) - k - -stringPosition(s,t,startpos) == - n := SIZE t - if startpos < 0 or startpos > n then error "index out of range" - if SIZE s = 0 then return startpos -- bug in STRPOS - r := STRPOS(s,t,startpos,NIL) - if EQ(r,NIL) then n else r - -superMatch?(opattern,subject) == --subject assumed to be DOWNCASEd - $wildCard : local := char '_* - pattern := patternCheck opattern - logicalMatch?(pattern,subject) - -logicalMatch?(pattern,subject) == --subject assumed to be DOWNCASEd - pattern is [op,:argl] => - op = "and" => and/[superMatch?(p,subject) for p in argl] - op = "or" => or/[superMatch?(p,subject) for p in argl] - op = "not" => not superMatch?(first argl,subject) - systemError '"unknown pattern form" - basicMatch?(pattern,subject) - -patternCheck pattern == main where - --checks for escape characters, maybe new $wildCard - main == --- pattern := pmTransFilter pattern --should no longer need this (rdj:10/1/91) - u := pos(char '__,pattern) - null u => pattern - not(and/[equal(pattern,i + 1,$wildCard) for i in u]) => - sayBrightly ['"Invalid use of underscores in pattern: ",pattern] - '"!!!!!!!!!!!!!!" - c := wild(pattern,'(_$ _# _% _& _@)) --- sayBrightlyNT ['"Choosing new wild card"] --- pp c - $oldWild :local := $wildCard - $wildCard := c - pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u)) --- sayBrightlyNT ['"Replacing pattern by"] --- pp pattern - pattern - mknew(old,i,r,new) == - new := STRCONC(new,old.(i + 1)) --add underscored character to string - null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0)) - mknew(old,first r,rest r, - STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1))) - subWild(s,i) == - (k := charPosition($oldWild,s,i)) < #s => - STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1)) - SUBSTRING(s,i,nil) - pos(c,s) == - i := 0 - n := MAXINDEX s - acc := nil - repeat - k := charPosition(c,s,i) - k > n => return NREVERSE acc - acc := [k,:acc] - i := k + 1 - equal(p,n,c) == - n > MAXINDEX p => false - p.n = c - wild(p,u) == - for id in u repeat - c := char id - not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c - -match?(pattern,subject) == --returns index of first character that matches - basicMatch?(pattern,DOWNCASE subject) - -stringMatch(pattern,subject,wildcard) == - not CHARP wildcard => - systemError '"Wildcard must be a character" - $wildCard : local := wildcard - subject := DOWNCASE subject - k := basicMatch?(pattern,DOWNCASE subject) => k + 1 - 0 - -basicMatch?(pattern,target) == - n := #pattern - p := charPosition($wildCard,pattern,0) - p = n => (pattern = target) and 0 - if p ^= 0 then - -- pattern does not begin with a wild card - ans := 0 - s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] - not substring?(s,target,0) => return false - else if n = 1 then return 0 - i := p -- starting position for searching the target - q := charPosition($wildCard,pattern,p+1) - ltarget := #target - while q ^= n repeat - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - i := stringPosition(s,target,i) - if null ans then ans := stringPosition(s,target,p) - -- for patterns beginning with wildcard, ans gives position of first match - if i = ltarget then return (returnFlag := true) - i := i + #s - p := q - q := charPosition($wildCard,pattern,q+1) - returnFlag => false - if p ^= q-1 then - -- pattern does not end with a wildcard - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - if not suffix?(s,target) then return false - if null ans then ans := 1 --pattern is a word preceded by a * - ans - -matchSegment?(pattern,subject,k) == - matchAnySegment?(pattern,DOWNCASE subject,k,nil) - -matchAnySegment?(pattern,target,k,nc) == --k = start position; nc=#chars or NIL - n := #pattern - p := charPosition($wildCard,pattern,0) - p = n => - m := stringPosition(pattern,target,k) - m = #target => nil - null nc => true - m <= k + nc - n - if k ^= 0 and nc then - target := SUBSTRING(target,k,nc) - k := 0 - if p ^= 0 then - -- pattern does not begin with a wild card - ans := 0 - s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] - not substring?(s,target,k) => return false - else if n = 1 then return true - i := p + k -- starting position for searching the target - q := charPosition($wildCard,pattern,p+1) - ltarget := #target - while q ^= n repeat - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - i := stringPosition(s,target,i) - if i = ltarget then return (returnFlag := true) - i := i + #s - p := q - q := charPosition($wildCard,pattern,q+1) - returnFlag => false - if p ^= q-1 then - -- pattern does not end with a '& - s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] - if not suffix?(s,target) then return false - if null ans then ans := 1 --pattern is a word preceded by a * - true - -infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) - -prefix?(s,t) == substring?(s,t,0) - -suffix?(s,t) == - m := #s; n := #t - if m > n then return false - substring?(s,t,(n-m)) - - diff --git a/src/interp/match.boot.pamphlet b/src/interp/match.boot.pamphlet new file mode 100644 index 00000000..132b99f9 --- /dev/null +++ b/src/interp/match.boot.pamphlet @@ -0,0 +1,242 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp match.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +SETANDFILEQ($wildCard,char "*") + +maskMatch?(mask,subject) == + null mask => true + if null STRINGP subject then subject := PNAME subject + or/[match?(pattern,subject) for pattern in mask] + +substring?(part, whole, startpos) == +--This function should be replaced by STRING< + np := SIZE part + nw := SIZE whole + np > nw - startpos => false + and/[CHAR_-EQUAL(ELT(part, ip), ELT(whole, iw)) + for ip in 0..np-1 for iw in startpos.. ] + +anySubstring?(part,whole,startpos) == + np := SIZE part + nw := SIZE whole + or/[((k := i) and and/[CHAR_-EQUAL(ELT(part, ip),ELT(whole, iw)) + for ip in 0..np - 1 for iw in i..]) for i in startpos..nw - np] => k + +charPosition(c,t,startpos) == + n := SIZE t + startpos < 0 or startpos > n => n + k:= startpos + for i in startpos .. n-1 repeat + c = ELT(t,i) => return nil + k := k+1 + k + +rightCharPosition(c,t,startpos) == --startpos often equals MAXINDEX t (rightmost) + k := startpos + for i in startpos..0 by -1 while c ^= ELT(t,i) repeat (k := k - 1) + k + +stringPosition(s,t,startpos) == + n := SIZE t + if startpos < 0 or startpos > n then error "index out of range" + if SIZE s = 0 then return startpos -- bug in STRPOS + r := STRPOS(s,t,startpos,NIL) + if EQ(r,NIL) then n else r + +superMatch?(opattern,subject) == --subject assumed to be DOWNCASEd + $wildCard : local := char '_* + pattern := patternCheck opattern + logicalMatch?(pattern,subject) + +logicalMatch?(pattern,subject) == --subject assumed to be DOWNCASEd + pattern is [op,:argl] => + op = "and" => and/[superMatch?(p,subject) for p in argl] + op = "or" => or/[superMatch?(p,subject) for p in argl] + op = "not" => not superMatch?(first argl,subject) + systemError '"unknown pattern form" + basicMatch?(pattern,subject) + +patternCheck pattern == main where + --checks for escape characters, maybe new $wildCard + main == +-- pattern := pmTransFilter pattern --should no longer need this (rdj:10/1/91) + u := pos(char '__,pattern) + null u => pattern + not(and/[equal(pattern,i + 1,$wildCard) for i in u]) => + sayBrightly ['"Invalid use of underscores in pattern: ",pattern] + '"!!!!!!!!!!!!!!" + c := wild(pattern,'(_$ _# _% _& _@)) +-- sayBrightlyNT ['"Choosing new wild card"] +-- pp c + $oldWild :local := $wildCard + $wildCard := c + pattern := mknew(pattern,first u,rest u,SUBSTRING(pattern,0,first u)) +-- sayBrightlyNT ['"Replacing pattern by"] +-- pp pattern + pattern + mknew(old,i,r,new) == + new := STRCONC(new,old.(i + 1)) --add underscored character to string + null r => STRCONC(new,subWild(SUBSTRING(old,i + 2,nil),0)) + mknew(old,first r,rest r, + STRCONC(new,subWild(SUBSTRING(old,i + 2,(first r) - i - 1),i + 1))) + subWild(s,i) == + (k := charPosition($oldWild,s,i)) < #s => + STRCONC(SUBSTRING(s,i,k - i),$wildCard,subWild(s,k + 1)) + SUBSTRING(s,i,nil) + pos(c,s) == + i := 0 + n := MAXINDEX s + acc := nil + repeat + k := charPosition(c,s,i) + k > n => return NREVERSE acc + acc := [k,:acc] + i := k + 1 + equal(p,n,c) == + n > MAXINDEX p => false + p.n = c + wild(p,u) == + for id in u repeat + c := char id + not(or/[p.i = c for i in 0..MAXINDEX(p)]) => return c + +match?(pattern,subject) == --returns index of first character that matches + basicMatch?(pattern,DOWNCASE subject) + +stringMatch(pattern,subject,wildcard) == + not CHARP wildcard => + systemError '"Wildcard must be a character" + $wildCard : local := wildcard + subject := DOWNCASE subject + k := basicMatch?(pattern,DOWNCASE subject) => k + 1 + 0 + +basicMatch?(pattern,target) == + n := #pattern + p := charPosition($wildCard,pattern,0) + p = n => (pattern = target) and 0 + if p ^= 0 then + -- pattern does not begin with a wild card + ans := 0 + s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] + not substring?(s,target,0) => return false + else if n = 1 then return 0 + i := p -- starting position for searching the target + q := charPosition($wildCard,pattern,p+1) + ltarget := #target + while q ^= n repeat + s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] + i := stringPosition(s,target,i) + if null ans then ans := stringPosition(s,target,p) + -- for patterns beginning with wildcard, ans gives position of first match + if i = ltarget then return (returnFlag := true) + i := i + #s + p := q + q := charPosition($wildCard,pattern,q+1) + returnFlag => false + if p ^= q-1 then + -- pattern does not end with a wildcard + s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] + if not suffix?(s,target) then return false + if null ans then ans := 1 --pattern is a word preceded by a * + ans + +matchSegment?(pattern,subject,k) == + matchAnySegment?(pattern,DOWNCASE subject,k,nil) + +matchAnySegment?(pattern,target,k,nc) == --k = start position; nc=#chars or NIL + n := #pattern + p := charPosition($wildCard,pattern,0) + p = n => + m := stringPosition(pattern,target,k) + m = #target => nil + null nc => true + m <= k + nc - n + if k ^= 0 and nc then + target := SUBSTRING(target,k,nc) + k := 0 + if p ^= 0 then + -- pattern does not begin with a wild card + ans := 0 + s := SUBSTRING(pattern,0,p) --[pattern.i for i in 0..p-1] + not substring?(s,target,k) => return false + else if n = 1 then return true + i := p + k -- starting position for searching the target + q := charPosition($wildCard,pattern,p+1) + ltarget := #target + while q ^= n repeat + s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] + i := stringPosition(s,target,i) + if i = ltarget then return (returnFlag := true) + i := i + #s + p := q + q := charPosition($wildCard,pattern,q+1) + returnFlag => false + if p ^= q-1 then + -- pattern does not end with a '& + s := SUBSTRING(pattern,p+1,q-p-1) --[pattern.i for i in (p+1..q-1)] + if not suffix?(s,target) then return false + if null ans then ans := 1 --pattern is a word preceded by a * + true + +infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) + +prefix?(s,t) == substring?(s,t,0) + +suffix?(s,t) == + m := #s; n := #t + if m > n then return false + substring?(s,t,(n-m)) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot deleted file mode 100644 index 67f7dcee..00000000 --- a/src/interp/modemap.boot +++ /dev/null @@ -1,353 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% EXTERNAL ROUTINES - ---These functions are called from outside this file to add a domain --- or to get the current domains in scope; - -addDomain(domain,e) == - atom domain => - EQ(domain,"$EmptyMode") => e - EQ(domain,"$NoValueMode") => e - not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and - EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e - MEMQ(domain,getDomainsInScope e) => e - isLiteral(domain,e) => e - addNewDomain(domain,e) - (name:= first domain)='Category => e - domainMember(domain,getDomainsInScope e) => e - getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> - addNewDomain(domain,e) - -- constructor? test needed for domains compiled with $bootStrapMode=true - isFunctor name or constructor? name => addNewDomain(domain,e) - if not isCategoryForm(domain,e) and - not member(name,'(Mapping CATEGORY)) then - unknownTypeError name - e --is not a functor - -domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] - ---% MODEMAP FUNCTIONS - ---getTargetMode(x is [op,:argl],e) == --- CASES(#(mml:= getModemapList(op,#argl,e)), --- (1 => --- ([[.,target,:.],:.]:= first mml; substituteForFormalArguments(argl,target)) --- ; 0 => MOAN(x," has no modemap"); systemError [x," has duplicate modemaps"])) - -getModemap(x is [op,:.],e) == - for modemap in get(op,'modemap,e) repeat - if u:= compApplyModemap(x,modemap,e,nil) then return - ([.,.,sl]:= u; SUBLIS(sl,modemap)) - -getUniqueSignature(form,e) == - [[.,:sig],:.]:= getUniqueModemap(first form,#rest form,e) or return nil - sig - -getUniqueModemap(op,numOfArgs,e) == - 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml - 1<#mml => - stackWarning [numOfArgs,'" argument form of: ",op, - '" has more than one modemap"] - first mml - nil - -getModemapList(op,numOfArgs,e) == - op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) - [mm for - (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] - -getModemapListFromDomain(op,numOfArgs,D,e) == - [mm - for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= - numOfArgs] - -addModemapKnown(op,mc,sig,pred,fn,$e) == --- if knownInfo pred then pred:=true --- that line is handled elsewhere - $insideCapsuleFunctionIfTrue=true => - $CapsuleModemapFrame := - addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) - $e - addModemap0(op,mc,sig,pred,fn,$e) - -addModemap0(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - $functorForm is ['CategoryDefaults,:.] and mc="$" => e - --don't put CD modemaps into environment - --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps - -- breaks -:($,$)->U($,failed) in DP - op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) - addModemap1(op,mc,sig,pred,fn,e) - -addEltModemap(op,mc,sig,pred,fn,e) == - --hack to change selectors from strings to identifiers; and to - --add flag identifiers as literals in the envir - op='elt and sig is [:lt,sel] => - STRINGP sel => - id:= INTERN sel - if $insideCapsuleFunctionIfTrue=true - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id],pred,fn,e) - -- atom sel => systemErrorHere '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - op='setelt and sig is [:lt,sel,v] => - STRINGP sel => - id:= INTERN sel - if $insideCapsuleFunctionIfTrue=true - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id,v],pred,fn,e) - -- atom sel => systemError '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - systemErrorHere '"addEltModemap" - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -addModemap1(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - if mc='Rep then - if fn is [kind,'Rep,.] and - -- save old sig for NRUNTIME - (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] - sig:= substitute("$",'Rep,sig) - currentProplist:= getProplist(op,e) or nil - newModemapList:= - mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) - newProplist:= augProplist(currentProplist,'modemap,newModemapList) - newProplist':= augProplist(newProplist,"FLUID",true) - unErrorRef op - --There may have been a warning about op having no value - addBinding(op,newProplist',e) - -mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == - entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] - member(entry,curModemapList) => curModemapList - (oldMap:= ASSOC(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => - $forceAdd => mergeModemap(entry,curModemapList,e) - opred=true => curModemapList - if pred^=true and pred^=opred then pred:= ["OR",pred,opred] - [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x - - --if new modemap less general, put at end; otherwise, at front - for x in curModemapList] - $InteractiveMode => insertModemap(entry,curModemapList) - mergeModemap(entry,curModemapList,e) - -mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == - for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat - mc=mc' or isSuperDomain(mc',mc,e) => - newmm:= nil - mm:= modemapList - while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) - if (mc=mc') and (sig=sig') then - --We only need one of these, unless the conditions are hairy - not $forceAdd and TruthP pred' => - entry:=nil - --the new predicate buys us nothing - return modemapList - TruthP pred => mmtail:=rest mmtail - --the thing we matched against is useless, by comparison - modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail]) - entry:= nil - return modemapList - if entry then [:modemapList,entry] else modemapList - --- next definition RPLACs, and hence causes problems. --- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled ---mergeModemap(entry:=((mc,:sig),:.),modemapList,e) == --- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do --- mc=mc' or isSuperDomain(mc',mc,e) => --- RPLACD(mmtail,(first mmtail,: rest mmtail)) --- RPLACA(mmtail,entry) --- entry := nil --- return modemapList --- if entry then (:modemapList,entry) else modemapList - -isSuperDomain(domainForm,domainForm',e) == - isSubset(domainForm',domainForm,e) => true - domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep - LASSOC(opOf domainForm',get(domainForm,"SubDomain",e)) - ---substituteForRep(entry is [[mc,:sig],:.],curModemapList) == --- --change 'Rep to "$" unless the resulting signature is already in $ --- member(entry':= substitute("$",'Rep,entry),curModemapList) => --- [entry,:curModemapList] --- [entry,entry',:curModemapList] - -addNewDomain(domain,e) == - augModemapsFromDomain(domain,domain,e) - -augModemapsFromDomain(name,functorForm,e) == - member(KAR name or name,$DummyFunctorNames) => e - name=$Category or isCategoryForm(name,e) => e - member(name,curDomainsInScope:= getDomainsInScope e) => e - if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then - e:= addNewDomain(first u,e) - --need code to handle parameterized SuperDomains - if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e) - if name is ["Union",:dl] then for d in stripUnionTags dl - repeat e:= addDomain(d,e) - augModemapsFromDomain1(name,functorForm,e) - --see LISPLIB BOOT - -substituteCategoryArguments(argl,catform) == - argl:= substitute("$$","$",argl) - arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] - SUBLIS(arglAssoc,catform) - - --Called, by compDefineFunctor, to add modemaps for $ that may - --be equivalent to those of Rep. We must check that these - --operations are not being redefined. -augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) - [repFnAlist,e]:= evalAndSub('Rep,'Rep,repDefn,getmode(repDefn,e),e) - catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) - compilerMessage ["Adding ",domainName," modemaps"] - e:= putDomainsInScope(domainName,e) - $base:= 4 - for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat - u:=ASSOC(SUBST('Rep,domainName,lhs),repFnAlist) - u and not AMFCR_,redefinedList(op,functorBody) => - fnsel':=CADDR u - e:= addModemap(op,domainName,sig,cond,fnsel',e) - e:= addModemap(op,domainName,sig,cond,fnsel,e) - e - -AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] - -AMFCR_,redefined(opname,u) == - not(u is [op,:l]) => nil - op = 'DEF => opname = CAAR l - MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l) - op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l] - -augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) - -- catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) - -- catform appears not to be used, so why set it? - --if ^$InteractiveMode then - compilerMessage ["Adding ",domainName," modemaps"] - e:= putDomainsInScope(domainName,e) - $base:= 4 - condlist:=[] - for [[op,sig,:.],cond,fnsel] in fnAlist repeat --- e:= addModemap(op,domainName,sig,cond,fnsel,e) ----------next 5 lines commented out to avoid wasting time checking knownInfo on ----------conditions attached to each modemap being added, takes a very long time ----------instead conditions will be checked when maps are actually used - --v:=ASSOC(cond,condlist) => - -- e:= addModemapKnown(op,domainName,sig,CDR v,fnsel,e) - --$e:local := e -- $e is used by knownInfo - --if knownInfo cond then cond1:=true else cond1:=cond - --condlist:=[[cond,:cond1],:condlist] - e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 --- for u in sig | (not member(u,$DomainsInScope)) and --- (not atom u) and --- (not isCategoryForm(u,e)) do --- e:= addNewDomain(u,e) - e - ---subCatParametersInto(domainForm,catForm,e) == --- -- JHD 08/08/84 perhaps we are fortunate that it is not used --- --this is particularly dirty and should be cleaned up, say, by wrapping --- -- an appropriate lambda expression around mapping forms --- domainForm is [op,:l] and l => --- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) --- catForm - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -evalAndSub(domainName,viewName,functorForm,form,$e) == - $lhsOfColon: local:= domainName - isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] - --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 - if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) - opAlist:= getOperationAlist(domainName,functorForm,form) - substAlist:= substNames(domainName,viewName,functorForm,opAlist) - [substitute("$","$$",substAlist),$e] - -getOperationAlist(name,functorForm,form) == - if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] --- (null isConstructorForm functorForm) and (u:= isFunctor functorForm) - (u:= isFunctor functorForm) and not - ($insideFunctorIfTrue and first functorForm=first $functorForm) => u - $insideFunctorIfTrue and name="$" => - ($domainShell => $domainShell.(1); systemError '"$ has no shell now") - T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) - stackMessage ["not a category form: ",form] - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -substNames(domainName,viewName,functorForm,catForm) == - EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, - -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred, - -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm]) - -- following calls to SUBSTQ must copy to save RPLAC's in - -- putInLocalDomainReferences - [[:SUBSTQ(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)] - for [:modemapform,fnsel] in catForm]) - -compCat(form is [functorName,:argl],m,e) == - fn:= GETL(functorName,"makeFunctionList") or return nil - [funList,e]:= FUNCALL(fn,form,form,e) - catForm:= - ["Join",'(SetCategory),["CATEGORY","domain",: - [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]] - --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not - --sure if it uses any of the other signatures(see extendsCategoryForm) - [form,catForm,e] - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -addConstructorModemaps(name,form is [functorName,:.],e) == - $InteractiveMode: local:= nil - e:= putDomainsInScope(name,e) --frame - fn := GETL(functorName,"makeFunctionList") - [funList,e]:= FUNCALL(fn,name,form,e) - for [op,sig,opcode] in funList repeat - e:= addModemap(op,name,sig,true,opcode,e) - e - - ---The way XLAMs work: --- ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) - -getDomainsInScope e == - $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope - get("$DomainsInScope","special",e) - -putDomainsInScope(x,e) == - l:= getDomainsInScope e - if member(x,l) then SAY("****** Domain: ",x," already in scope") - newValue:= [x,:delete(x,l)] - $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) - put("$DomainsInScope","special",newValue,e) - diff --git a/src/interp/modemap.boot.pamphlet b/src/interp/modemap.boot.pamphlet new file mode 100644 index 00000000..e5af0fac --- /dev/null +++ b/src/interp/modemap.boot.pamphlet @@ -0,0 +1,379 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp modemap.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% EXTERNAL ROUTINES + +--These functions are called from outside this file to add a domain +-- or to get the current domains in scope; + +addDomain(domain,e) == + atom domain => + EQ(domain,"$EmptyMode") => e + EQ(domain,"$NoValueMode") => e + not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and + EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e + MEMQ(domain,getDomainsInScope e) => e + isLiteral(domain,e) => e + addNewDomain(domain,e) + (name:= first domain)='Category => e + domainMember(domain,getDomainsInScope e) => e + getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> + addNewDomain(domain,e) + -- constructor? test needed for domains compiled with $bootStrapMode=true + isFunctor name or constructor? name => addNewDomain(domain,e) + if not isCategoryForm(domain,e) and + not member(name,'(Mapping CATEGORY)) then + unknownTypeError name + e --is not a functor + +domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] + +--% MODEMAP FUNCTIONS + +--getTargetMode(x is [op,:argl],e) == +-- CASES(#(mml:= getModemapList(op,#argl,e)), +-- (1 => +-- ([[.,target,:.],:.]:= first mml; substituteForFormalArguments(argl,target)) +-- ; 0 => MOAN(x," has no modemap"); systemError [x," has duplicate modemaps"])) + +getModemap(x is [op,:.],e) == + for modemap in get(op,'modemap,e) repeat + if u:= compApplyModemap(x,modemap,e,nil) then return + ([.,.,sl]:= u; SUBLIS(sl,modemap)) + +getUniqueSignature(form,e) == + [[.,:sig],:.]:= getUniqueModemap(first form,#rest form,e) or return nil + sig + +getUniqueModemap(op,numOfArgs,e) == + 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml + 1<#mml => + stackWarning [numOfArgs,'" argument form of: ",op, + '" has more than one modemap"] + first mml + nil + +getModemapList(op,numOfArgs,e) == + op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) + [mm for + (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] + +getModemapListFromDomain(op,numOfArgs,D,e) == + [mm + for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= + numOfArgs] + +addModemapKnown(op,mc,sig,pred,fn,$e) == +-- if knownInfo pred then pred:=true +-- that line is handled elsewhere + $insideCapsuleFunctionIfTrue=true => + $CapsuleModemapFrame := + addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) + $e + addModemap0(op,mc,sig,pred,fn,$e) + +addModemap0(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + $functorForm is ['CategoryDefaults,:.] and mc="$" => e + --don't put CD modemaps into environment + --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps + -- breaks -:($,$)->U($,failed) in DP + op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) + addModemap1(op,mc,sig,pred,fn,e) + +addEltModemap(op,mc,sig,pred,fn,e) == + --hack to change selectors from strings to identifiers; and to + --add flag identifiers as literals in the envir + op='elt and sig is [:lt,sel] => + STRINGP sel => + id:= INTERN sel + if $insideCapsuleFunctionIfTrue=true + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id],pred,fn,e) + -- atom sel => systemErrorHere '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + op='setelt and sig is [:lt,sel,v] => + STRINGP sel => + id:= INTERN sel + if $insideCapsuleFunctionIfTrue=true + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id,v],pred,fn,e) + -- atom sel => systemError '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + systemErrorHere '"addEltModemap" + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +addModemap1(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + if mc='Rep then + if fn is [kind,'Rep,.] and + -- save old sig for NRUNTIME + (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] + sig:= substitute("$",'Rep,sig) + currentProplist:= getProplist(op,e) or nil + newModemapList:= + mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) + newProplist:= augProplist(currentProplist,'modemap,newModemapList) + newProplist':= augProplist(newProplist,"FLUID",true) + unErrorRef op + --There may have been a warning about op having no value + addBinding(op,newProplist',e) + +mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == + entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] + member(entry,curModemapList) => curModemapList + (oldMap:= ASSOC(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => + $forceAdd => mergeModemap(entry,curModemapList,e) + opred=true => curModemapList + if pred^=true and pred^=opred then pred:= ["OR",pred,opred] + [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x + + --if new modemap less general, put at end; otherwise, at front + for x in curModemapList] + $InteractiveMode => insertModemap(entry,curModemapList) + mergeModemap(entry,curModemapList,e) + +mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == + for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat + mc=mc' or isSuperDomain(mc',mc,e) => + newmm:= nil + mm:= modemapList + while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) + if (mc=mc') and (sig=sig') then + --We only need one of these, unless the conditions are hairy + not $forceAdd and TruthP pred' => + entry:=nil + --the new predicate buys us nothing + return modemapList + TruthP pred => mmtail:=rest mmtail + --the thing we matched against is useless, by comparison + modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail]) + entry:= nil + return modemapList + if entry then [:modemapList,entry] else modemapList + +-- next definition RPLACs, and hence causes problems. +-- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled +--mergeModemap(entry:=((mc,:sig),:.),modemapList,e) == +-- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do +-- mc=mc' or isSuperDomain(mc',mc,e) => +-- RPLACD(mmtail,(first mmtail,: rest mmtail)) +-- RPLACA(mmtail,entry) +-- entry := nil +-- return modemapList +-- if entry then (:modemapList,entry) else modemapList + +isSuperDomain(domainForm,domainForm',e) == + isSubset(domainForm',domainForm,e) => true + domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep + LASSOC(opOf domainForm',get(domainForm,"SubDomain",e)) + +--substituteForRep(entry is [[mc,:sig],:.],curModemapList) == +-- --change 'Rep to "$" unless the resulting signature is already in $ +-- member(entry':= substitute("$",'Rep,entry),curModemapList) => +-- [entry,:curModemapList] +-- [entry,entry',:curModemapList] + +addNewDomain(domain,e) == + augModemapsFromDomain(domain,domain,e) + +augModemapsFromDomain(name,functorForm,e) == + member(KAR name or name,$DummyFunctorNames) => e + name=$Category or isCategoryForm(name,e) => e + member(name,curDomainsInScope:= getDomainsInScope e) => e + if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then + e:= addNewDomain(first u,e) + --need code to handle parameterized SuperDomains + if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e) + if name is ["Union",:dl] then for d in stripUnionTags dl + repeat e:= addDomain(d,e) + augModemapsFromDomain1(name,functorForm,e) + --see LISPLIB BOOT + +substituteCategoryArguments(argl,catform) == + argl:= substitute("$$","$",argl) + arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] + SUBLIS(arglAssoc,catform) + + --Called, by compDefineFunctor, to add modemaps for $ that may + --be equivalent to those of Rep. We must check that these + --operations are not being redefined. +augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) + [repFnAlist,e]:= evalAndSub('Rep,'Rep,repDefn,getmode(repDefn,e),e) + catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) + compilerMessage ["Adding ",domainName," modemaps"] + e:= putDomainsInScope(domainName,e) + $base:= 4 + for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat + u:=ASSOC(SUBST('Rep,domainName,lhs),repFnAlist) + u and not AMFCR_,redefinedList(op,functorBody) => + fnsel':=CADDR u + e:= addModemap(op,domainName,sig,cond,fnsel',e) + e:= addModemap(op,domainName,sig,cond,fnsel,e) + e + +AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] + +AMFCR_,redefined(opname,u) == + not(u is [op,:l]) => nil + op = 'DEF => opname = CAAR l + MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l) + op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l] + +augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) + -- catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) + -- catform appears not to be used, so why set it? + --if ^$InteractiveMode then + compilerMessage ["Adding ",domainName," modemaps"] + e:= putDomainsInScope(domainName,e) + $base:= 4 + condlist:=[] + for [[op,sig,:.],cond,fnsel] in fnAlist repeat +-- e:= addModemap(op,domainName,sig,cond,fnsel,e) +---------next 5 lines commented out to avoid wasting time checking knownInfo on +---------conditions attached to each modemap being added, takes a very long time +---------instead conditions will be checked when maps are actually used + --v:=ASSOC(cond,condlist) => + -- e:= addModemapKnown(op,domainName,sig,CDR v,fnsel,e) + --$e:local := e -- $e is used by knownInfo + --if knownInfo cond then cond1:=true else cond1:=cond + --condlist:=[[cond,:cond1],:condlist] + e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 +-- for u in sig | (not member(u,$DomainsInScope)) and +-- (not atom u) and +-- (not isCategoryForm(u,e)) do +-- e:= addNewDomain(u,e) + e + +--subCatParametersInto(domainForm,catForm,e) == +-- -- JHD 08/08/84 perhaps we are fortunate that it is not used +-- --this is particularly dirty and should be cleaned up, say, by wrapping +-- -- an appropriate lambda expression around mapping forms +-- domainForm is [op,:l] and l => +-- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) +-- catForm + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +evalAndSub(domainName,viewName,functorForm,form,$e) == + $lhsOfColon: local:= domainName + isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] + --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 + if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) + opAlist:= getOperationAlist(domainName,functorForm,form) + substAlist:= substNames(domainName,viewName,functorForm,opAlist) + [substitute("$","$$",substAlist),$e] + +getOperationAlist(name,functorForm,form) == + if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] +-- (null isConstructorForm functorForm) and (u:= isFunctor functorForm) + (u:= isFunctor functorForm) and not + ($insideFunctorIfTrue and first functorForm=first $functorForm) => u + $insideFunctorIfTrue and name="$" => + ($domainShell => $domainShell.(1); systemError '"$ has no shell now") + T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) + stackMessage ["not a category form: ",form] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +substNames(domainName,viewName,functorForm,catForm) == + EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, + -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred, + -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm]) + -- following calls to SUBSTQ must copy to save RPLAC's in + -- putInLocalDomainReferences + [[:SUBSTQ(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)] + for [:modemapform,fnsel] in catForm]) + +compCat(form is [functorName,:argl],m,e) == + fn:= GETL(functorName,"makeFunctionList") or return nil + [funList,e]:= FUNCALL(fn,form,form,e) + catForm:= + ["Join",'(SetCategory),["CATEGORY","domain",: + [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]] + --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not + --sure if it uses any of the other signatures(see extendsCategoryForm) + [form,catForm,e] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +addConstructorModemaps(name,form is [functorName,:.],e) == + $InteractiveMode: local:= nil + e:= putDomainsInScope(name,e) --frame + fn := GETL(functorName,"makeFunctionList") + [funList,e]:= FUNCALL(fn,name,form,e) + for [op,sig,opcode] in funList repeat + e:= addModemap(op,name,sig,true,opcode,e) + e + + +--The way XLAMs work: +-- ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) + +getDomainsInScope e == + $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope + get("$DomainsInScope","special",e) + +putDomainsInScope(x,e) == + l:= getDomainsInScope e + if member(x,l) then SAY("****** Domain: ",x," already in scope") + newValue:= [x,:delete(x,l)] + $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) + put("$DomainsInScope","special",newValue,e) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/msg.boot b/src/interp/msg.boot deleted file mode 100644 index d800554a..00000000 --- a/src/interp/msg.boot +++ /dev/null @@ -1,551 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -ListMember?(ob, l) == - MEMBER(ob, l, KEYWORD::TEST, function EQUAL) - ---% Messages for the USERS of the compiler. --- The program being compiled has a minor error. --- Give a message and continue processing. -ncSoftError(pos, erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - desiredMsg erMsgKey => - processKeyedError _ - msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix,optAttr) - --- The program being compiled is seriously incorrect. --- Give message and throw to a recovery point. -ncHardError(pos, erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - desiredMsg erMsgKey => - erMsg := processKeyedError _ - msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix,optAttr) - ncError() - --- Bug in the compiler: something which shouldn't have happened did. -ncBug (erMsgKey, erArgL,:optAttr) == - $newcompErrorCount := $newcompErrorCount + 1 - erMsg := processKeyedError _ - msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix,optAttr) - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - BREAK() - ncAbort() - ---% Lower level functions - ---msgObject tag -- catagory of msg --- -- attributes as a-list --- 'imPr => dont save for list processing --- toWhere, screen or file --- 'norep => only display once in list --- pos -- position with possible FROM/TO tag --- key -- key for message database --- argL -- arguments to be placed in the msg test --- prefix -- things like "Error: " --- text -- the actual text - -msgCreate(tag,posWTag,key,argL,optPre,:optAttr) == - if PAIRP key then tag := 'old - msg := [tag,posWTag,key,argL,optPre,NIL] - if CAR optAttr then - setMsgForcedAttrList(msg,car optAttr) - putDatabaseStuff msg - initImPr msg - initToWhere msg - msg - -processKeyedError msg == - getMsgTag? msg = 'old => --temp - erMsg := getMsgKey msg --temp - if pre := getMsgPrefix? msg then --temp - erMsg := ['%b, pre, '%d, :erMsg] --temp - sayBrightly ['"old msg from ",_ - CallerName 4,:erMsg] --temp - msgImPr? msg => - msgOutputter msg - $ncMsgList := cons (msg, $ncMsgList) - ---------------------------------- ---%getting info from db. -putDatabaseStuff msg == - [text,attributes] := getMsgInfoFromKey msg - if attributes then setMsgUnforcedAttrList(msg,attributes) - setMsgText(msg,text) - -getMsgInfoFromKey msg == - $msgDatabaseName : local := [] - msgText := - msgKey := getMsgKey? msg => --temp oldmsgs use key tostoretext - dbL := [$erLocMsgDatabaseName,$erGlbMsgDatabaseName] - getErFromDbL (msgKey,dbL) - getMsgKey msg --temp oldmsgs - msgText := segmentKeyedMsg msgText - [msgText,attributes] := removeAttributes msgText - msgText := substituteSegmentedMsg(msgText, getMsgArgL msg) - [msgText,attributes] - - -getErFromDbL (erMsgKey,dbL) == - erMsg := NIL - while null erMsg repeat - dbName := CAR dbL - dbL := CDR dbL - $msgDatabaseName := dbName - lastName := null dbL --- fileFound := '"co_-eng.msgs" - fileFound := '"s2_-us.msgs" - if fileFound or lastName then - erMsg := fetchKeyedMsg(erMsgKey,not lastName) - erMsg - ------------------------ ---%character position marking - -processChPosesForOneLine msgList == - chPosList := posPointers msgList - for msg in msgList repeat - if getMsgFTTag? msg then - putFTText (msg,chPosList) - posLetter := CDR ASSOC(poCharPosn getMsgPos msg,chPosList) - oldPre := getMsgPrefix msg - setMsgPrefix (msg,STRCONC(oldPre,_ - MAKE_-FULL_-CVEC ($preLength - 4 - SIZE oldPre),posLetter) ) - leaderMsg := makeLeaderMsg chPosList - NCONC(msgList,LIST leaderMsg) --a back cons - -posPointers msgList == ---gets all the char posns for msgs on one line ---associates them with a uppercase letter - pointers := '"ABCDEFGHIJKLMONPQRS" - increment := 0 - posList:= [] - ftPosList := [] - for msg in msgList repeat - pos := poCharPosn getMsgPos msg - if pos ^= IFCAR posList then - posList := [pos,:posList] - if getMsgFTTag? msg = 'FROMTO then - ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList] - for toPos in ftPosList repeat - posList := insertPos(toPos,posList) - for pos in posList repeat - posLetterList := [[pos,:pointers.increment],:posLetterList] - increment := increment + 1 - posLetterList - -insertPos(newPos,posList) == ---insersts a position in the proper place of a positon list ---used for the 2nd pos of a fromto - done := false - bot := [0,:posList] - top := [] - while not done repeat - top := [CAR bot,:top] - bot := CDR bot - pos := CAR bot - done := - pos < newPos => false - pos = newPos => true - pos > newPos => - top := [newPos,:top] - true - [CDR reverse top,:bot] - -putFTText (msg,chPosList) == - tag := getMsgFTTag? msg - pos := poCharPosn getMsgPos msg - charMarker := CDR ASSOC(pos,chPosList) - tag = 'FROM => - markingText := ['"(from ",charMarker,'" and on) "] - setMsgText(msg,[:markingText,:getMsgText msg]) - tag = 'TO => - markingText := ['"(up to ",charMarker,'") "] - setMsgText(msg,[:markingText,:getMsgText msg]) - tag = 'FROMTO => - pos2 := poCharPosn getMsgPos2 msg - charMarker2 := CDR ASSOC(pos2,chPosList) - markingText := ['"(from ",charMarker,'" up to ",_ - charMarker2,'") "] - setMsgText(msg,[:markingText,:getMsgText msg]) - -rep (c,n) == - n > 0 => - MAKE_-FULL_-CVEC(n, c) - '"" - ---called from parameter list of nc message functions -From pos == ['FROM, pos] -To pos == ['TO, pos] -FromTo (pos1,pos2) == ['FROMTO, pos1, pos2] - ------------------------- ---%processing error lists -processMsgList (erMsgList,lineList) == - $outputList :local := []--grows in queueUp errors - $noRepList :local := []--grows in queueUp errors - erMsgList := erMsgSort erMsgList - for line in lineList repeat - msgLine := makeMsgFromLine line - $outputList := [msgLine,:$outputList] - globalNumOfLine := poGlobalLinePosn getMsgPos msgLine - erMsgList := - queueUpErrors(globalNumOfLine,erMsgList) - $outputList := append(erMsgList,$outputList) --the nopos's - st := '"---------SOURCE-TEXT-&-ERRORS------------------------" - listOutputter reverse $outputList - -erMsgSort erMsgList == - [msgWPos,msgWOPos] := erMsgSep erMsgList - msgWPos := listSort(function erMsgCompare, msgWPos) - msgWOPos := reverse msgWOPos - [:msgWPos,:msgWOPos] - -erMsgCompare(ob1,ob2)== - pos1 := getMsgPos ob1 - pos2 := getMsgPos ob2 - compareposns(pos2,pos1) - -erMsgSep erMsgList == - msgWPos := [] - msgWOPos := [] - for msg in erMsgList repeat - if poNopos? getMsgPos msg then - msgWOPos := [msg,:msgWOPos] - else - msgWPos := [msg,:msgWPos] - [msgWPos,msgWOPos] - -getLinePos line == CAR line -getLineText line == CDR line - -queueUpErrors(globalNumOfLine,msgList)== - thisPosMsgs := [] - notThisLineMsgs := [] - for msg in msgList _ - while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat - --these are msgs that refer to positions from earlier compilations - if not redundant (msg,notThisPosMsgs) then - notThisPosMsgs := [msg,:notThisPosMsgs] - msgList := rest msgList - for msg in msgList _ - while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat - if not redundant (msg,thisPosMsgs) then - thisPosMsgs := [msg,:thisPosMsgs] - msgList := rest msgList - if thisPosMsgs then - thisPosMsgs := processChPosesForOneLine thisPosMsgs - $outputList := NCONC(thisPosMsgs,$outputList) - if notThisPosMsgs then - $outputList := NCONC(notThisPosMsgs,$outputList) - msgList - -redundant(msg,thisPosMsgs) == - found := NIL - if msgNoRep? msg then - for item in $noRepList repeat - sameMsg?(msg,item) => return (found := true) - $noRepList := [msg,$noRepList] - found or member(msg,thisPosMsgs) - -sameMsg? (msg1,msg2) == - (getMsgKey msg1 = getMsgKey msg2) and _ - (getMsgArgL msg1 = getMsgArgL msg2) - - -thisPosIsLess(pos,num) == - poNopos? pos => NIL - poGlobalLinePosn pos < num - -thisPosIsEqual(pos,num) == - poNopos? pos => NIL - poGlobalLinePosn pos = num - ---%outputting stuff - -listOutputter outputList == - for msg in outputList repeat - msgOutputter msg - -msgOutputter msg == - st := getStFromMsg msg - shouldFlow := not (leader? msg or line? msg) - if toScreen? msg then - if shouldFlow then - st := flowSegmentedMsg(st,$LINELENGTH,0) - sayBrightly st - if toFile? msg then - if shouldFlow then - st := flowSegmentedMsg(st,$LOGLENGTH,0) - alreadyOpened := alreadyOpened? msg - -toScreen? msg == getMsgToWhere msg ^= 'fileOnly -toFile? msg == - PAIRP $fn and _ - getMsgToWhere msg ^= 'screenOnly - - -alreadyOpened? msg == - not msgImPr? msg - -getStFromMsg msg == - $optKeyBlanks : local := '"" --set in setOptKeyBlanks() - setOptKeyBlanks() - preStL := getPreStL getMsgPrefix? msg - getMsgTag msg = 'line => - [$optKeyBlanks, '"%x1" , :preStL,_ - getMsgText msg] - posStL := getPosStL msg - optKey := - $showKeyNum => - msgKey := getMsgKey? msg => PNAME msgKey - '"no key " - '"" - st :=[posStL,getMsgLitSym msg,_ - optKey,:preStL,_ - tabbing msg,:getMsgText msg] - -tabbing msg == - chPos := 2 - if getMsgPrefix? msg then - chPos := chPos + $preLength - 1 - if $showKeyNum then chPos := chPos + 8 - ["%t",:chPos] - -setOptKeyBlanks() == - $optKeyBlanks := - $showKeyNum => '"%x8" - '"" - -getPosStL msg == - not showMsgPos? msg => '"" - msgPos := getMsgPos msg - howMuch := - msgImPr? msg => - decideHowMuch (msgPos,$lastPos) - listDecideHowMuch (msgPos,$lastPos) - $lastPos := msgPos - fullPrintedPos := ppos msgPos - printedFileName := ['"%x2",'"[",:remLine fullPrintedPos,'"]" ] - printedLineNum := ['"%x2",'"[",:remFile fullPrintedPos,'"]" ] - printedOrigin := ['"%x2",'"[",:fullPrintedPos,'"]" ] - howMuch = 'ORG => [$optKeyBlanks,:printedOrigin, '%l] - howMuch = 'LINE => [$optKeyBlanks,:printedLineNum, '%l] - howMuch = 'FILE => [$optKeyBlanks,:printedFileName, '%l] - howMuch = 'ALL => [$optKeyBlanks,:printedFileName, '%l,_ - $optKeyBlanks,:printedLineNum, '%l] - '"" - -showMsgPos? msg == - $erMsgToss or (not msgImPr? msg and not msgLeader? msg) - - -remFile positionList == - IFCDR IFCDR positionList - -remLine positionList == - [IFCAR positionList] - -decideHowMuch(pos,oldPos) == ---when printing a msg, we wish not to show pos infor that was ---shown for a previous msg with identical pos info. ---org prints out the word noposition or console - ((poNopos? pos) and (poNopos? oldPos)) or _ - ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE - (poNopos? pos) or (poPosImmediate? pos) => 'ORG - (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL - poFileName oldPos ^= poFileName pos => 'ALL - poLinePosn oldPos ^= poLinePosn pos => 'LINE - 'NONE - -listDecideHowMuch(pos,oldPos) == - ((poNopos? pos) and (poNopos? oldPos)) or _ - ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE - (poNopos? pos) => 'ORG - (poNopos? oldPos) => 'NONE - poGlobalLinePosn pos < poGlobalLinePosn oldPos => - poPosImmediate? pos => 'ORG - 'LINE - --(poNopos? pos) or (poPosImmediate? pos) => 'ORG - 'NONE - -getPreStL optPre == - null optPre => [MAKE_-FULL_-CVEC 2] - spses := - (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 => - MAKE_-FULL_-CVEC extraPlaces - '"" - ['%b, optPre,spses,'":", '%d] - -------------------- ---% a-list stuff -desiredMsg (erMsgKey,:optCatFlag) == - isKeyQualityP(erMsgKey,'show) => true - isKeyQualityP(erMsgKey,'stifle) => false - not null optCatFlag => CAR optCatFlag - true - -isKeyQualityP (key,qual) == - --returns pair if found, else NIL - found := false - while not found and (qualPair := ASSOC(key,$specificMsgTags)) repeat - if CDR qualPair = qual then found := true - qualPair - ------------------------------ ---% these functions handle the attributes - -initImPr msg == - $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) => - setMsgUnforcedAttr (msg,'$imPrGuys,'imPr) - -initToWhere msg == - member ('trace,getMsgCatAttr (msg,'catless)) => - setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly) - -msgImPr? msg == - (getMsgCatAttr (msg,'$imPrGuys) = 'imPr) - -msgNoRep? msg == - (getMsgCatAttr (msg,'$repGuys) = 'noRep) - -msgLeader? msg == - getMsgTag msg = 'leader - -getMsgToWhere msg == - getMsgCatAttr (msg,'$toWhereGuys) - -getMsgCatAttr (msg,cat) == - IFCDR QASSQ(cat, ncAlist msg) - -setMsgForcedAttrList (msg,aL) == - for attr in aL repeat - setMsgForcedAttr(msg,whichCat attr,attr) - -setMsgUnforcedAttrList (msg,aL) == - for attr in aL repeat - setMsgUnforcedAttr(msg,whichCat attr,attr) - -setMsgForcedAttr(msg,cat,attr) == - cat = 'catless => setMsgCatlessAttr(msg,attr) - ncPutQ(msg,cat,attr) - -setMsgUnforcedAttr(msg,cat,attr) == - cat = 'catless => setMsgCatlessAttr(msg,attr) - not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr) - -setMsgCatlessAttr(msg,attr) == - ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ(catless, ncAlist msg))) - -whichCat attr == - found := 'catless - for cat in $attrCats repeat - if ListMember? (attr,EVAL cat) then - found := cat - return found - found - --------------------------------------- ---% these functions directly interact with the message object - -makeLeaderMsg chPosList == - st := MAKE_-FULL_-CVEC ($preLength- 3) - oldPos := -1 - for [posNum,:posLetter] in reverse chPosList repeat - st := STRCONC(st, _ - rep(char ".", (posNum - oldPos - 1)),posLetter) - oldPos := posNum - ['leader,$nopos,'nokey,NIL,NIL,[st]] - -makeMsgFromLine line == - posOfLine := getLinePos line - textOfLine := getLineText line - globalNumOfLine := poGlobalLinePosn posOfLine - localNumOfLine := - i := poLinePosn posOfLine - stNum := STRINGIMAGE i - STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_ - stNum) - ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_ - textOfLine] - -getMsgTag msg == ncTag msg - -getMsgTag? msg == - IFCAR member (getMsgTag msg,_ - ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug]) - -leader? msg == getMsgTag msg = 'leader -line? msg == getMsgTag msg = 'line - -getMsgPosTagOb msg == msg.1 - -getMsgPos msg == - getMsgFTTag? msg => CADR getMsgPosTagOb msg - getMsgPosTagOb msg - -getMsgPos2 msg == - getMsgFTTag? msg => CADDR getMsgPosTagOb msg - ncBug('"not a from to",[]) - -getMsgFTTag? msg == IFCAR member (IFCAR getMsgPosTagOb msg,_ - ['FROM,'TO,'FROMTO]) - -getMsgKey msg == msg.2 - -getMsgKey? msg == IDENTP (val := getMsgKey msg) => val - -getMsgArgL msg == msg.3 - -getMsgPrefix? msg == - (pre := msg.4) = 'noPre => NIL - pre - -getMsgPrefix msg == msg.4 - - -getMsgLitSym msg == - getMsgKey? msg => '" " - '"*" - -getMsgText msg == msg.5 - -setMsgPrefix (msg,val) == msg.4 := val - -setMsgText (msg,val) == msg.5 := val - - - - diff --git a/src/interp/msg.boot.pamphlet b/src/interp/msg.boot.pamphlet new file mode 100644 index 00000000..ac311779 --- /dev/null +++ b/src/interp/msg.boot.pamphlet @@ -0,0 +1,577 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/msg.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +ListMember?(ob, l) == + MEMBER(ob, l, KEYWORD::TEST, function EQUAL) + +--% Messages for the USERS of the compiler. +-- The program being compiled has a minor error. +-- Give a message and continue processing. +ncSoftError(pos, erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + desiredMsg erMsgKey => + processKeyedError _ + msgCreate ('error, pos, erMsgKey, erArgL, $compErrorPrefix,optAttr) + +-- The program being compiled is seriously incorrect. +-- Give message and throw to a recovery point. +ncHardError(pos, erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + desiredMsg erMsgKey => + erMsg := processKeyedError _ + msgCreate('error,pos,erMsgKey, erArgL, $compErrorPrefix,optAttr) + ncError() + +-- Bug in the compiler: something which shouldn't have happened did. +ncBug (erMsgKey, erArgL,:optAttr) == + $newcompErrorCount := $newcompErrorCount + 1 + erMsg := processKeyedError _ + msgCreate('bug,$nopos, erMsgKey, erArgL,$compBugPrefix,optAttr) + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + BREAK() + ncAbort() + +--% Lower level functions + +--msgObject tag -- catagory of msg +-- -- attributes as a-list +-- 'imPr => dont save for list processing +-- toWhere, screen or file +-- 'norep => only display once in list +-- pos -- position with possible FROM/TO tag +-- key -- key for message database +-- argL -- arguments to be placed in the msg test +-- prefix -- things like "Error: " +-- text -- the actual text + +msgCreate(tag,posWTag,key,argL,optPre,:optAttr) == + if PAIRP key then tag := 'old + msg := [tag,posWTag,key,argL,optPre,NIL] + if CAR optAttr then + setMsgForcedAttrList(msg,car optAttr) + putDatabaseStuff msg + initImPr msg + initToWhere msg + msg + +processKeyedError msg == + getMsgTag? msg = 'old => --temp + erMsg := getMsgKey msg --temp + if pre := getMsgPrefix? msg then --temp + erMsg := ['%b, pre, '%d, :erMsg] --temp + sayBrightly ['"old msg from ",_ + CallerName 4,:erMsg] --temp + msgImPr? msg => + msgOutputter msg + $ncMsgList := cons (msg, $ncMsgList) + +--------------------------------- +--%getting info from db. +putDatabaseStuff msg == + [text,attributes] := getMsgInfoFromKey msg + if attributes then setMsgUnforcedAttrList(msg,attributes) + setMsgText(msg,text) + +getMsgInfoFromKey msg == + $msgDatabaseName : local := [] + msgText := + msgKey := getMsgKey? msg => --temp oldmsgs use key tostoretext + dbL := [$erLocMsgDatabaseName,$erGlbMsgDatabaseName] + getErFromDbL (msgKey,dbL) + getMsgKey msg --temp oldmsgs + msgText := segmentKeyedMsg msgText + [msgText,attributes] := removeAttributes msgText + msgText := substituteSegmentedMsg(msgText, getMsgArgL msg) + [msgText,attributes] + + +getErFromDbL (erMsgKey,dbL) == + erMsg := NIL + while null erMsg repeat + dbName := CAR dbL + dbL := CDR dbL + $msgDatabaseName := dbName + lastName := null dbL +-- fileFound := '"co_-eng.msgs" + fileFound := '"s2_-us.msgs" + if fileFound or lastName then + erMsg := fetchKeyedMsg(erMsgKey,not lastName) + erMsg + +----------------------- +--%character position marking + +processChPosesForOneLine msgList == + chPosList := posPointers msgList + for msg in msgList repeat + if getMsgFTTag? msg then + putFTText (msg,chPosList) + posLetter := CDR ASSOC(poCharPosn getMsgPos msg,chPosList) + oldPre := getMsgPrefix msg + setMsgPrefix (msg,STRCONC(oldPre,_ + MAKE_-FULL_-CVEC ($preLength - 4 - SIZE oldPre),posLetter) ) + leaderMsg := makeLeaderMsg chPosList + NCONC(msgList,LIST leaderMsg) --a back cons + +posPointers msgList == +--gets all the char posns for msgs on one line +--associates them with a uppercase letter + pointers := '"ABCDEFGHIJKLMONPQRS" + increment := 0 + posList:= [] + ftPosList := [] + for msg in msgList repeat + pos := poCharPosn getMsgPos msg + if pos ^= IFCAR posList then + posList := [pos,:posList] + if getMsgFTTag? msg = 'FROMTO then + ftPosList := [poCharPosn getMsgPos2 msg,:ftPosList] + for toPos in ftPosList repeat + posList := insertPos(toPos,posList) + for pos in posList repeat + posLetterList := [[pos,:pointers.increment],:posLetterList] + increment := increment + 1 + posLetterList + +insertPos(newPos,posList) == +--insersts a position in the proper place of a positon list +--used for the 2nd pos of a fromto + done := false + bot := [0,:posList] + top := [] + while not done repeat + top := [CAR bot,:top] + bot := CDR bot + pos := CAR bot + done := + pos < newPos => false + pos = newPos => true + pos > newPos => + top := [newPos,:top] + true + [CDR reverse top,:bot] + +putFTText (msg,chPosList) == + tag := getMsgFTTag? msg + pos := poCharPosn getMsgPos msg + charMarker := CDR ASSOC(pos,chPosList) + tag = 'FROM => + markingText := ['"(from ",charMarker,'" and on) "] + setMsgText(msg,[:markingText,:getMsgText msg]) + tag = 'TO => + markingText := ['"(up to ",charMarker,'") "] + setMsgText(msg,[:markingText,:getMsgText msg]) + tag = 'FROMTO => + pos2 := poCharPosn getMsgPos2 msg + charMarker2 := CDR ASSOC(pos2,chPosList) + markingText := ['"(from ",charMarker,'" up to ",_ + charMarker2,'") "] + setMsgText(msg,[:markingText,:getMsgText msg]) + +rep (c,n) == + n > 0 => + MAKE_-FULL_-CVEC(n, c) + '"" + +--called from parameter list of nc message functions +From pos == ['FROM, pos] +To pos == ['TO, pos] +FromTo (pos1,pos2) == ['FROMTO, pos1, pos2] + +------------------------ +--%processing error lists +processMsgList (erMsgList,lineList) == + $outputList :local := []--grows in queueUp errors + $noRepList :local := []--grows in queueUp errors + erMsgList := erMsgSort erMsgList + for line in lineList repeat + msgLine := makeMsgFromLine line + $outputList := [msgLine,:$outputList] + globalNumOfLine := poGlobalLinePosn getMsgPos msgLine + erMsgList := + queueUpErrors(globalNumOfLine,erMsgList) + $outputList := append(erMsgList,$outputList) --the nopos's + st := '"---------SOURCE-TEXT-&-ERRORS------------------------" + listOutputter reverse $outputList + +erMsgSort erMsgList == + [msgWPos,msgWOPos] := erMsgSep erMsgList + msgWPos := listSort(function erMsgCompare, msgWPos) + msgWOPos := reverse msgWOPos + [:msgWPos,:msgWOPos] + +erMsgCompare(ob1,ob2)== + pos1 := getMsgPos ob1 + pos2 := getMsgPos ob2 + compareposns(pos2,pos1) + +erMsgSep erMsgList == + msgWPos := [] + msgWOPos := [] + for msg in erMsgList repeat + if poNopos? getMsgPos msg then + msgWOPos := [msg,:msgWOPos] + else + msgWPos := [msg,:msgWPos] + [msgWPos,msgWOPos] + +getLinePos line == CAR line +getLineText line == CDR line + +queueUpErrors(globalNumOfLine,msgList)== + thisPosMsgs := [] + notThisLineMsgs := [] + for msg in msgList _ + while thisPosIsLess(getMsgPos msg,globalNumOfLine) repeat + --these are msgs that refer to positions from earlier compilations + if not redundant (msg,notThisPosMsgs) then + notThisPosMsgs := [msg,:notThisPosMsgs] + msgList := rest msgList + for msg in msgList _ + while thisPosIsEqual(getMsgPos msg,globalNumOfLine) repeat + if not redundant (msg,thisPosMsgs) then + thisPosMsgs := [msg,:thisPosMsgs] + msgList := rest msgList + if thisPosMsgs then + thisPosMsgs := processChPosesForOneLine thisPosMsgs + $outputList := NCONC(thisPosMsgs,$outputList) + if notThisPosMsgs then + $outputList := NCONC(notThisPosMsgs,$outputList) + msgList + +redundant(msg,thisPosMsgs) == + found := NIL + if msgNoRep? msg then + for item in $noRepList repeat + sameMsg?(msg,item) => return (found := true) + $noRepList := [msg,$noRepList] + found or member(msg,thisPosMsgs) + +sameMsg? (msg1,msg2) == + (getMsgKey msg1 = getMsgKey msg2) and _ + (getMsgArgL msg1 = getMsgArgL msg2) + + +thisPosIsLess(pos,num) == + poNopos? pos => NIL + poGlobalLinePosn pos < num + +thisPosIsEqual(pos,num) == + poNopos? pos => NIL + poGlobalLinePosn pos = num + +--%outputting stuff + +listOutputter outputList == + for msg in outputList repeat + msgOutputter msg + +msgOutputter msg == + st := getStFromMsg msg + shouldFlow := not (leader? msg or line? msg) + if toScreen? msg then + if shouldFlow then + st := flowSegmentedMsg(st,$LINELENGTH,0) + sayBrightly st + if toFile? msg then + if shouldFlow then + st := flowSegmentedMsg(st,$LOGLENGTH,0) + alreadyOpened := alreadyOpened? msg + +toScreen? msg == getMsgToWhere msg ^= 'fileOnly +toFile? msg == + PAIRP $fn and _ + getMsgToWhere msg ^= 'screenOnly + + +alreadyOpened? msg == + not msgImPr? msg + +getStFromMsg msg == + $optKeyBlanks : local := '"" --set in setOptKeyBlanks() + setOptKeyBlanks() + preStL := getPreStL getMsgPrefix? msg + getMsgTag msg = 'line => + [$optKeyBlanks, '"%x1" , :preStL,_ + getMsgText msg] + posStL := getPosStL msg + optKey := + $showKeyNum => + msgKey := getMsgKey? msg => PNAME msgKey + '"no key " + '"" + st :=[posStL,getMsgLitSym msg,_ + optKey,:preStL,_ + tabbing msg,:getMsgText msg] + +tabbing msg == + chPos := 2 + if getMsgPrefix? msg then + chPos := chPos + $preLength - 1 + if $showKeyNum then chPos := chPos + 8 + ["%t",:chPos] + +setOptKeyBlanks() == + $optKeyBlanks := + $showKeyNum => '"%x8" + '"" + +getPosStL msg == + not showMsgPos? msg => '"" + msgPos := getMsgPos msg + howMuch := + msgImPr? msg => + decideHowMuch (msgPos,$lastPos) + listDecideHowMuch (msgPos,$lastPos) + $lastPos := msgPos + fullPrintedPos := ppos msgPos + printedFileName := ['"%x2",'"[",:remLine fullPrintedPos,'"]" ] + printedLineNum := ['"%x2",'"[",:remFile fullPrintedPos,'"]" ] + printedOrigin := ['"%x2",'"[",:fullPrintedPos,'"]" ] + howMuch = 'ORG => [$optKeyBlanks,:printedOrigin, '%l] + howMuch = 'LINE => [$optKeyBlanks,:printedLineNum, '%l] + howMuch = 'FILE => [$optKeyBlanks,:printedFileName, '%l] + howMuch = 'ALL => [$optKeyBlanks,:printedFileName, '%l,_ + $optKeyBlanks,:printedLineNum, '%l] + '"" + +showMsgPos? msg == + $erMsgToss or (not msgImPr? msg and not msgLeader? msg) + + +remFile positionList == + IFCDR IFCDR positionList + +remLine positionList == + [IFCAR positionList] + +decideHowMuch(pos,oldPos) == +--when printing a msg, we wish not to show pos infor that was +--shown for a previous msg with identical pos info. +--org prints out the word noposition or console + ((poNopos? pos) and (poNopos? oldPos)) or _ + ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE + (poNopos? pos) or (poPosImmediate? pos) => 'ORG + (poNopos? oldPos) or (poPosImmediate? oldPos) => 'ALL + poFileName oldPos ^= poFileName pos => 'ALL + poLinePosn oldPos ^= poLinePosn pos => 'LINE + 'NONE + +listDecideHowMuch(pos,oldPos) == + ((poNopos? pos) and (poNopos? oldPos)) or _ + ((poPosImmediate? pos) and (poPosImmediate? oldPos)) => 'NONE + (poNopos? pos) => 'ORG + (poNopos? oldPos) => 'NONE + poGlobalLinePosn pos < poGlobalLinePosn oldPos => + poPosImmediate? pos => 'ORG + 'LINE + --(poNopos? pos) or (poPosImmediate? pos) => 'ORG + 'NONE + +getPreStL optPre == + null optPre => [MAKE_-FULL_-CVEC 2] + spses := + (extraPlaces := ($preLength - (SIZE optPre) - 3)) > 0 => + MAKE_-FULL_-CVEC extraPlaces + '"" + ['%b, optPre,spses,'":", '%d] + +------------------- +--% a-list stuff +desiredMsg (erMsgKey,:optCatFlag) == + isKeyQualityP(erMsgKey,'show) => true + isKeyQualityP(erMsgKey,'stifle) => false + not null optCatFlag => CAR optCatFlag + true + +isKeyQualityP (key,qual) == + --returns pair if found, else NIL + found := false + while not found and (qualPair := ASSOC(key,$specificMsgTags)) repeat + if CDR qualPair = qual then found := true + qualPair + +----------------------------- +--% these functions handle the attributes + +initImPr msg == + $erMsgToss or MEMQ (getMsgTag msg,$imPrTagGuys) => + setMsgUnforcedAttr (msg,'$imPrGuys,'imPr) + +initToWhere msg == + member ('trace,getMsgCatAttr (msg,'catless)) => + setMsgUnforcedAttr (msg,'$toWhereGuys,'screenOnly) + +msgImPr? msg == + (getMsgCatAttr (msg,'$imPrGuys) = 'imPr) + +msgNoRep? msg == + (getMsgCatAttr (msg,'$repGuys) = 'noRep) + +msgLeader? msg == + getMsgTag msg = 'leader + +getMsgToWhere msg == + getMsgCatAttr (msg,'$toWhereGuys) + +getMsgCatAttr (msg,cat) == + IFCDR QASSQ(cat, ncAlist msg) + +setMsgForcedAttrList (msg,aL) == + for attr in aL repeat + setMsgForcedAttr(msg,whichCat attr,attr) + +setMsgUnforcedAttrList (msg,aL) == + for attr in aL repeat + setMsgUnforcedAttr(msg,whichCat attr,attr) + +setMsgForcedAttr(msg,cat,attr) == + cat = 'catless => setMsgCatlessAttr(msg,attr) + ncPutQ(msg,cat,attr) + +setMsgUnforcedAttr(msg,cat,attr) == + cat = 'catless => setMsgCatlessAttr(msg,attr) + not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr) + +setMsgCatlessAttr(msg,attr) == + ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ(catless, ncAlist msg))) + +whichCat attr == + found := 'catless + for cat in $attrCats repeat + if ListMember? (attr,EVAL cat) then + found := cat + return found + found + +-------------------------------------- +--% these functions directly interact with the message object + +makeLeaderMsg chPosList == + st := MAKE_-FULL_-CVEC ($preLength- 3) + oldPos := -1 + for [posNum,:posLetter] in reverse chPosList repeat + st := STRCONC(st, _ + rep(char ".", (posNum - oldPos - 1)),posLetter) + oldPos := posNum + ['leader,$nopos,'nokey,NIL,NIL,[st]] + +makeMsgFromLine line == + posOfLine := getLinePos line + textOfLine := getLineText line + globalNumOfLine := poGlobalLinePosn posOfLine + localNumOfLine := + i := poLinePosn posOfLine + stNum := STRINGIMAGE i + STRCONC(rep(char " ", ($preLength - 7 - SIZE stNum)),_ + stNum) + ['line,posOfLine,NIL,NIL, STRCONC('"Line", localNumOfLine),_ + textOfLine] + +getMsgTag msg == ncTag msg + +getMsgTag? msg == + IFCAR member (getMsgTag msg,_ + ['line,'old,'error,'warn,'bug,'unimple,'remark,'stat,'say,'debug]) + +leader? msg == getMsgTag msg = 'leader +line? msg == getMsgTag msg = 'line + +getMsgPosTagOb msg == msg.1 + +getMsgPos msg == + getMsgFTTag? msg => CADR getMsgPosTagOb msg + getMsgPosTagOb msg + +getMsgPos2 msg == + getMsgFTTag? msg => CADDR getMsgPosTagOb msg + ncBug('"not a from to",[]) + +getMsgFTTag? msg == IFCAR member (IFCAR getMsgPosTagOb msg,_ + ['FROM,'TO,'FROMTO]) + +getMsgKey msg == msg.2 + +getMsgKey? msg == IDENTP (val := getMsgKey msg) => val + +getMsgArgL msg == msg.3 + +getMsgPrefix? msg == + (pre := msg.4) = 'noPre => NIL + pre + +getMsgPrefix msg == msg.4 + + +getMsgLitSym msg == + getMsgKey? msg => '" " + '"*" + +getMsgText msg == msg.5 + +setMsgPrefix (msg,val) == msg.4 := val + +setMsgText (msg,val) == msg.5 := val + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-c02.boot b/src/interp/nag-c02.boot deleted file mode 100644 index 8e7434c9..00000000 --- a/src/interp/nag-c02.boot +++ /dev/null @@ -1,294 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -c02aff() == - htInitPage('"C02AFF - All Zeros of a Complex Polynomial",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc02aff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c02aff| '|NagPolynomialRootsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Finds all the roots of the complex polynomial equation ") - (text . "\htbitmap{c02aff}, using a variant of Laguerre's method. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{} ") - (text . "\tab{2} Enter the degree {\em n} of the polynomial:") - (text . "\newline\tab{2} ") - (bcStrings (5 5 n PI)) - (text . "\blankline") - (text . "\newline") - (text . "\newline \menuitemstyle{} \tab{2} Scale value:") - (radioButtons scale - ("" " True" true) - ("" " False" false)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c02affSolve) - htShowPage() - -c02affSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - logical := htpButtonValue(htPage,'scale) - scale := - logical = 'true => '"true" - '"false" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '5 => c02affDefaultSolve(htPage,scale,ifail) - labelList := - "append"/[f(i,n) for i in 1..(n+1)] where f(i,n) == - prefix := ('"\newline z**") - prefix := STRCONC(prefix,STRINGIMAGE (n-i+1),'"\space{1}") - post := ('"\tab{30} ") - post := STRCONC(post,'"\space{1}") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - inam := INTERN STRCONC ('"i",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], - ['text,:post],['bcStrings,[10, 0.0, inam, 'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("C02AFF - All Zeros of a Complex Polynomial", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} Enter the coefficients of the polynomial: " - htSay '"\blankline " - htSay '"Real parts \tab{30} Imaginary parts " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'c02affGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'scale,scale) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c02affDefaultSolve (htPage, scale, ifail) == - n := '5 - page := htInitPage('"C02AFF - All Zeros of a Complex Polynomial",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Enter the coefficients of the polynomial: ") - (text . "\blankline ") - (text . "Real parts \tab{30} Imaginary parts ") - (text . "\newline z**5 \space{1} ") - (bcStrings (10 "5.0" r1 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "6.0" i1 F)) - (text . "\newline ") - (text . "z**4 \space{1} ") - (bcStrings (10 "30.0" r2 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "20.0" i2 F)) - (text . "\newline ") - (text . "z**3 \space{1} ") - (bcStrings (10 "-0.2" r3 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "-6.0" i3 F)) - (text . "\newline ") - (text . "z**2 \space{1} ") - (bcStrings (10 "50.0" r4 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "100000.0" i4 F)) - (text . "\newline ") - (text . "z**1 \space{1} ") - (bcStrings (10 "-2.0" r5 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "40.0" i5 F)) - (text . "\newline ") - (text . "z**0 \space{1} ") - (bcStrings (10 "10.0" r6 F)) - (text . "\tab{30} ") - (text . "\space{1} ") - (bcStrings (10 "1.0" i6 F)) - (text . "\newline ") - (text . "\blankline")) - htMakeDoneButton('"Continue",'c02affGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'scale,scale) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c02affGen htPage == - n := htpProperty(htPage,'n) - scale := htpProperty(htPage,'scale) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC((first y).1," ") - y := rest y - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - linkGen STRCONC ('"c02aff([",realstring,",",imagstring,"],",STRINGIMAGE n,",",scale,",",STRINGIMAGE ifail,")") - -c02agf() == - htInitPage('"C02AGF - All Zeros of a Real Polynomial",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc02agf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c02agf| '|NagPolynomialRootsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Finds all the roots of the real polynomial equation ") - (text . "\htbitmap{c02aff}, using a variant of Laguerre's method. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{} ") - (text . "\tab{2} Enter the degree {\em n} of the polynomial:") - (text . "\newline\tab{2} ") - (bcStrings (5 5 n PI)) - (text . "\blankline") - (text . "\newline") - (text . "\newline \menuitemstyle{} \tab{2} Scale value:") - (radioButtons scale - ("" " True" true) - ("" " False" false)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c02agfSolve) - htShowPage() - -c02agfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - logical := htpButtonValue(htPage,'scale) - scale := - logical = 'true => '"true" - '"false" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '5 => c02agfDefaultSolve(htPage,scale,ifail) - labelList := - "append"/[f(i,n) for i in 1..(n+1)] where f(i,n) == - prefix := ('"\newline z**") - prefix := STRCONC(prefix,STRINGIMAGE (n-i+1),'"\space{1}") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("C02AGF - All Zeros of a Real Polynomial", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the coefficients of the polynomial: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'c02agfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'scale,scale) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c02agfDefaultSolve (htPage, scale, ifail) == - n := '5 - page := htInitPage('"C02AGF - All Zeros of a Real Polynomial",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Enter the coefficients of the polynomial: ") - (text . "\newline ") - (text . "z**5 \space{1} ") - (bcStrings (10 "1.0" r1 F)) - (text . "\newline ") - (text . "z**4 \space{1} ") - (bcStrings (10 "2.0" r2 F)) - (text . "\newline ") - (text . "z**3 \space{1} ") - (bcStrings (10 "3.0" r3 F)) - (text . "\newline ") - (text . "z**2 \space{1} ") - (bcStrings (10 "4.0" r4 F)) - (text . "\newline ") - (text . "z**1 \space{1} ") - (bcStrings (10 "5.0" r5 F)) - (text . "\newline ") - (text . "z**0 \space{1} ") - (bcStrings (10 "6.0" r6 F)) - (text . "\newline ") - (text . "\blankline")) - htMakeDoneButton('"Continue",'c02agfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'scale,scale) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c02agfGen htPage == - n := htpProperty(htPage,'n) - scale := htpProperty(htPage,'scale) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c02agf([",realstring,"],",STRINGIMAGE n,",",scale,",",STRINGIMAGE ifail,")") - - diff --git a/src/interp/nag-c02.boot.pamphlet b/src/interp/nag-c02.boot.pamphlet new file mode 100644 index 00000000..ed5821e7 --- /dev/null +++ b/src/interp/nag-c02.boot.pamphlet @@ -0,0 +1,316 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-c02.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +c02aff() == + htInitPage('"C02AFF - All Zeros of a Complex Polynomial",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc02aff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c02aff| '|NagPolynomialRootsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Finds all the roots of the complex polynomial equation ") + (text . "\htbitmap{c02aff}, using a variant of Laguerre's method. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{} ") + (text . "\tab{2} Enter the degree {\em n} of the polynomial:") + (text . "\newline\tab{2} ") + (bcStrings (5 5 n PI)) + (text . "\blankline") + (text . "\newline") + (text . "\newline \menuitemstyle{} \tab{2} Scale value:") + (radioButtons scale + ("" " True" true) + ("" " False" false)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c02affSolve) + htShowPage() + +c02affSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + logical := htpButtonValue(htPage,'scale) + scale := + logical = 'true => '"true" + '"false" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '5 => c02affDefaultSolve(htPage,scale,ifail) + labelList := + "append"/[f(i,n) for i in 1..(n+1)] where f(i,n) == + prefix := ('"\newline z**") + prefix := STRCONC(prefix,STRINGIMAGE (n-i+1),'"\space{1}") + post := ('"\tab{30} ") + post := STRCONC(post,'"\space{1}") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + inam := INTERN STRCONC ('"i",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], + ['text,:post],['bcStrings,[10, 0.0, inam, 'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("C02AFF - All Zeros of a Complex Polynomial", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} Enter the coefficients of the polynomial: " + htSay '"\blankline " + htSay '"Real parts \tab{30} Imaginary parts " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'c02affGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'scale,scale) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c02affDefaultSolve (htPage, scale, ifail) == + n := '5 + page := htInitPage('"C02AFF - All Zeros of a Complex Polynomial",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Enter the coefficients of the polynomial: ") + (text . "\blankline ") + (text . "Real parts \tab{30} Imaginary parts ") + (text . "\newline z**5 \space{1} ") + (bcStrings (10 "5.0" r1 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "6.0" i1 F)) + (text . "\newline ") + (text . "z**4 \space{1} ") + (bcStrings (10 "30.0" r2 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "20.0" i2 F)) + (text . "\newline ") + (text . "z**3 \space{1} ") + (bcStrings (10 "-0.2" r3 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "-6.0" i3 F)) + (text . "\newline ") + (text . "z**2 \space{1} ") + (bcStrings (10 "50.0" r4 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "100000.0" i4 F)) + (text . "\newline ") + (text . "z**1 \space{1} ") + (bcStrings (10 "-2.0" r5 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "40.0" i5 F)) + (text . "\newline ") + (text . "z**0 \space{1} ") + (bcStrings (10 "10.0" r6 F)) + (text . "\tab{30} ") + (text . "\space{1} ") + (bcStrings (10 "1.0" i6 F)) + (text . "\newline ") + (text . "\blankline")) + htMakeDoneButton('"Continue",'c02affGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'scale,scale) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c02affGen htPage == + n := htpProperty(htPage,'n) + scale := htpProperty(htPage,'scale) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC((first y).1," ") + y := rest y + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + linkGen STRCONC ('"c02aff([",realstring,",",imagstring,"],",STRINGIMAGE n,",",scale,",",STRINGIMAGE ifail,")") + +c02agf() == + htInitPage('"C02AGF - All Zeros of a Real Polynomial",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc02agf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c02agf| '|NagPolynomialRootsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Finds all the roots of the real polynomial equation ") + (text . "\htbitmap{c02aff}, using a variant of Laguerre's method. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{} ") + (text . "\tab{2} Enter the degree {\em n} of the polynomial:") + (text . "\newline\tab{2} ") + (bcStrings (5 5 n PI)) + (text . "\blankline") + (text . "\newline") + (text . "\newline \menuitemstyle{} \tab{2} Scale value:") + (radioButtons scale + ("" " True" true) + ("" " False" false)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c02agfSolve) + htShowPage() + +c02agfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + logical := htpButtonValue(htPage,'scale) + scale := + logical = 'true => '"true" + '"false" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '5 => c02agfDefaultSolve(htPage,scale,ifail) + labelList := + "append"/[f(i,n) for i in 1..(n+1)] where f(i,n) == + prefix := ('"\newline z**") + prefix := STRCONC(prefix,STRINGIMAGE (n-i+1),'"\space{1}") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("C02AGF - All Zeros of a Real Polynomial", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the coefficients of the polynomial: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'c02agfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'scale,scale) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c02agfDefaultSolve (htPage, scale, ifail) == + n := '5 + page := htInitPage('"C02AGF - All Zeros of a Real Polynomial",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Enter the coefficients of the polynomial: ") + (text . "\newline ") + (text . "z**5 \space{1} ") + (bcStrings (10 "1.0" r1 F)) + (text . "\newline ") + (text . "z**4 \space{1} ") + (bcStrings (10 "2.0" r2 F)) + (text . "\newline ") + (text . "z**3 \space{1} ") + (bcStrings (10 "3.0" r3 F)) + (text . "\newline ") + (text . "z**2 \space{1} ") + (bcStrings (10 "4.0" r4 F)) + (text . "\newline ") + (text . "z**1 \space{1} ") + (bcStrings (10 "5.0" r5 F)) + (text . "\newline ") + (text . "z**0 \space{1} ") + (bcStrings (10 "6.0" r6 F)) + (text . "\newline ") + (text . "\blankline")) + htMakeDoneButton('"Continue",'c02agfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'scale,scale) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c02agfGen htPage == + n := htpProperty(htPage,'n) + scale := htpProperty(htPage,'scale) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c02agf([",realstring,"],",STRINGIMAGE n,",",scale,",",STRINGIMAGE ifail,")") + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-c05.boot b/src/interp/nag-c05.boot deleted file mode 100644 index ef7f9554..00000000 --- a/src/interp/nag-c05.boot +++ /dev/null @@ -1,402 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -c05adf() == - htInitPage('"C05ADF - Zero of continuous function in given interval, Bus and Dekker algorithm",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXc05adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05adf| '|NagRootFindingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "C05ADF locates a zero of a continuous function in a ") - (text . "interval by a combination of the methods of linear ") - (text . "interpolation, extrapolation and bisection. ") - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the function whose zero is to be determined ") - (text . "as a function of X, {\it f}: ") - (text . "\newline\tab{2} ") - (bcStrings (55 "exp(-X)-X" expression EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Lower bound of the interval {\it a}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Upper bound {\it b}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0" b F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute tolerance {\it eps}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Value tolerance {\it eta}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-5" eps F)) - (text . "\tab{34} ") - (bcStrings (10 "0.0" eta F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c05adfGen) - htShowPage() - -c05adfGen htPage == - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - eps := htpLabelInputString(htPage,'eps) - eta := htpLabelInputString(htPage,'eta) - temp := READ_-FROM_-STRING(eps) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - temp1 := - temp > 0.0 => eps - '"1.0e-5" - expression := htpLabelInputString(htPage, 'expression) - prefix := STRCONC('"c05adf(",a,",",b,",",temp1,",",eta,",",STRINGIMAGE ifail) - linkGen STRCONC (prefix,",(",expression,")::ASP1(F))") - - -c05nbf() == - htInitPage('"C05NBF - Solution of system of nonlinear equations using function values only",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc05nbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05nbf| '|NagRootFindingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "C05NBF finds a solution of a system of nonlinear equations ") - (text . "by a modification of the Powell hybrid method. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of equations in the system {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Accuracy required {\it xtol}:") - (text . "\newline\tab{2} ") - -- should be sqrt(machine precision) - (bcStrings (10 "1.0e-9" xtol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c05nbfSolve) - htShowPage() - -c05nbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - xtol := htpLabelInputString(htPage,'xtol) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '9 => c05nbfDefaultSolve(htPage,ifail,xtol) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"X[",STRINGIMAGE i ,"] + 1") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x}: \newline ") - middle := cons('text,middle) - vecList := - [fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ['bcStrings,[4, -1.0, xnam, 'F]] - funcList := [:funcList,middle,:vecList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList] - page := htInitPage("C05NBF - Solution of system of nonlinear equations using function values only", htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'c05nbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'xtol,xtol) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c05nbfDefaultSolve (htPage,ifail,xtol) == - n := '9 - page := htInitPage("C05NBF - Solution of system of nonlinear equations using function values only", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]; ") - (text . " \newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (42 "3*X[1] - 2*X[1]**2 - 2*X[2] + 1" n1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (42 "-X[1] + 3*X[2] - 2*X[2]**2 - 2*X[3] + 1" n2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (42 "-X[2] + 3*X[3] - 2*X[3]**2 - 2*X[4] + 1" n3 EM)) - (text . "\newline {\em Function 4:} \space{1}") - (bcStrings (42 "-X[3] + 3*X[4] - 2*X[4]**2 - 2*X[5] + 1" n4 EM)) - (text . "\newline {\em Function 5:} \space{1}") - (bcStrings (42 "-X[4] + 3*X[5] - 2*X[5]**2 - 2*X[6] + 1" n5 EM)) - (text . "\newline {\em Function 6:} \space{1}") - (bcStrings (42 "-X[5] + 3*X[6] - 2*X[6]**2 - 2*X[7] + 1" n6 EM)) - (text . "\newline {\em Function 7:} \space{1}") - (bcStrings (42 "-X[6] + 3*X[7] - 2*X[7]**2 - 2*X[8] + 1" n7 EM)) - (text . "\newline {\em Function 8:} \space{1}") - (bcStrings (42 "-X[7] + 3*X[8] - 2*X[8]**2 - 2*X[9] + 1" n8 EM)) - (text . "\newline {\em Function 9:} \space{1}") - (bcStrings (42 "-X[8] + 3*X[9] - 2*X[9]**2 + 1" n9 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector {\it x}: \newline ") - (bcStrings (4 "-1.0" x1 F)) - (bcStrings (4 "-1.0" x2 F)) - (bcStrings (4 "-1.0" x3 F)) - (bcStrings (4 "-1.0" x4 F)) - (bcStrings (4 "-1.0" x5 F)) - (bcStrings (4 "-1.0" x6 F)) - (bcStrings (4 "-1.0" x7 F)) - (bcStrings (4 "-1.0" x8 F)) - (bcStrings (4 "-1.0" x9 F))) - htMakeDoneButton('"Continue",'c05nbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'xtol,xtol) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c05nbfGen htPage == - n := htpProperty(htPage, 'n) - ifail := htpProperty(htPage,'ifail) - xtol := htpProperty(htPage,'xtol) - alist := htpInputAreaAlist htPage - y := alist - i := 1 - while y repeat - if i < (n+1) then - temp1 := STRCONC ((first y).1," ") - temp1list := [temp1,:temp1list] - else - temp2 := (first y).1 - temp2list := [temp2,:temp2list] - y := rest y - i := i + 1 - string1 := bcwords2liststring temp1list - string2 := bcwords2liststring temp2list - lwa := n*(3*n+13)/2 - prefix := STRCONC ("c05nbf(",STRINGIMAGE n,",",STRINGIMAGE lwa,",[",string1,"],") - middle := STRCONC (xtol,",",STRINGIMAGE ifail,",") - linkGen STRCONC (prefix,middle,"(",string2,"::Vector Expression(Float))::ASP6(FCN))") - -c05pbf() == - htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc05pbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05pbf| '|NagRootFindingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "C05PBF finds a solution of a system of nonlinear equations ") - (text . "by a modification of the Powell hybrid method. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of equations in the system {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Accuracy required {\it xtol}:") - (text . "\newline\tab{2} ") - -- should be sqrt(machine precision) - (bcStrings (10 "1.0e-9" xtol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c05pbfSolve) - htShowPage() - -c05pbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - xtol := htpLabelInputString(htPage,'xtol) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '9 => c05pbfDefaultSolve(htPage,ifail,xtol) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"X[",STRINGIMAGE i ,"] + 1") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x}: \newline ") - middle := cons('text,middle) - vecList := - [fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ['bcStrings,[4, -1.0, xnam, 'F]] - funcList := [:funcList,middle,:vecList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList] - page := htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'c05pbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'xtol,xtol) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c05pbfDefaultSolve (htPage,ifail,xtol) == - n := '9 - page := htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: ") - (text . "\newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (42 "3*X[1] - 2*X[1]**2 - 2*X[2] + 1" n1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (42 "-X[1] + 3*X[2] - 2*X[2]**2 - 2*X[3] + 1" n2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (42 "-X[2] + 3*X[3] - 2*X[3]**2 - 2*X[4] + 1" n3 EM)) - (text . "\newline {\em Function 4:} \space{1}") - (bcStrings (42 "-X[3] + 3*X[4] - 2*X[4]**2 - 2*X[5] + 1" n4 EM)) - (text . "\newline {\em Function 5:} \space{1}") - (bcStrings (42 "-X[4] + 3*X[5] - 2*X[5]**2 - 2*X[6] + 1" n5 EM)) - (text . "\newline {\em Function 6:} \space{1}") - (bcStrings (42 "-X[5] + 3*X[6] - 2*X[6]**2 - 2*X[7] + 1" n6 EM)) - (text . "\newline {\em Function 7:} \space{1}") - (bcStrings (42 "-X[6] + 3*X[7] - 2*X[7]**2 - 2*X[8] + 1" n7 EM)) - (text . "\newline {\em Function 8:} \space{1}") - (bcStrings (42 "-X[7] + 3*X[8] - 2*X[8]**2 - 2*X[9] + 1" n8 EM)) - (text . "\newline {\em Function 9:} \space{1}") - (bcStrings (42 "-X[8] + 3*X[9] - 2*X[9]**2 + 1" n9 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector {\it x}: \newline ") - (bcStrings (4 "-1.0" x1 F)) - (bcStrings (4 "-1.0" x2 F)) - (bcStrings (4 "-1.0" x3 F)) - (bcStrings (4 "-1.0" x4 F)) - (bcStrings (4 "-1.0" x5 F)) - (bcStrings (4 "-1.0" x6 F)) - (bcStrings (4 "-1.0" x7 F)) - (bcStrings (4 "-1.0" x8 F)) - (bcStrings (4 "-1.0" x9 F))) - htMakeDoneButton('"Continue",'c05pbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'xtol,xtol) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c05pbfGen htPage == - n := htpProperty(htPage, 'n) - ifail := htpProperty(htPage,'ifail) - xtol := htpProperty(htPage,'xtol) - alist := htpInputAreaAlist htPage - y := alist - i := 1 - while y repeat - if i < (n+1) then - temp1 := STRCONC ((first y).1," ") - temp1list := [temp1,:temp1list] - else - temp2 := (first y).1 - temp2list := [temp2,:temp2list] - y := rest y - i := i + 1 - string1 := bcwords2liststring temp1list - string2 := bcwords2liststring temp2list - lwa := n*(n+13)/2 - prefix := STRCONC("c05pbf(",STRINGIMAGE n,",",STRINGIMAGE n) - middle := STRCONC(",",STRINGIMAGE lwa,",[",string1,"],") - middle := STRCONC (middle,xtol,",",STRINGIMAGE ifail,",") - linkGen STRCONC (prefix,middle,"(",string2,"::Vector Expression(Float))::ASP35(FCN))") - diff --git a/src/interp/nag-c05.boot.pamphlet b/src/interp/nag-c05.boot.pamphlet new file mode 100644 index 00000000..8b49400d --- /dev/null +++ b/src/interp/nag-c05.boot.pamphlet @@ -0,0 +1,424 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-c05.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +c05adf() == + htInitPage('"C05ADF - Zero of continuous function in given interval, Bus and Dekker algorithm",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXc05adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05adf| '|NagRootFindingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "C05ADF locates a zero of a continuous function in a ") + (text . "interval by a combination of the methods of linear ") + (text . "interpolation, extrapolation and bisection. ") + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the function whose zero is to be determined ") + (text . "as a function of X, {\it f}: ") + (text . "\newline\tab{2} ") + (bcStrings (55 "exp(-X)-X" expression EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Lower bound of the interval {\it a}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Upper bound {\it b}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0" b F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute tolerance {\it eps}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Value tolerance {\it eta}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-5" eps F)) + (text . "\tab{34} ") + (bcStrings (10 "0.0" eta F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c05adfGen) + htShowPage() + +c05adfGen htPage == + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + eps := htpLabelInputString(htPage,'eps) + eta := htpLabelInputString(htPage,'eta) + temp := READ_-FROM_-STRING(eps) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + temp1 := + temp > 0.0 => eps + '"1.0e-5" + expression := htpLabelInputString(htPage, 'expression) + prefix := STRCONC('"c05adf(",a,",",b,",",temp1,",",eta,",",STRINGIMAGE ifail) + linkGen STRCONC (prefix,",(",expression,")::ASP1(F))") + + +c05nbf() == + htInitPage('"C05NBF - Solution of system of nonlinear equations using function values only",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc05nbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05nbf| '|NagRootFindingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "C05NBF finds a solution of a system of nonlinear equations ") + (text . "by a modification of the Powell hybrid method. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of equations in the system {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Accuracy required {\it xtol}:") + (text . "\newline\tab{2} ") + -- should be sqrt(machine precision) + (bcStrings (10 "1.0e-9" xtol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c05nbfSolve) + htShowPage() + +c05nbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + xtol := htpLabelInputString(htPage,'xtol) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '9 => c05nbfDefaultSolve(htPage,ifail,xtol) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"X[",STRINGIMAGE i ,"] + 1") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x}: \newline ") + middle := cons('text,middle) + vecList := + [fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ['bcStrings,[4, -1.0, xnam, 'F]] + funcList := [:funcList,middle,:vecList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList] + page := htInitPage("C05NBF - Solution of system of nonlinear equations using function values only", htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'c05nbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'xtol,xtol) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c05nbfDefaultSolve (htPage,ifail,xtol) == + n := '9 + page := htInitPage("C05NBF - Solution of system of nonlinear equations using function values only", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]; ") + (text . " \newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (42 "3*X[1] - 2*X[1]**2 - 2*X[2] + 1" n1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (42 "-X[1] + 3*X[2] - 2*X[2]**2 - 2*X[3] + 1" n2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (42 "-X[2] + 3*X[3] - 2*X[3]**2 - 2*X[4] + 1" n3 EM)) + (text . "\newline {\em Function 4:} \space{1}") + (bcStrings (42 "-X[3] + 3*X[4] - 2*X[4]**2 - 2*X[5] + 1" n4 EM)) + (text . "\newline {\em Function 5:} \space{1}") + (bcStrings (42 "-X[4] + 3*X[5] - 2*X[5]**2 - 2*X[6] + 1" n5 EM)) + (text . "\newline {\em Function 6:} \space{1}") + (bcStrings (42 "-X[5] + 3*X[6] - 2*X[6]**2 - 2*X[7] + 1" n6 EM)) + (text . "\newline {\em Function 7:} \space{1}") + (bcStrings (42 "-X[6] + 3*X[7] - 2*X[7]**2 - 2*X[8] + 1" n7 EM)) + (text . "\newline {\em Function 8:} \space{1}") + (bcStrings (42 "-X[7] + 3*X[8] - 2*X[8]**2 - 2*X[9] + 1" n8 EM)) + (text . "\newline {\em Function 9:} \space{1}") + (bcStrings (42 "-X[8] + 3*X[9] - 2*X[9]**2 + 1" n9 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector {\it x}: \newline ") + (bcStrings (4 "-1.0" x1 F)) + (bcStrings (4 "-1.0" x2 F)) + (bcStrings (4 "-1.0" x3 F)) + (bcStrings (4 "-1.0" x4 F)) + (bcStrings (4 "-1.0" x5 F)) + (bcStrings (4 "-1.0" x6 F)) + (bcStrings (4 "-1.0" x7 F)) + (bcStrings (4 "-1.0" x8 F)) + (bcStrings (4 "-1.0" x9 F))) + htMakeDoneButton('"Continue",'c05nbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'xtol,xtol) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c05nbfGen htPage == + n := htpProperty(htPage, 'n) + ifail := htpProperty(htPage,'ifail) + xtol := htpProperty(htPage,'xtol) + alist := htpInputAreaAlist htPage + y := alist + i := 1 + while y repeat + if i < (n+1) then + temp1 := STRCONC ((first y).1," ") + temp1list := [temp1,:temp1list] + else + temp2 := (first y).1 + temp2list := [temp2,:temp2list] + y := rest y + i := i + 1 + string1 := bcwords2liststring temp1list + string2 := bcwords2liststring temp2list + lwa := n*(3*n+13)/2 + prefix := STRCONC ("c05nbf(",STRINGIMAGE n,",",STRINGIMAGE lwa,",[",string1,"],") + middle := STRCONC (xtol,",",STRINGIMAGE ifail,",") + linkGen STRCONC (prefix,middle,"(",string2,"::Vector Expression(Float))::ASP6(FCN))") + +c05pbf() == + htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc05pbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c05pbf| '|NagRootFindingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "C05PBF finds a solution of a system of nonlinear equations ") + (text . "by a modification of the Powell hybrid method. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of equations in the system {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Accuracy required {\it xtol}:") + (text . "\newline\tab{2} ") + -- should be sqrt(machine precision) + (bcStrings (10 "1.0e-9" xtol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c05pbfSolve) + htShowPage() + +c05pbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + xtol := htpLabelInputString(htPage,'xtol) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '9 => c05pbfDefaultSolve(htPage,ifail,xtol) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"X[",STRINGIMAGE i ,"] + 1") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x}: \newline ") + middle := cons('text,middle) + vecList := + [fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ['bcStrings,[4, -1.0, xnam, 'F]] + funcList := [:funcList,middle,:vecList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList] + page := htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'c05pbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'xtol,xtol) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c05pbfDefaultSolve (htPage,ifail,xtol) == + n := '9 + page := htInitPage('"C05PBF - Solution of system of nonlinear equations using first derivatives",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{fi} below in terms of X[1]...X[n]: ") + (text . "\newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (42 "3*X[1] - 2*X[1]**2 - 2*X[2] + 1" n1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (42 "-X[1] + 3*X[2] - 2*X[2]**2 - 2*X[3] + 1" n2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (42 "-X[2] + 3*X[3] - 2*X[3]**2 - 2*X[4] + 1" n3 EM)) + (text . "\newline {\em Function 4:} \space{1}") + (bcStrings (42 "-X[3] + 3*X[4] - 2*X[4]**2 - 2*X[5] + 1" n4 EM)) + (text . "\newline {\em Function 5:} \space{1}") + (bcStrings (42 "-X[4] + 3*X[5] - 2*X[5]**2 - 2*X[6] + 1" n5 EM)) + (text . "\newline {\em Function 6:} \space{1}") + (bcStrings (42 "-X[5] + 3*X[6] - 2*X[6]**2 - 2*X[7] + 1" n6 EM)) + (text . "\newline {\em Function 7:} \space{1}") + (bcStrings (42 "-X[6] + 3*X[7] - 2*X[7]**2 - 2*X[8] + 1" n7 EM)) + (text . "\newline {\em Function 8:} \space{1}") + (bcStrings (42 "-X[7] + 3*X[8] - 2*X[8]**2 - 2*X[9] + 1" n8 EM)) + (text . "\newline {\em Function 9:} \space{1}") + (bcStrings (42 "-X[8] + 3*X[9] - 2*X[9]**2 + 1" n9 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector {\it x}: \newline ") + (bcStrings (4 "-1.0" x1 F)) + (bcStrings (4 "-1.0" x2 F)) + (bcStrings (4 "-1.0" x3 F)) + (bcStrings (4 "-1.0" x4 F)) + (bcStrings (4 "-1.0" x5 F)) + (bcStrings (4 "-1.0" x6 F)) + (bcStrings (4 "-1.0" x7 F)) + (bcStrings (4 "-1.0" x8 F)) + (bcStrings (4 "-1.0" x9 F))) + htMakeDoneButton('"Continue",'c05pbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'xtol,xtol) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c05pbfGen htPage == + n := htpProperty(htPage, 'n) + ifail := htpProperty(htPage,'ifail) + xtol := htpProperty(htPage,'xtol) + alist := htpInputAreaAlist htPage + y := alist + i := 1 + while y repeat + if i < (n+1) then + temp1 := STRCONC ((first y).1," ") + temp1list := [temp1,:temp1list] + else + temp2 := (first y).1 + temp2list := [temp2,:temp2list] + y := rest y + i := i + 1 + string1 := bcwords2liststring temp1list + string2 := bcwords2liststring temp2list + lwa := n*(n+13)/2 + prefix := STRCONC("c05pbf(",STRINGIMAGE n,",",STRINGIMAGE n) + middle := STRCONC(",",STRINGIMAGE lwa,",[",string1,"],") + middle := STRCONC (middle,xtol,",",STRINGIMAGE ifail,",") + linkGen STRCONC (prefix,middle,"(",string2,"::Vector Expression(Float))::ASP35(FCN))") + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-c06.boot b/src/interp/nag-c06.boot deleted file mode 100644 index 1d7b98ba..00000000 --- a/src/interp/nag-c06.boot +++ /dev/null @@ -1,1832 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -c06eaf() == - htInitPage('"C06EAF - Single 1-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06eaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06eaf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Calculates the discrete Fourier transform of the sequence ") - (text . "of real data values \space{1} \inputbitmap{\htbmdir{}/xj.bitmap}, for ") - (text . "j = 0,1,...,n-1. ") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values: ") - (text . "\newline\tab{2} ") - (bcStrings (5 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06eafSolve) - htShowPage() - -c06eafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '7 => c06eafDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{15} ") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :labelList] - page := htInitPage("C06EAF - Single 1-D real discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the sequence to be transformed: " - htMakePage equationPart - htSay '"\blankline " - htSay '"Note : On exit, the transformed sequence is stored " - htSay '"in Hermitian form " - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06eafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06eafDefaultSolve (htPage, ifail) == - n := '7 - page := htInitPage('"C06EAF - Single 1-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the sequence to be transformed: ") - (text . "\newline \tab{15} ") - (bcStrings (10 "0.34907" r1 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.54890" r2 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.74776" r3 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.94459" r4 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.13850" r5 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.32850" r6 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.51370" r7 F)) - (text . "\blankline ") - (text . "Note : On exit, the transformed sequence is stored ") - (text . "in Hermitian form ") - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06eafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06eafGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06eaf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") - -c06ebf() == - htInitPage('"C06EBF - Single 1-D Hermitian discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06ebf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ebf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Calculates the discrete Fourier transform of a Hermitian ") - (text . "sequence of complex data values. ") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values: ") - (text . "\newline \tab{2}") - (bcStrings (5 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06ebfSolve) - htShowPage() - -c06ebfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '7 => c06ebfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{15} ") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :labelList] - page := htInitPage("C06EBF - Single 1-D real discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the sequence to be transformed, stored in Hermitian form: " - htMakePage equationPart - htSay '"\blankline " - htSay '"Note : On exit, the components of the discrete Fourier transform " - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06ebfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06ebfDefaultSolve (htPage, ifail) == - n := '7 - page := htInitPage('"C06EBF - Single 1-D Hermitian discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the sequence to be transformed, stored in Hermitian form: ") - (text . "\newline \tab{15} ") - (bcStrings (10 "0.34907" r1 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.54890" r2 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.74776" r3 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.94459" r4 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.13850" r5 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.32850" r6 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.51370" r7 F)) - (text . "\blankline ") - (text . "Note : On exit, the components of the discrete Fourier transform") - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06ebfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06ebfGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06ebf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") - - -c06ecf() == - htInitPage('"C06ECF - Single 1-D complex discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06ecf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ecf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Calculates the discrete Fourier transform of a complex sequence.") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values: ") - (text . "\newline\tab{2} ") - (bcStrings (5 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06ecfSolve) - htShowPage() - - -c06ecfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '7 => c06ecfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{32} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("C06ECF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Real parts of sequence: \tab{30} " - htSay '"\menuitemstyle{}\tab{32} Imaginary parts: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06ecfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c06ecfDefaultSolve (htPage, ifail) == - n := '7 - page := htInitPage('"C06ECF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Real parts of sequence: \tab{30} ") - (text . "\menuitemstyle{}\tab{32} Imaginary parts: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.34907" x1 F)) - (text . "\tab{32} ") - (bcStrings (10 "-0.37168" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.54890" x2 F)) - (text . "\tab{32} ") - (bcStrings (10 "-0.35669" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.74776" x3 F)) - (text . "\tab{32} ") - (bcStrings (10 "-0.31175" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.94459" x4 F)) - (text . "\tab{32} ") - (bcStrings (10 "-0.23702" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.13850" x5 F)) - (text . "\tab{32} ") - (bcStrings (10 "-0.13274" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.32850" x6 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.00074" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.51370" x7 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.16298" y7 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'c06ecfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06ecfGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - linkGen STRCONC ('"c06ecf(",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],", STRINGIMAGE ifail,")") - - -c06ekf() == - htInitPage('"C06EKF - Circular convolution or correlation of two real vectors",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06ekf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ekf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Calculates the circular convolution or correlation of two real ") - (text . "vectors of period {\em n} ") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values: ") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Choose the computation to be performed:") - (radioButtons job - ("" " Convolution" conv) - ("" " Correlation" corr)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06ekfSolve) - htShowPage() - - -c06ekfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - type := htpButtonValue(htPage,'job) - job := - type = 'conv => '1 - '2 - n = '9 => c06ekfDefaultSolve(htPage,job,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{34} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("C06EKF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Elements of period of vector {\em x}: " - htSay '"\tab{31} " - htSay '"\menuitemstyle{}\tab{34} Elements of period of vector {\em y}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06ekfGen) - htpSetProperty(page,'job,job) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c06ekfDefaultSolve (htPage, job, ifail) == - n := '9 - page := htInitPage('"C06EKF - Circular convolution or correlation of two real vectors ",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Elements of period of vector {\em x}: \tab{32} ") - (text . "\menuitemstyle{}\tab{34} Elements of period of vector {\em y}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "1.00" x1 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.50" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x2 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.50" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x3 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.50" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x4 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.50" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x5 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.00" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x6 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.00" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x7 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.00" y7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x8 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.00" y8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x9 F)) - (text . "\tab{34} ") - (bcStrings (10 "0.00" y9 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'c06ekfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'job,job) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06ekfGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - job := htpProperty(htPage,'job) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - linkGen STRCONC ('"c06ekf(",STRINGIMAGE job,",",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],", STRINGIMAGE ifail,")") - -c06fpf() == - htInitPage('"C06FPF - Multiple 1-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06fpf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fpf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the discrete Fourier transforms of {\it m} real ") - (text . "sequences, each containing {\it n} data values.") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of sequences to be transformed {\it m}: ") - (text . "\newline \tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 6 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Type of call:") - (radioButtons init - ("" " Initial" i) - ("" " Subsequent" s) - ("" " Restart" r)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06fpfSolve) - htShowPage() - -c06fpfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - call := htpButtonValue(htPage,'init) - init := - call = 'i => '"i" - call = 's => '"s" - '"r" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and m = '3) => c06fpfDefaultSolve(htPage,init,ifail) - matList := - "append"/[f(i,m) for i in 1..n] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - xnam := INTERN STRCONC ('"r",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, xnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - trigList := - "append"/[h(k) for k in 1..(2*n)] where h(k) == - prefix := ('"\newline \tab{2} ") - trignam := INTERN STRCONC ('"t",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Trigonometric coefficients ") - prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - trigList := [['text,:prefix],:trigList] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :matList,:trigList] - page := htInitPage("C06FPF - Multiple 1-D real discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter each sequence to be transformed, {\it x}. " - htSay '"(Each column to contain a sequence.) " - htMakePage equationPart - htMakeDoneButton('"Continue",'c06fpfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fpfDefaultSolve (htPage, init,ifail) == - n := '6 - m := '3 - page := htInitPage('"C06FPF - Multiple 1-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter each sequence to be transformed, {\it x}. ") - (text . "(Each column to contain a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.3854" x11 F)) - (bcStrings (6 "0.5417" x21 F)) - (bcStrings (6 "0.9172" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6772" x12 F)) - (bcStrings (6 "0.2983" x22 F)) - (bcStrings (6 "0.0644" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1138" x13 F)) - (bcStrings (6 "0.1181" x23 F)) - (bcStrings (6 "0.6037" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6751" x14 F)) - (bcStrings (6 "0.7255" x24 F)) - (bcStrings (6 "0.6430" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6362" x15 F)) - (bcStrings (6 "0.8638" x25 F)) - (bcStrings (6 "0.0428" x35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1424" x16 F)) - (bcStrings (6 "0.8723" x26 F)) - (bcStrings (6 "0.4815" x36 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Trignometric coefficients (not required if initial call) ") - (text . "{\it TRIG}: \newline \tab{2} ") - (bcStrings (6 "0.0" t1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t6 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t7 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t8 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t9 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t10 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t11 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t12 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06fpfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fpfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - init := htpProperty(htPage,'init) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(2*n) repeat - left := STRCONC((first y).1," ") - y := rest y - triglist := [left,:triglist] - trigstring := bcwords2liststring triglist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - xlist := [left,:xlist] - xstring := bcwords2liststring xlist - prefix := STRCONC ('"c06fpf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") - prefix := STRCONC(prefix,init,"_",[",xstring,"],[",trigstring,"],") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - - -c06fqf() == - htInitPage('"C06FQF - Multiple 1-D Hermitian discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06fqf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fqf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the discrete Fourier transforms of {\it m} real ") - (text . "sequences, each containing {\it n} data values.") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of sequences to be transformed {\it m}: ") - (text . "\newline \tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 6 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Type of call:") - (radioButtons init - ("" " Initial" i) - ("" " Subsequent" s) - ("" " Restart" r)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06fqfSolve) - htShowPage() - -c06fqfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - call := htpButtonValue(htPage,'init) - init := - call = 'i => '"i" - call = 's => '"s" - '"r" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and m = '3) => c06fqfDefaultSolve(htPage,init,ifail) - matList := - "append"/[f(i,m) for i in 1..n] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - xnam := INTERN STRCONC ('"r",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, xnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - trigList := - "append"/[h(k) for k in 1..(2*n)] where h(k) == - prefix := ("\newline \tab{2} ") - trignam := INTERN STRCONC ('"t",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") - prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - trigList := [['text,:prefix],:trigList] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :matList,:trigList] - page := htInitPage("C06FQF - Multiple 1-D Hermitian discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter each sequence to be transformed, {\it x}. " - htSay '"(Each column to contain a sequence.) " - htMakePage equationPart - htMakeDoneButton('"Continue",'c06fqfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fqfDefaultSolve (htPage, init,ifail) == - n := '6 - m := '3 - page := htInitPage('"C06FQF - Multiple 1-D Hermitian discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter each sequence to be transformed, {\it x}. ") - (text . "(Each column to contain a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.3854" x11 F)) - (bcStrings (6 "0.5417" x21 F)) - (bcStrings (6 "0.9172" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6772" x12 F)) - (bcStrings (6 "0.2983" x22 F)) - (bcStrings (6 "0.0644" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1138" x13 F)) - (bcStrings (6 "0.1181" x23 F)) - (bcStrings (6 "0.6037" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6751" x14 F)) - (bcStrings (6 "0.7255" x24 F)) - (bcStrings (6 "0.6430" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6362" x15 F)) - (bcStrings (6 "0.8638" x25 F)) - (bcStrings (6 "0.0428" x35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1424" x16 F)) - (bcStrings (6 "0.8723" x26 F)) - (bcStrings (6 "0.4815" x36 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Trignometric coefficients (not required if initial call) ") - (text . "{\it TRIG}: \newline \tab{2} ") - (bcStrings (6 "0.0" t1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t6 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t7 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t8 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t9 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t10 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t11 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t12 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06fqfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fqfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - init := htpProperty(htPage,'init) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(2*n) repeat - left := STRCONC((first y).1," ") - y := rest y - triglist := [left,:triglist] - trigstring := bcwords2liststring triglist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - xlist := [left,:xlist] - xstring := bcwords2liststring xlist - prefix := STRCONC ('"c06fqf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") - prefix := STRCONC(prefix,init,"_",[",xstring,"],[",trigstring,"],") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - - -c06frf() == - htInitPage('"C06FRF - Multiple 1-D complex discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06frf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06frf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the discrete Fourier transforms of {\it m} complex ") - (text . "sequences, each containing {\it n} data values.") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of sequences to be transformed {\it m}: ") - (text . "\newline \tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 6 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Type of call:") - (radioButtons init - ("" " Initial" i) - ("" " Subsequent" s) - ("" " Restart" r)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06frfSolve) - htShowPage() - -c06frfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - call := htpButtonValue(htPage,'init) - init := - call = 'i => '"i" - call = 's => '"s" - '"r" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and m = '3) => c06frfDefaultSolve(htPage,init,ifail) - xList := - "append"/[fx(i,m) for i in 1..n] where fx(i,n) == - labelList := - "append"/[gx(i,j) for j in 1..n] where gx(i,j) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, xnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - yList := - "append"/[fy(i,m) for i in 1..n] where fy(i,n) == - labelList := - "append"/[gy(i,j) for j in 1..n] where gy(i,j) == - ynam := INTERN STRCONC ('"y",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, ynam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter the imaginary parts ") - prefix := STRCONC(prefix,"of each sequence to be transformed, {\it y}. ") - prefix := STRCONC(prefix,"(Each column to contain the imaginary parts ") - prefix := STRCONC(prefix,"of a sequence.) \newline \tab{2} ") - yList := [['text,:prefix],:yList] - trigList := - "append"/[h(k) for k in 1..(2*n)] where h(k) == - prefix := ("\newline \tab{2} ") - trignam := INTERN STRCONC ('"t",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") - prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - trigList := [['text,:prefix],:trigList] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :xList,:yList,:trigList] - page := htInitPage("C06FRF - Multiple 1-D real discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the real parts of each sequence to be transformed, {\it x}. " - htSay '"(Each column to contain the real parts of a sequence.) " - htMakePage equationPart - htMakeDoneButton('"Continue",'c06frfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06frfDefaultSolve (htPage, init,ifail) == - n := '6 - m := '3 - page := htInitPage('"C06FRF - Multiple 1-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the real parts of each sequence to be transformed, ") - (text . "{\it x}. (Each column to contain the real parts of a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.3854" x11 F)) - (bcStrings (6 "0.9172" x21 F)) - (bcStrings (6 "0.1156" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6772" x12 F)) - (bcStrings (6 "0.0644" x22 F)) - (bcStrings (6 "0.0685" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1138" x13 F)) - (bcStrings (6 "0.6037" x23 F)) - (bcStrings (6 "0.2060" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6751" x14 F)) - (bcStrings (6 "0.6430" x24 F)) - (bcStrings (6 "0.8630" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6362" x15 F)) - (bcStrings (6 "0.0428" x25 F)) - (bcStrings (6 "0.6967" x35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1424" x16 F)) - (bcStrings (6 "0.4815" x26 F)) - (bcStrings (6 "0.2792" x36 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter the imaginary parts of each ") - (text . "sequence to be transformed, {\it y}. ") - (text . "(Each column to contain the imaginary parts of a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5417" y11 F)) - (bcStrings (6 "0.9089" y21 F)) - (bcStrings (6 "0.6214" y31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.2983" y12 F)) - (bcStrings (6 "0.3118" y22 F)) - (bcStrings (6 "0.8681" y32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1181" y13 F)) - (bcStrings (6 "0.3465" y23 F)) - (bcStrings (6 "0.7060" y33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.7255" y14 F)) - (bcStrings (6 "0.6198" y24 F)) - (bcStrings (6 "0.8652" y34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.8638" y15 F)) - (bcStrings (6 "0.2668" y25 F)) - (bcStrings (6 "0.9190" y35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.8723" y16 F)) - (bcStrings (6 "0.1614" y26 F)) - (bcStrings (6 "0.3355" y36 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Trignometric coefficients (not required if initial call) ") - (text . "{\it TRIG}: \newline \tab{2} ") - (bcStrings (6 "0.0" t1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t6 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t7 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t8 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t9 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t10 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t11 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" t12 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06frfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06frfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - init := htpProperty(htPage,'init) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(2*n) repeat - left := STRCONC((first y).1," ") - y := rest y - triglist := [left,:triglist] - trigstring := bcwords2liststring triglist - for i in 1..(m*n) repeat - left := STRCONC((first y).1," ") - y := rest y - ylist := [left,:ylist] - ystring := bcwords2liststring ylist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - xlist := [left,:xlist] - xstring := bcwords2liststring xlist - prefix := STRCONC ('"c06frf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") - prefix := STRCONC(prefix,init,"_",[",xstring,"],[",ystring,"],[") - linkGen STRCONC(prefix,trigstring,"],",STRINGIMAGE ifail,")") - - -c06fuf() == - htInitPage('"C06FUF - 2-D complex discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06fuf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fuf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the two-dimensional discrete Fourier transform of ") - (text . "a bivaraite sequence of complex data values; likely to be ") - (text . "efficient on vector processors. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of {\it m} of rows of X and Y; ") - (text . "\htbitmap{great=} 1 \newline \tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of {\it n} of columns of X and Y; ") - (text . "\htbitmap{great=} 1 \newline \tab{2} ") - (bcStrings (5 5 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Type of call:") - (radioButtons init - ("" " Initial" i) - ("" " Subsequent" s) - ("" " Restart" r)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06fufSolve) - htShowPage() - -c06fufSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - call := htpButtonValue(htPage,'init) - init := - call = 'i => '"i" - call = 's => '"s" - '"r" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '5 and m = '3) => c06fufDefaultSolve(htPage,init,ifail) - xList := - "append"/[fx(i,m) for i in 1..n] where fx(i,n) == - labelList := - "append"/[gx(i,j) for j in 1..n] where gx(i,j) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, xnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - yList := - "append"/[fy(i,m) for i in 1..n] where fy(i,n) == - labelList := - "append"/[gy(i,j) for j in 1..n] where gy(i,j) == - ynam := INTERN STRCONC ('"y",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, 0.0, ynam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter the imaginary parts ") - prefix := STRCONC(prefix,"of each sequence to be transformed, {\it y}. ") - prefix := STRCONC(prefix,"(Each column to contain the imaginary parts ") - prefix := STRCONC(prefix,"of a sequence.) \newline \tab{2} ") - yList := [['text,:prefix],:yList] - trigmList := - "append"/[hm(k) for k in 1..(2*m)] where hm(k) == - prefix := ("\newline \tab{2} ") - trignam := INTERN STRCONC ('"tm",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") - prefix := STRCONC(prefix,"(not required if initial call) {\it TRIGM}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - trigmList := [['text,:prefix],:trigmList] - trignList := - "append"/[hn(k) for k in 1..(2*n)] where hn(k) == - prefix := ("\newline \tab{2} ") - trignam := INTERN STRCONC ('"tn",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it TRIGN}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - trignList := [['text,:prefix],:trignList] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :xList,:yList,:trigmList,:trignList] - page := htInitPage("C06FUF - 2-D complex discrete Fourier transform ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the real part of each sequence to be transformed, {\it x}. " - htSay '"(Each column to contain the real parts of a sequence.) " - htMakePage equationPart - htMakeDoneButton('"Continue",'c06fufGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fufDefaultSolve (htPage, init,ifail) == - n := '5 - m := '3 - page := htInitPage('"C06FUF - 2-D real discrete Fourier transform ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the real parts of each sequence to be transformed, ") - (text . "{\it x}. (Each column to contain the real parts of a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.000" x11 F)) - (bcStrings (6 "0.994" x21 F)) - (bcStrings (6 "0.903" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.999" x12 F)) - (bcStrings (6 "0.989" x22 F)) - (bcStrings (6 "0.885" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.987" x13 F)) - (bcStrings (6 "0.963" x23 F)) - (bcStrings (6 "0.823" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.936" x14 F)) - (bcStrings (6 "0.891" x24 F)) - (bcStrings (6 "0.694" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.802" x15 F)) - (bcStrings (6 "0.731" x25 F)) - (bcStrings (6 "0.467" x35 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter the imaginary parts of each ") - (text . "sequence to be transformed, {\it y}. (Each column to contain ") - (text . "the imaginary parts of a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.000" y11 F)) - (bcStrings (6 "-0.111" y21 F)) - (bcStrings (6 "-0.430" y31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-0.040" y12 F)) - (bcStrings (6 "-0.151" y22 F)) - (bcStrings (6 "-0.466" y32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-0.159" y13 F)) - (bcStrings (6 "-0.268" y23 F)) - (bcStrings (6 "-0.568" y33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-0.352" y14 F)) - (bcStrings (6 "-0.454" y24 F)) - (bcStrings (6 "-0.720" y34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-0.597" y15 F)) - (bcStrings (6 "-0.682" y25 F)) - (bcStrings (6 "-0.884" y35 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Trignometric coefficients (not required if initial call) ") - (text . "{\it TRIGM}: \newline \tab{2} ") - (bcStrings (6 "0.0" tm1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tm2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tm3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tm4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tm5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tm6 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "{\it TRIGN}: \newline \tab{2} ") - (bcStrings (6 "0.0" tn1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn6 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn7 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn8 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn9 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" tn10 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06fufGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'init,init) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06fufGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - init := htpProperty(htPage,'init) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(2*n) repeat - left := STRCONC((first y).1," ") - y := rest y - trignlist := [left,:trignlist] - trignstring := bcwords2liststring trignlist - for i in 1..(2*m) repeat - left := STRCONC((first y).1," ") - y := rest y - trigmlist := [left,:trigmlist] - trigmstring := bcwords2liststring trigmlist - for i in 1..(m*n) repeat - left := STRCONC((first y).1," ") - y := rest y - ylist := [left,:ylist] - ystring := bcwords2liststring ylist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - xlist := [left,:xlist] - xstring := bcwords2liststring xlist - prefix := STRCONC ('"c06fuf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") - prefix := STRCONC(prefix,init,"_",[",xstring,"],[",ystring,"],[",trigmstring) - linkGen STRCONC(prefix,"],[",trignstring,"],",STRINGIMAGE ifail,")") - - - -c06gbf() == - htInitPage('"C06GBF - Complex conjugate of a Hermitian sequence ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06gbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gbf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Forms the complex conjugate of a Hermitian sequence of {\it n} data values") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values {\it n} ") - (text . "\space{1} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "\newline\tab{2} ") - (bcStrings (5 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06gbfSolve) - htShowPage() - -c06gbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '7 => c06gbfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{15} ") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :labelList] - page := htInitPage("C06GBF - Complex conjugate of a Hermitian sequence ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the Hermitian sequence to be transformed stored in Hermitian form: " - htMakePage equationPart - htSay '"\blankline " - htSay '"Note : On exit, the imaginary values are negated " - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06gbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gbfDefaultSolve (htPage, ifail) == - n := '7 - page := htInitPage('"C06GBF - Complex conjugate of a Hermitian sequence ", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the Hermitian sequence to be transformed ") - (text . "stored in Hermitian form: ") - (text . "\newline \tab{15} ") - (bcStrings (10 "0.34907" r1 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.54890" r2 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.74776" r3 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.94459" r4 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.13850" r5 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.32850" r6 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.51370" r7 F)) - (text . "\blankline ") - (text . "Note : On exit, the imaginary values are negated ") - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06gbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gbfGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06gbf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") - - -c06gcf() == - htInitPage('"C06GCF - Complex conjugate of complex sequence ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06gcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gcf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Forms the complex conjugate of a sequence of {\it n} data values") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data values {\it n} ") - (text . "\space{1} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "\newline\tab{2} ") - (bcStrings (5 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06gcfSolve) - htShowPage() - -c06gcfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '7 => c06gcfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{15} ") - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain F (Float))), - :labelList] - page := htInitPage("C06GCF - Complex conjugate of a Hermitian sequence ", htpPropertyList htPage) - htSay '"\menuitemstyle{} \tab{2} " - htSay '"Enter the imaginary parts of the sequence: " - htMakePage equationPart - htSay '"\blankline " - htSay '"Note : On exit, these values are negated " - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06gcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gcfDefaultSolve (htPage, ifail) == - n := '7 - page := htInitPage('"C06GCF - Complex conjugate of complex sequence ", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the imaginary parts of the sequence: ") - (text . "\newline \tab{15} ") - (bcStrings (10 "-0.37168" r1 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "-0.35669" r2 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "-0.31175" r3 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "-0.23702" r4 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.00074" r5 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.16298" r6 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "1.51370" r7 F)) - (text . "\blankline ") - (text . "Note : On exit, these values are negated ") - (text . "\blankline ")) - htMakeDoneButton('"Continue",'c06gcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gcfGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - left := STRCONC((first y).1," ") - y := rest y - reallist := [left,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06gcf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") - -c06gqf() == - htInitPage('"C06GQF - Complex conjugate of multiple Hermitian sequences ",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06gqf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gqf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Forms the complex conjugates of {\it m} Hermitian sequences, ") - (text . "each containing {\it n} data values. ") - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "of sequences to be tranformed: ") - (text . "\newline\tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number {\it n} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "of data values in each sequence: ") - (text . "\newline\tab{2} ") - (bcStrings (5 6 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06gqfSolve) - htShowPage() - - -c06gqfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '3 and n = '6) => c06gqfDefaultSolve(htPage,ifail) - newList:= - "append"/[g(i,m) for i in 1..n] where g(i,n) == - labelList := - "append"/[f(i,j) for j in 1..n] where f(i,j) == - rnam := INTERN STRCONC ('"r",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0.0, rnam, 'P]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :newList] - page := htInitPage("C06GQF - Complex conjugate of multiple Hermitian sequences ",htpPropertyList htPage) - htSay '"\newline " - htSay '"\menuitemstyle{}\tab{2} Please enter each sequence to be " - htSay '"transformed in Hermitian format. (Each column to contain " - htSay '"a sequence.) " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06gqfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c06gqfDefaultSolve (htPage, ifail) == - m := '3 - n := '6 - page := htInitPage('"C06GQF - Complex conjugate of multiple Hermitian sequences ",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Please enter each sequence to be ") - (text . "transformed in Hermitian format. ") - (text . "(Each column to contain a sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.3854" x11 F)) - (bcStrings (6 "0.5417" x21 F)) - (bcStrings (6 "0.9172" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6772" x12 F)) - (bcStrings (6 "0.2983" x22 F)) - (bcStrings (6 "0.0644" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1138" x13 F)) - (bcStrings (6 "0.1181" x23 F)) - (bcStrings (6 "0.6037" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6751" x14 F)) - (bcStrings (6 "0.7255" x24 F)) - (bcStrings (6 "0.6430" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6362" x15 F)) - (bcStrings (6 "0.8638" x25 F)) - (bcStrings (6 "0.0428" x35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1424" x16 F)) - (bcStrings (6 "0.8723" y26 F)) - (bcStrings (6 "0.4815" y36 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'c06gqfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gqfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - reallist := [right,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06gqf(",STRINGIMAGE m,",",STRINGIMAGE n,",[",realstring,"],", STRINGIMAGE ifail,")") - - - -c06gsf() == - htInitPage('"C06GSF - Convert Hermitian sequences to general complex sequences", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXc06gsf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gsf| '|NagSeriesSummationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Takes {\it m} Hermitian sequences, each containing {\it n} data values, ") - (text . "and forms the real and imaginary parts of the {\it m} ") - (text . "corresponding complex sequences. \newline ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "of sequences to be transformed: ") - (text . "\newline\tab{2} ") - (bcStrings (5 3 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number {\it n} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") - (text . "of data values in each sequence: ") - (text . "\newline\tab{2} ") - (bcStrings (5 6 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'c06gsfSolve) - htShowPage() - - -c06gsfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '3 and n = '6) => c06gsfDefaultSolve(htPage,ifail) - newList:= - "append"/[g(i,m) for i in 1..n] where g(i,n) == - labelList := - "append"/[f(i,j) for j in 1..n] where f(i,j) == - rnam := INTERN STRCONC ('"r",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0.0, rnam, 'P]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :newList] - page := htInitPage("C06GSF - Convert Hermitian sequences to general complex sequences ",htpPropertyList htPage) - htSay '"\newline " - htSay '"\menuitemstyle{}\tab{2} Please enter each sequence to be " - htSay '"transformed in Hermitian format. (Each column to contain a " - htSay '"sequence.) " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'c06gsfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -c06gsfDefaultSolve (htPage, ifail) == - m := '3 - n := '6 - page := htInitPage('"C06GSF - Convert Hermitian sequences to general complex sequences ",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Please enter each sequence to be ") - (text . "transformed in Hermitian format. (Each column to contain a ") - (text . "sequence.) ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.3854" x11 F)) - (bcStrings (6 "0.5417" x21 F)) - (bcStrings (6 "0.9172" x31 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6772" x12 F)) - (bcStrings (6 "0.2983" x22 F)) - (bcStrings (6 "0.0644" x32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1138" x13 F)) - (bcStrings (6 "0.1181" x23 F)) - (bcStrings (6 "0.6037" x33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6751" x14 F)) - (bcStrings (6 "0.7255" x24 F)) - (bcStrings (6 "0.6430" x34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6362" x15 F)) - (bcStrings (6 "0.8638" x25 F)) - (bcStrings (6 "0.0428" x35 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1424" x16 F)) - (bcStrings (6 "0.8723" y26 F)) - (bcStrings (6 "0.4815" y36 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'c06gsfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -c06gsfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - reallist := [right,:reallist] - realstring := bcwords2liststring reallist - linkGen STRCONC ('"c06gsf(",STRINGIMAGE m,",",STRINGIMAGE n,",[",realstring,"],", STRINGIMAGE ifail,")") - - diff --git a/src/interp/nag-c06.boot.pamphlet b/src/interp/nag-c06.boot.pamphlet new file mode 100644 index 00000000..6bf1b75b --- /dev/null +++ b/src/interp/nag-c06.boot.pamphlet @@ -0,0 +1,1854 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-c06.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +c06eaf() == + htInitPage('"C06EAF - Single 1-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06eaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06eaf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Calculates the discrete Fourier transform of the sequence ") + (text . "of real data values \space{1} \inputbitmap{\htbmdir{}/xj.bitmap}, for ") + (text . "j = 0,1,...,n-1. ") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values: ") + (text . "\newline\tab{2} ") + (bcStrings (5 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06eafSolve) + htShowPage() + +c06eafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '7 => c06eafDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{15} ") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :labelList] + page := htInitPage("C06EAF - Single 1-D real discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the sequence to be transformed: " + htMakePage equationPart + htSay '"\blankline " + htSay '"Note : On exit, the transformed sequence is stored " + htSay '"in Hermitian form " + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06eafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06eafDefaultSolve (htPage, ifail) == + n := '7 + page := htInitPage('"C06EAF - Single 1-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the sequence to be transformed: ") + (text . "\newline \tab{15} ") + (bcStrings (10 "0.34907" r1 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.54890" r2 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.74776" r3 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.94459" r4 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.13850" r5 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.32850" r6 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.51370" r7 F)) + (text . "\blankline ") + (text . "Note : On exit, the transformed sequence is stored ") + (text . "in Hermitian form ") + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06eafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06eafGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06eaf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") + +c06ebf() == + htInitPage('"C06EBF - Single 1-D Hermitian discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06ebf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ebf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Calculates the discrete Fourier transform of a Hermitian ") + (text . "sequence of complex data values. ") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values: ") + (text . "\newline \tab{2}") + (bcStrings (5 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06ebfSolve) + htShowPage() + +c06ebfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '7 => c06ebfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{15} ") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :labelList] + page := htInitPage("C06EBF - Single 1-D real discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the sequence to be transformed, stored in Hermitian form: " + htMakePage equationPart + htSay '"\blankline " + htSay '"Note : On exit, the components of the discrete Fourier transform " + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06ebfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06ebfDefaultSolve (htPage, ifail) == + n := '7 + page := htInitPage('"C06EBF - Single 1-D Hermitian discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the sequence to be transformed, stored in Hermitian form: ") + (text . "\newline \tab{15} ") + (bcStrings (10 "0.34907" r1 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.54890" r2 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.74776" r3 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.94459" r4 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.13850" r5 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.32850" r6 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.51370" r7 F)) + (text . "\blankline ") + (text . "Note : On exit, the components of the discrete Fourier transform") + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06ebfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06ebfGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06ebf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") + + +c06ecf() == + htInitPage('"C06ECF - Single 1-D complex discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06ecf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ecf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Calculates the discrete Fourier transform of a complex sequence.") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values: ") + (text . "\newline\tab{2} ") + (bcStrings (5 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06ecfSolve) + htShowPage() + + +c06ecfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '7 => c06ecfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{32} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("C06ECF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Real parts of sequence: \tab{30} " + htSay '"\menuitemstyle{}\tab{32} Imaginary parts: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06ecfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c06ecfDefaultSolve (htPage, ifail) == + n := '7 + page := htInitPage('"C06ECF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Real parts of sequence: \tab{30} ") + (text . "\menuitemstyle{}\tab{32} Imaginary parts: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.34907" x1 F)) + (text . "\tab{32} ") + (bcStrings (10 "-0.37168" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.54890" x2 F)) + (text . "\tab{32} ") + (bcStrings (10 "-0.35669" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.74776" x3 F)) + (text . "\tab{32} ") + (bcStrings (10 "-0.31175" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.94459" x4 F)) + (text . "\tab{32} ") + (bcStrings (10 "-0.23702" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.13850" x5 F)) + (text . "\tab{32} ") + (bcStrings (10 "-0.13274" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.32850" x6 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.00074" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.51370" x7 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.16298" y7 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'c06ecfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06ecfGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + linkGen STRCONC ('"c06ecf(",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],", STRINGIMAGE ifail,")") + + +c06ekf() == + htInitPage('"C06EKF - Circular convolution or correlation of two real vectors",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06ekf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06ekf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Calculates the circular convolution or correlation of two real ") + (text . "vectors of period {\em n} ") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values: ") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Choose the computation to be performed:") + (radioButtons job + ("" " Convolution" conv) + ("" " Correlation" corr)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06ekfSolve) + htShowPage() + + +c06ekfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + type := htpButtonValue(htPage,'job) + job := + type = 'conv => '1 + '2 + n = '9 => c06ekfDefaultSolve(htPage,job,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{34} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("C06EKF - Single 1-D complex discrete Fourier transform ",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Elements of period of vector {\em x}: " + htSay '"\tab{31} " + htSay '"\menuitemstyle{}\tab{34} Elements of period of vector {\em y}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06ekfGen) + htpSetProperty(page,'job,job) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c06ekfDefaultSolve (htPage, job, ifail) == + n := '9 + page := htInitPage('"C06EKF - Circular convolution or correlation of two real vectors ",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Elements of period of vector {\em x}: \tab{32} ") + (text . "\menuitemstyle{}\tab{34} Elements of period of vector {\em y}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "1.00" x1 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.50" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x2 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.50" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x3 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.50" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x4 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.50" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x5 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.00" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x6 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.00" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x7 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.00" y7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x8 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.00" y8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x9 F)) + (text . "\tab{34} ") + (bcStrings (10 "0.00" y9 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'c06ekfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'job,job) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06ekfGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + job := htpProperty(htPage,'job) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + linkGen STRCONC ('"c06ekf(",STRINGIMAGE job,",",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],", STRINGIMAGE ifail,")") + +c06fpf() == + htInitPage('"C06FPF - Multiple 1-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06fpf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fpf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the discrete Fourier transforms of {\it m} real ") + (text . "sequences, each containing {\it n} data values.") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of sequences to be transformed {\it m}: ") + (text . "\newline \tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 6 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Type of call:") + (radioButtons init + ("" " Initial" i) + ("" " Subsequent" s) + ("" " Restart" r)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06fpfSolve) + htShowPage() + +c06fpfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + call := htpButtonValue(htPage,'init) + init := + call = 'i => '"i" + call = 's => '"s" + '"r" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and m = '3) => c06fpfDefaultSolve(htPage,init,ifail) + matList := + "append"/[f(i,m) for i in 1..n] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + xnam := INTERN STRCONC ('"r",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, xnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + trigList := + "append"/[h(k) for k in 1..(2*n)] where h(k) == + prefix := ('"\newline \tab{2} ") + trignam := INTERN STRCONC ('"t",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Trigonometric coefficients ") + prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + trigList := [['text,:prefix],:trigList] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :matList,:trigList] + page := htInitPage("C06FPF - Multiple 1-D real discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter each sequence to be transformed, {\it x}. " + htSay '"(Each column to contain a sequence.) " + htMakePage equationPart + htMakeDoneButton('"Continue",'c06fpfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fpfDefaultSolve (htPage, init,ifail) == + n := '6 + m := '3 + page := htInitPage('"C06FPF - Multiple 1-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter each sequence to be transformed, {\it x}. ") + (text . "(Each column to contain a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.3854" x11 F)) + (bcStrings (6 "0.5417" x21 F)) + (bcStrings (6 "0.9172" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6772" x12 F)) + (bcStrings (6 "0.2983" x22 F)) + (bcStrings (6 "0.0644" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1138" x13 F)) + (bcStrings (6 "0.1181" x23 F)) + (bcStrings (6 "0.6037" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6751" x14 F)) + (bcStrings (6 "0.7255" x24 F)) + (bcStrings (6 "0.6430" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6362" x15 F)) + (bcStrings (6 "0.8638" x25 F)) + (bcStrings (6 "0.0428" x35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1424" x16 F)) + (bcStrings (6 "0.8723" x26 F)) + (bcStrings (6 "0.4815" x36 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Trignometric coefficients (not required if initial call) ") + (text . "{\it TRIG}: \newline \tab{2} ") + (bcStrings (6 "0.0" t1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t6 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t7 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t8 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t9 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t10 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t11 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t12 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06fpfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fpfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + init := htpProperty(htPage,'init) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(2*n) repeat + left := STRCONC((first y).1," ") + y := rest y + triglist := [left,:triglist] + trigstring := bcwords2liststring triglist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + xlist := [left,:xlist] + xstring := bcwords2liststring xlist + prefix := STRCONC ('"c06fpf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") + prefix := STRCONC(prefix,init,"_",[",xstring,"],[",trigstring,"],") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + + +c06fqf() == + htInitPage('"C06FQF - Multiple 1-D Hermitian discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06fqf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fqf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the discrete Fourier transforms of {\it m} real ") + (text . "sequences, each containing {\it n} data values.") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of sequences to be transformed {\it m}: ") + (text . "\newline \tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 6 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Type of call:") + (radioButtons init + ("" " Initial" i) + ("" " Subsequent" s) + ("" " Restart" r)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06fqfSolve) + htShowPage() + +c06fqfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + call := htpButtonValue(htPage,'init) + init := + call = 'i => '"i" + call = 's => '"s" + '"r" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and m = '3) => c06fqfDefaultSolve(htPage,init,ifail) + matList := + "append"/[f(i,m) for i in 1..n] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + xnam := INTERN STRCONC ('"r",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, xnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + trigList := + "append"/[h(k) for k in 1..(2*n)] where h(k) == + prefix := ("\newline \tab{2} ") + trignam := INTERN STRCONC ('"t",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") + prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + trigList := [['text,:prefix],:trigList] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :matList,:trigList] + page := htInitPage("C06FQF - Multiple 1-D Hermitian discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter each sequence to be transformed, {\it x}. " + htSay '"(Each column to contain a sequence.) " + htMakePage equationPart + htMakeDoneButton('"Continue",'c06fqfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fqfDefaultSolve (htPage, init,ifail) == + n := '6 + m := '3 + page := htInitPage('"C06FQF - Multiple 1-D Hermitian discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter each sequence to be transformed, {\it x}. ") + (text . "(Each column to contain a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.3854" x11 F)) + (bcStrings (6 "0.5417" x21 F)) + (bcStrings (6 "0.9172" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6772" x12 F)) + (bcStrings (6 "0.2983" x22 F)) + (bcStrings (6 "0.0644" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1138" x13 F)) + (bcStrings (6 "0.1181" x23 F)) + (bcStrings (6 "0.6037" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6751" x14 F)) + (bcStrings (6 "0.7255" x24 F)) + (bcStrings (6 "0.6430" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6362" x15 F)) + (bcStrings (6 "0.8638" x25 F)) + (bcStrings (6 "0.0428" x35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1424" x16 F)) + (bcStrings (6 "0.8723" x26 F)) + (bcStrings (6 "0.4815" x36 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Trignometric coefficients (not required if initial call) ") + (text . "{\it TRIG}: \newline \tab{2} ") + (bcStrings (6 "0.0" t1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t6 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t7 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t8 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t9 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t10 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t11 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t12 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06fqfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fqfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + init := htpProperty(htPage,'init) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(2*n) repeat + left := STRCONC((first y).1," ") + y := rest y + triglist := [left,:triglist] + trigstring := bcwords2liststring triglist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + xlist := [left,:xlist] + xstring := bcwords2liststring xlist + prefix := STRCONC ('"c06fqf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") + prefix := STRCONC(prefix,init,"_",[",xstring,"],[",trigstring,"],") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + + +c06frf() == + htInitPage('"C06FRF - Multiple 1-D complex discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06frf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06frf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the discrete Fourier transforms of {\it m} complex ") + (text . "sequences, each containing {\it n} data values.") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of sequences to be transformed {\it m}: ") + (text . "\newline \tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 6 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Type of call:") + (radioButtons init + ("" " Initial" i) + ("" " Subsequent" s) + ("" " Restart" r)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06frfSolve) + htShowPage() + +c06frfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + call := htpButtonValue(htPage,'init) + init := + call = 'i => '"i" + call = 's => '"s" + '"r" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and m = '3) => c06frfDefaultSolve(htPage,init,ifail) + xList := + "append"/[fx(i,m) for i in 1..n] where fx(i,n) == + labelList := + "append"/[gx(i,j) for j in 1..n] where gx(i,j) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, xnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + yList := + "append"/[fy(i,m) for i in 1..n] where fy(i,n) == + labelList := + "append"/[gy(i,j) for j in 1..n] where gy(i,j) == + ynam := INTERN STRCONC ('"y",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, ynam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter the imaginary parts ") + prefix := STRCONC(prefix,"of each sequence to be transformed, {\it y}. ") + prefix := STRCONC(prefix,"(Each column to contain the imaginary parts ") + prefix := STRCONC(prefix,"of a sequence.) \newline \tab{2} ") + yList := [['text,:prefix],:yList] + trigList := + "append"/[h(k) for k in 1..(2*n)] where h(k) == + prefix := ("\newline \tab{2} ") + trignam := INTERN STRCONC ('"t",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") + prefix := STRCONC(prefix,"(not required if initial call) {\it TRIG}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + trigList := [['text,:prefix],:trigList] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :xList,:yList,:trigList] + page := htInitPage("C06FRF - Multiple 1-D real discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the real parts of each sequence to be transformed, {\it x}. " + htSay '"(Each column to contain the real parts of a sequence.) " + htMakePage equationPart + htMakeDoneButton('"Continue",'c06frfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06frfDefaultSolve (htPage, init,ifail) == + n := '6 + m := '3 + page := htInitPage('"C06FRF - Multiple 1-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the real parts of each sequence to be transformed, ") + (text . "{\it x}. (Each column to contain the real parts of a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.3854" x11 F)) + (bcStrings (6 "0.9172" x21 F)) + (bcStrings (6 "0.1156" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6772" x12 F)) + (bcStrings (6 "0.0644" x22 F)) + (bcStrings (6 "0.0685" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1138" x13 F)) + (bcStrings (6 "0.6037" x23 F)) + (bcStrings (6 "0.2060" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6751" x14 F)) + (bcStrings (6 "0.6430" x24 F)) + (bcStrings (6 "0.8630" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6362" x15 F)) + (bcStrings (6 "0.0428" x25 F)) + (bcStrings (6 "0.6967" x35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1424" x16 F)) + (bcStrings (6 "0.4815" x26 F)) + (bcStrings (6 "0.2792" x36 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter the imaginary parts of each ") + (text . "sequence to be transformed, {\it y}. ") + (text . "(Each column to contain the imaginary parts of a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5417" y11 F)) + (bcStrings (6 "0.9089" y21 F)) + (bcStrings (6 "0.6214" y31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.2983" y12 F)) + (bcStrings (6 "0.3118" y22 F)) + (bcStrings (6 "0.8681" y32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1181" y13 F)) + (bcStrings (6 "0.3465" y23 F)) + (bcStrings (6 "0.7060" y33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.7255" y14 F)) + (bcStrings (6 "0.6198" y24 F)) + (bcStrings (6 "0.8652" y34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.8638" y15 F)) + (bcStrings (6 "0.2668" y25 F)) + (bcStrings (6 "0.9190" y35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.8723" y16 F)) + (bcStrings (6 "0.1614" y26 F)) + (bcStrings (6 "0.3355" y36 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Trignometric coefficients (not required if initial call) ") + (text . "{\it TRIG}: \newline \tab{2} ") + (bcStrings (6 "0.0" t1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t6 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t7 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t8 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t9 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t10 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t11 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" t12 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06frfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06frfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + init := htpProperty(htPage,'init) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(2*n) repeat + left := STRCONC((first y).1," ") + y := rest y + triglist := [left,:triglist] + trigstring := bcwords2liststring triglist + for i in 1..(m*n) repeat + left := STRCONC((first y).1," ") + y := rest y + ylist := [left,:ylist] + ystring := bcwords2liststring ylist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + xlist := [left,:xlist] + xstring := bcwords2liststring xlist + prefix := STRCONC ('"c06frf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") + prefix := STRCONC(prefix,init,"_",[",xstring,"],[",ystring,"],[") + linkGen STRCONC(prefix,trigstring,"],",STRINGIMAGE ifail,")") + + +c06fuf() == + htInitPage('"C06FUF - 2-D complex discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06fuf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06fuf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the two-dimensional discrete Fourier transform of ") + (text . "a bivaraite sequence of complex data values; likely to be ") + (text . "efficient on vector processors. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of {\it m} of rows of X and Y; ") + (text . "\htbitmap{great=} 1 \newline \tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of {\it n} of columns of X and Y; ") + (text . "\htbitmap{great=} 1 \newline \tab{2} ") + (bcStrings (5 5 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Type of call:") + (radioButtons init + ("" " Initial" i) + ("" " Subsequent" s) + ("" " Restart" r)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06fufSolve) + htShowPage() + +c06fufSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + call := htpButtonValue(htPage,'init) + init := + call = 'i => '"i" + call = 's => '"s" + '"r" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '5 and m = '3) => c06fufDefaultSolve(htPage,init,ifail) + xList := + "append"/[fx(i,m) for i in 1..n] where fx(i,n) == + labelList := + "append"/[gx(i,j) for j in 1..n] where gx(i,j) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, xnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + yList := + "append"/[fy(i,m) for i in 1..n] where fy(i,n) == + labelList := + "append"/[gy(i,j) for j in 1..n] where gy(i,j) == + ynam := INTERN STRCONC ('"y",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, 0.0, ynam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter the imaginary parts ") + prefix := STRCONC(prefix,"of each sequence to be transformed, {\it y}. ") + prefix := STRCONC(prefix,"(Each column to contain the imaginary parts ") + prefix := STRCONC(prefix,"of a sequence.) \newline \tab{2} ") + yList := [['text,:prefix],:yList] + trigmList := + "append"/[hm(k) for k in 1..(2*m)] where hm(k) == + prefix := ("\newline \tab{2} ") + trignam := INTERN STRCONC ('"tm",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Trignometric coefficients ") + prefix := STRCONC(prefix,"(not required if initial call) {\it TRIGM}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + trigmList := [['text,:prefix],:trigmList] + trignList := + "append"/[hn(k) for k in 1..(2*n)] where hn(k) == + prefix := ("\newline \tab{2} ") + trignam := INTERN STRCONC ('"tn",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", trignam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it TRIGN}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + trignList := [['text,:prefix],:trignList] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :xList,:yList,:trigmList,:trignList] + page := htInitPage("C06FUF - 2-D complex discrete Fourier transform ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the real part of each sequence to be transformed, {\it x}. " + htSay '"(Each column to contain the real parts of a sequence.) " + htMakePage equationPart + htMakeDoneButton('"Continue",'c06fufGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fufDefaultSolve (htPage, init,ifail) == + n := '5 + m := '3 + page := htInitPage('"C06FUF - 2-D real discrete Fourier transform ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the real parts of each sequence to be transformed, ") + (text . "{\it x}. (Each column to contain the real parts of a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.000" x11 F)) + (bcStrings (6 "0.994" x21 F)) + (bcStrings (6 "0.903" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.999" x12 F)) + (bcStrings (6 "0.989" x22 F)) + (bcStrings (6 "0.885" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.987" x13 F)) + (bcStrings (6 "0.963" x23 F)) + (bcStrings (6 "0.823" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.936" x14 F)) + (bcStrings (6 "0.891" x24 F)) + (bcStrings (6 "0.694" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.802" x15 F)) + (bcStrings (6 "0.731" x25 F)) + (bcStrings (6 "0.467" x35 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter the imaginary parts of each ") + (text . "sequence to be transformed, {\it y}. (Each column to contain ") + (text . "the imaginary parts of a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.000" y11 F)) + (bcStrings (6 "-0.111" y21 F)) + (bcStrings (6 "-0.430" y31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-0.040" y12 F)) + (bcStrings (6 "-0.151" y22 F)) + (bcStrings (6 "-0.466" y32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-0.159" y13 F)) + (bcStrings (6 "-0.268" y23 F)) + (bcStrings (6 "-0.568" y33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-0.352" y14 F)) + (bcStrings (6 "-0.454" y24 F)) + (bcStrings (6 "-0.720" y34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-0.597" y15 F)) + (bcStrings (6 "-0.682" y25 F)) + (bcStrings (6 "-0.884" y35 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Trignometric coefficients (not required if initial call) ") + (text . "{\it TRIGM}: \newline \tab{2} ") + (bcStrings (6 "0.0" tm1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tm2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tm3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tm4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tm5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tm6 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "{\it TRIGN}: \newline \tab{2} ") + (bcStrings (6 "0.0" tn1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn6 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn7 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn8 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn9 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" tn10 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06fufGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'init,init) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06fufGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + init := htpProperty(htPage,'init) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(2*n) repeat + left := STRCONC((first y).1," ") + y := rest y + trignlist := [left,:trignlist] + trignstring := bcwords2liststring trignlist + for i in 1..(2*m) repeat + left := STRCONC((first y).1," ") + y := rest y + trigmlist := [left,:trigmlist] + trigmstring := bcwords2liststring trigmlist + for i in 1..(m*n) repeat + left := STRCONC((first y).1," ") + y := rest y + ylist := [left,:ylist] + ystring := bcwords2liststring ylist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + xlist := [left,:xlist] + xstring := bcwords2liststring xlist + prefix := STRCONC ('"c06fuf(",STRINGIMAGE m,", ",STRINGIMAGE n,", _"") + prefix := STRCONC(prefix,init,"_",[",xstring,"],[",ystring,"],[",trigmstring) + linkGen STRCONC(prefix,"],[",trignstring,"],",STRINGIMAGE ifail,")") + + + +c06gbf() == + htInitPage('"C06GBF - Complex conjugate of a Hermitian sequence ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06gbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gbf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Forms the complex conjugate of a Hermitian sequence of {\it n} data values") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values {\it n} ") + (text . "\space{1} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "\newline\tab{2} ") + (bcStrings (5 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06gbfSolve) + htShowPage() + +c06gbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '7 => c06gbfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{15} ") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :labelList] + page := htInitPage("C06GBF - Complex conjugate of a Hermitian sequence ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the Hermitian sequence to be transformed stored in Hermitian form: " + htMakePage equationPart + htSay '"\blankline " + htSay '"Note : On exit, the imaginary values are negated " + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06gbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gbfDefaultSolve (htPage, ifail) == + n := '7 + page := htInitPage('"C06GBF - Complex conjugate of a Hermitian sequence ", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the Hermitian sequence to be transformed ") + (text . "stored in Hermitian form: ") + (text . "\newline \tab{15} ") + (bcStrings (10 "0.34907" r1 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.54890" r2 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.74776" r3 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.94459" r4 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.13850" r5 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.32850" r6 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.51370" r7 F)) + (text . "\blankline ") + (text . "Note : On exit, the imaginary values are negated ") + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06gbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gbfGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06gbf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") + + +c06gcf() == + htInitPage('"C06GCF - Complex conjugate of complex sequence ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06gcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gcf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Forms the complex conjugate of a sequence of {\it n} data values") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data values {\it n} ") + (text . "\space{1} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "\newline\tab{2} ") + (bcStrings (5 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06gcfSolve) + htShowPage() + +c06gcfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '7 => c06gcfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{15} ") + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain F (Float))), + :labelList] + page := htInitPage("C06GCF - Complex conjugate of a Hermitian sequence ", htpPropertyList htPage) + htSay '"\menuitemstyle{} \tab{2} " + htSay '"Enter the imaginary parts of the sequence: " + htMakePage equationPart + htSay '"\blankline " + htSay '"Note : On exit, these values are negated " + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06gcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gcfDefaultSolve (htPage, ifail) == + n := '7 + page := htInitPage('"C06GCF - Complex conjugate of complex sequence ", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the imaginary parts of the sequence: ") + (text . "\newline \tab{15} ") + (bcStrings (10 "-0.37168" r1 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "-0.35669" r2 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "-0.31175" r3 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "-0.23702" r4 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.00074" r5 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.16298" r6 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "1.51370" r7 F)) + (text . "\blankline ") + (text . "Note : On exit, these values are negated ") + (text . "\blankline ")) + htMakeDoneButton('"Continue",'c06gcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gcfGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + left := STRCONC((first y).1," ") + y := rest y + reallist := [left,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06gcf(",STRINGIMAGE n,",[",realstring,"],",STRINGIMAGE ifail,")") + +c06gqf() == + htInitPage('"C06GQF - Complex conjugate of multiple Hermitian sequences ",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06gqf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gqf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Forms the complex conjugates of {\it m} Hermitian sequences, ") + (text . "each containing {\it n} data values. ") + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "of sequences to be tranformed: ") + (text . "\newline\tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number {\it n} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "of data values in each sequence: ") + (text . "\newline\tab{2} ") + (bcStrings (5 6 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06gqfSolve) + htShowPage() + + +c06gqfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '3 and n = '6) => c06gqfDefaultSolve(htPage,ifail) + newList:= + "append"/[g(i,m) for i in 1..n] where g(i,n) == + labelList := + "append"/[f(i,j) for j in 1..n] where f(i,j) == + rnam := INTERN STRCONC ('"r",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0.0, rnam, 'P]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :newList] + page := htInitPage("C06GQF - Complex conjugate of multiple Hermitian sequences ",htpPropertyList htPage) + htSay '"\newline " + htSay '"\menuitemstyle{}\tab{2} Please enter each sequence to be " + htSay '"transformed in Hermitian format. (Each column to contain " + htSay '"a sequence.) " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06gqfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c06gqfDefaultSolve (htPage, ifail) == + m := '3 + n := '6 + page := htInitPage('"C06GQF - Complex conjugate of multiple Hermitian sequences ",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Please enter each sequence to be ") + (text . "transformed in Hermitian format. ") + (text . "(Each column to contain a sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.3854" x11 F)) + (bcStrings (6 "0.5417" x21 F)) + (bcStrings (6 "0.9172" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6772" x12 F)) + (bcStrings (6 "0.2983" x22 F)) + (bcStrings (6 "0.0644" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1138" x13 F)) + (bcStrings (6 "0.1181" x23 F)) + (bcStrings (6 "0.6037" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6751" x14 F)) + (bcStrings (6 "0.7255" x24 F)) + (bcStrings (6 "0.6430" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6362" x15 F)) + (bcStrings (6 "0.8638" x25 F)) + (bcStrings (6 "0.0428" x35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1424" x16 F)) + (bcStrings (6 "0.8723" y26 F)) + (bcStrings (6 "0.4815" y36 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'c06gqfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gqfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + reallist := [right,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06gqf(",STRINGIMAGE m,",",STRINGIMAGE n,",[",realstring,"],", STRINGIMAGE ifail,")") + + + +c06gsf() == + htInitPage('"C06GSF - Convert Hermitian sequences to general complex sequences", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXc06gsf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|c06gsf| '|NagSeriesSummationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Takes {\it m} Hermitian sequences, each containing {\it n} data values, ") + (text . "and forms the real and imaginary parts of the {\it m} ") + (text . "corresponding complex sequences. \newline ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "of sequences to be transformed: ") + (text . "\newline\tab{2} ") + (bcStrings (5 3 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number {\it n} \inputbitmap{\htbmdir{}/great=.bitmap} 1 ") + (text . "of data values in each sequence: ") + (text . "\newline\tab{2} ") + (bcStrings (5 6 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'c06gsfSolve) + htShowPage() + + +c06gsfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '3 and n = '6) => c06gsfDefaultSolve(htPage,ifail) + newList:= + "append"/[g(i,m) for i in 1..n] where g(i,n) == + labelList := + "append"/[f(i,j) for j in 1..n] where f(i,j) == + rnam := INTERN STRCONC ('"r",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0.0, rnam, 'P]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :newList] + page := htInitPage("C06GSF - Convert Hermitian sequences to general complex sequences ",htpPropertyList htPage) + htSay '"\newline " + htSay '"\menuitemstyle{}\tab{2} Please enter each sequence to be " + htSay '"transformed in Hermitian format. (Each column to contain a " + htSay '"sequence.) " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'c06gsfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +c06gsfDefaultSolve (htPage, ifail) == + m := '3 + n := '6 + page := htInitPage('"C06GSF - Convert Hermitian sequences to general complex sequences ",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Please enter each sequence to be ") + (text . "transformed in Hermitian format. (Each column to contain a ") + (text . "sequence.) ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.3854" x11 F)) + (bcStrings (6 "0.5417" x21 F)) + (bcStrings (6 "0.9172" x31 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6772" x12 F)) + (bcStrings (6 "0.2983" x22 F)) + (bcStrings (6 "0.0644" x32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1138" x13 F)) + (bcStrings (6 "0.1181" x23 F)) + (bcStrings (6 "0.6037" x33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6751" x14 F)) + (bcStrings (6 "0.7255" x24 F)) + (bcStrings (6 "0.6430" x34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6362" x15 F)) + (bcStrings (6 "0.8638" x25 F)) + (bcStrings (6 "0.0428" x35 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1424" x16 F)) + (bcStrings (6 "0.8723" y26 F)) + (bcStrings (6 "0.4815" y36 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'c06gsfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +c06gsfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + reallist := [right,:reallist] + realstring := bcwords2liststring reallist + linkGen STRCONC ('"c06gsf(",STRINGIMAGE m,",",STRINGIMAGE n,",[",realstring,"],", STRINGIMAGE ifail,")") + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-d01.boot b/src/interp/nag-d01.boot deleted file mode 100644 index bb26e03c..00000000 --- a/src/interp/nag-d01.boot +++ /dev/null @@ -1,1337 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -d01ajf() == - htInitPage('"D01AJF - 1-D quadrature, adaptive, finite interval, allowing for badly-behaved integrands", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01ajf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01ajf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the integral ") - (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx ") - (text . "using an adaptive method. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} f to be integrated in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "X*sin(30*X)/(sqrt(1-(X/(2*\%pi))**2))" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (20 "\%pi*2" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01ajfGen) - htShowPage() - -d01ajfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/4 - prefix := STRCONC("d01ajf(",a," ,",b," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) - middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC("(",express,"::Expression Float) :: ASP1(F))") - linkGen STRCONC(prefix,middle,end) - -d01akf() == - htInitPage('"D01AKF - 1-D quadrature, adaptive, finite interval, method suitable for oscillating functions", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01akf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01akf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes \space{1} \inputbitmap{\htbmdir{}/integral.bitmap} ") - (text . "f(x) dx using an adaptive method, ") - (text . "especially suited to oscillating, non-singular integrands. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} f to be integrated in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "X*sin(30*X)*cos(X)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (20 "\%pi*2" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01akfGen) - htShowPage() - -d01akfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/4 - prefix := STRCONC("d01akf(",a," ,",b," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) - middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC("(",express,"::Expression Float) :: ASP1(F))") - linkGen STRCONC(prefix,middle,end) - -d01alf() == - htInitPage('"D01ALF - 1-D quadrature, adaptive, finite interval, allowing for singularities at user-specified break-points ", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01alf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01alf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the integral \space{1} ") - (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx; ") - (text . "the integrand may have local singular behaviour at a ") - (text . "finite number of points within [a,b]. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} f to be integrated in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "1/sqrt(abs(X-1/7))" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (20 "1.0" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Number of user supplied break-points: \tab{38}") - (bcStrings (10 "1" npts PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline User supplied break-points (separated by commas): ") - (text . "\newline \tab{2} ") - (bcStrings (40 "1/7" points EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01alfGen) - htShowPage() - -d01alfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - npts := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npts) - objValUnwrap htpLabelSpadValue(htPage, 'npts) - points := htpLabelInputString(htPage, 'points) - points := STRCONC ('"[[",points,"]]") - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/2 - prefix := STRCONC('"d01alf(",a," ,",b," ,",STRINGIMAGE npts,",",points,",") - prefix := STRCONC(prefix,epsabs," ,",epsrel," ,",STRINGIMAGE lw) - middle := STRCONC('" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC('"(",express,"::Expression Float) :: ASP1(F))") - linkGen STRCONC(prefix,middle,end) - -d01amf() == - htInitPage('"D01AMF 1-D quadrature, adaptive, infinite or semi-infinite interval",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01amf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01amf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Evaluates the integral \space{1} ") - (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx, ") - (text . "where (a,b) can be an infinite or semi-infinite interval.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} f to be integrated in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "1/((X+1)*sqrt(X))" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Bound} the finite limit of the integration range: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" a F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Choose the kind of integration range: ") - (radioButtons inf - (" 1" "\tab{2} Range is [Bound, +infinity] " plus) - ("-1" "\tab{2} Range is [-infinity, Bound] " minus) - ("2" "\tab{2} Range is [-infinity, +infinity] (Bound is not used) " minusPlus)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01amfGen) - htShowPage() - -d01amfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - infinity := htpButtonValue(htPage,'inf) - inf := - infinity = 'plus => 1 - infinity = 'minus => -1 - 2 - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/4 - prefix := STRCONC('"d01amf(",a," ,",STRINGIMAGE inf," ,") - prefix := STRCONC(prefix,epsabs," ,",epsrel," ,",STRINGIMAGE lw) - middle := STRCONC('" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC('"(",express,"::Expression Float) :: ASP1(F))") - linkGen STRCONC(prefix,middle,end) - -d01anf() == - htInitPage('"D01ANF - 1-D quadrature, adaptive, finite interval, weight function cos(\omega x) or sin(\omega x)", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01anf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01anf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates \inputbitmap{\htbmdir{}/integral.bitmap} g(x)sin(\omega x) dx ") - (text . "or \inputbitmap{\htbmdir{}/integral.bitmap} g(x)cos(\omega x) dx, ") - (text . "the sine and cosine transform respectively. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} f to be integrated in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "log(X)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "1.0e-6" a F)) - (text . "\tab{34} ") - (bcStrings (20 "1.0" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\omega the weight function:") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\tab{34} ") - (bcStrings (20 "10*\%pi" omega F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Key value, indicates which integral is to be computed:") - (radioButtons key - ("" " sin" sin) - ("" " cos" cos)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01anfGen) - htShowPage() - -d01anfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - omega := htpLabelInputString(htPage,'omega) - type := htpButtonValue(htPage,'key) - key := - type = 'cos => 1 - 2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/4 - prefix := STRCONC("d01anf(",a," ,",b," ,",omega," ,",STRINGIMAGE key," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) - middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") - linkGen STRCONC(prefix,middle,end) - -d01apf() == - htInitPage('"D01APF - 1-D quadrature, adaptive, finite interval, weight function with end point singularities of algebraico-logarithmic type", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01apf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01apf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates \inputbitmap{\htbmdir{}/integral.bitmap} g(x)w(x) dx, where w(x) ") - (text . "has end-point singularities of algebraico-logarithmic type. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the {\em function} g(x) in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "sin(10*X)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "1.0e-6" a F)) - (text . "\tab{34} ") - (bcStrings (20 "1.0" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline \alpha in the weight function:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\beta in the weight function:") - (text . "\newline\tab{2} ") - (bcStrings (10 "-0.5" alpha F)) - (text . "\tab{34} ") - (bcStrings (10 "-0.5" beta F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Key value, indicates which weight function is to be used: ") - (radioButtons key - ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta" kone) - ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(x-a)" ktwo) - ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(b-x)" kthree) - ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(x-a) * ln(b-x) " kfour)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01apfGen) - htShowPage() - -d01apfGen htPage == - express := htpLabelInputString(htPage,'expression) - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - alpha := htpLabelInputString(htPage,'alpha) - beta := htpLabelInputString(htPage,'beta) - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - type := htpButtonValue(htPage,'key) - key := - type = 'kone => 1 - type = 'ktwo => 2 - type = 'kthree => 3 - 4 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - liw := lw/4 - prefix := STRCONC("d01apf(",a," ,",b," ,",alpha," ,",beta," ,") - prefix := STRCONC(prefix,STRINGIMAGE key," ,",epsabs," ,",epsrel," ,") - prefix := STRCONC(prefix,STRINGIMAGE lw," ,",STRINGIMAGE liw," ,") - end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") - linkGen STRCONC(prefix,STRINGIMAGE ifail," ,",end) - -d01aqf() == - htInitPage('"D01AQF - 1-D quadrature, adaptive, finite interval, weight function 1/(x-c), Cauchy principal value (Hilbert transform)",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01aqf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01aqf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the Hilbert transform \inputbitmap{\htbmdir{}/integral.bitmap}") - (text . "g(x)/(x-c) dx.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the function {\it g(x)} in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (55 "(X**2+0.01**2)**-1" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval {\it a}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound {\it b}:") - (text . "\newline\tab{2} ") - (bcStrings (20 "-1.0" a F)) - (text . "\tab{34} ") - (bcStrings (20 "1.0" b F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "Parameter {\it c} \notequal {\it a} or {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.5" c F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Relative accuracy:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" epsabs F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0e-4" epsrel F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01aqfGen) - htShowPage() - -d01aqfGen htPage == - express := htpLabelInputString(htPage,'expression) - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - c := htpLabelInputString(htPage,'c) - epsabs := htpLabelInputString(htPage,'epsabs) - epsrel := htpLabelInputString(htPage,'epsrel) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - liw := lw/4 - prefix := STRCONC("d01aqf(",a," ,",b," ,",c," ,",epsabs," ,",epsrel," ,") - prefix := STRCONC(prefix,STRINGIMAGE lw," ,",STRINGIMAGE liw," ,") - end := STRCONC("((",express,")::Expression Float) :: ASP1(G))") - linkGen STRCONC(prefix,STRINGIMAGE ifail," ,",end) - -d01asf() == - htInitPage('"D01ASF - 1-D quadrature, adaptive, semi-infinite interval, weight function cos(\omega x) or sin(\omega x)", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01asf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01asf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates \inputbitmap{\htbmdir{}/si-integral.bitmap} ") - (text . "g(x)sin(\omega x) dx ") - (text . "or \inputbitmap{\htbmdir{}/si-integral.bitmap} ") - (text . "g(x)cos(\omega x) dx, ") - (text . "the sine and cosine transform respectively. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the function {\it g(x)} in terms of X: ") - (text . "\newline \tab{2} ") - (bcStrings (45 "1/sqrt(X)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "1.0e-12" a F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Parameter \omega in the weight function of the transform: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "\%pi/2" omega F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Absolute accuracy required:") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-3" epsabs F)) - (text . "\newline \menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 800 lw PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it LIMLST} upper bound on number of intervals:") - (text . "\newline\tab{2} ") - (bcStrings (10 50 limlst PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Key value, indicates which integral is to be computed:") - (radioButtons key - ("" " cos(\omega x)" cos) - ("" " sin(\omega x)" sin)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01asfGen) - htShowPage() - -d01asfGen htPage == - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - limlst := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'limlst) - objValUnwrap htpLabelSpadValue(htPage, 'limlst) - a := htpLabelInputString(htPage,'a) - epsabs := htpLabelInputString(htPage,'epsabs) - omega := htpLabelInputString(htPage,'omega) - type := htpButtonValue(htPage,'key) - key := - type = 'cos => 1 - 2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - express := htpLabelInputString(htPage,'expression) - liw := lw/2 - prefix := STRCONC("d01asf(",a," ,",omega," ,",STRINGIMAGE key," ,",epsabs) - prefix := STRCONC(prefix," ,",STRINGIMAGE limlst," ,",STRINGIMAGE lw) - middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") - end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") - linkGen STRCONC(prefix,middle,end) - - - -d01gaf() == - htInitPage('"D01GAF - \space{1} 1-D quadrature, integration of function defined by data values, Gill-Miller method", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd01gaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01gaf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the integral ") - (text . "\inputbitmap{\htbmdir{}/d01gaf1.bitmap} y(x)dx ") - (text . "where the numerical value of the function {\em y} is ") - (text . "specified at the n distinct points \vspace{-26} ") - (text . "\inputbitmap{\htbmdir{}/d01gaf2.bitmap} ") - (text . "\blankline ") - (text . "Enter the number of points:") - (text . "\newline\tab{2} ") - (bcStrings (5 21 n PI)) - (text . "\blankline ") - (text . "\newline Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01gafSolve) - htShowPage() - -d01gafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '21 => d01gafDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{40} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("D01GAF - 1-D quadrature, integration of function defined by data values", htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Enter values for {\em x}: \tab{38} " - htSay '"\menuitemstyle{}\tab{40} Enter values for {\em y}: " - htMakePage equationPart - htSay '"\blankline " - htSay '"Note:\space{1}{\em x} values in ascending or descending order only " - htMakeDoneButton('"Continue",'d01gafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d01gafDefaultSolve (htPage, ifail) == - n := '21 - page := htInitPage('"D01GAF - 1-D quadrature, integration of function defined by data values",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values for {\em x}: \tab{38} ") - (text . "\menuitemstyle{}\tab{40} Enter values for {\em y}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.00" x1 F)) - (text . "\tab{40} ") - (bcStrings (10 "4.0000" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.04" x2 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.9936" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.08" x3 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.9746" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.12" x4 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.9432" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.22" x5 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.8153" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.26" x6 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.7467" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.30" x7 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.6697" y7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.38" x8 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.4943" y8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.39" x9 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.4719" y9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.42" x10 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.4002" y10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.45" x11 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.3264" y11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.46" x12 F)) - (text . "\tab{40} ") - (bcStrings (10 "3.3014" y12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.60" x13 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.9412" y13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.68" x14 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.7352" y14 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.72" x15 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.6344" y15 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.73" x16 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.6094" y16 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.83" x17 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.3684" y17 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.85" x18 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.3222" y18 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.88" x19 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.2543" y19 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.90" x20 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.2099" y20 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x21 F)) - (text . "\tab{40} ") - (bcStrings (10 "2.0000" y21 F)) - (text . "\newline \tab{2} ") - (text . "\blankline ") - (text . "Note:\space{1}{\em x} values in ascending or descending order only ") - (text . "\blankline")) - htMakeDoneButton('"Continue",'d01gafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -d01gafGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - linkGen STRCONC ('"d01gaf([",realstring,"],[",imagstring,"],",STRINGIMAGE n,",", STRINGIMAGE ifail,")") - -d01fcf() == - htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01fcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01fcf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the multi-dimensional integral ") - (text . "\center{\htbitmap{d01fcf}}") - (text . "with constant finite limits, using an adaptive subdivision ") - (text . "strategy.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of dimensions n in the integral, 2 \htbitmap{less=} ") - (text . "{\it NDIM} \htbitmap{less=} 15: ") - (text . "\newline\tab{2} ") - (bcStrings (6 4 ndim F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the integrand {\it f} in terms of X[1]...X[n]: ") - (text . "\newline ") - (bcStrings (58 "4.0*X[1]*X[3]*X[3]*exp(2.0*X[1]*X[3])/((1.0+X[2]+X[4])**2)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Minimum number of evaluations: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Maximum number of evaluations: ") - (text . "\newline\tab{2} ") - (bcStrings (10 1000 minpts PI)) - (text . "\tab{34} ") - (bcStrings (10 5700 maxpts PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Relative accuracy required:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" eps F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 606 lenwrk PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01fcfSolve) - htShowPage() - - -d01fcfSolve htPage == - ndim := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ndim) - objValUnwrap htpLabelSpadValue(htPage, 'ndim) - expression := htpLabelInputString(htPage,'expression) - minpts := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'minpts) - objValUnwrap htpLabelSpadValue(htPage, 'minpts) - maxpts := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxpts) - objValUnwrap htpLabelSpadValue(htPage, 'maxpts) - eps := htpLabelInputString(htPage,'eps) - lenwrk := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lenwrk) - objValUnwrap htpLabelSpadValue(htPage, 'lenwrk) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ndim = '4 => d01fcfDefaultSolve(htPage,minpts,maxpts,eps,lenwrk,expression,ifail) - labelList := - "append"/[f(i) for i in 1..ndim] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{32} ") - rnam := INTERN STRCONC ('"a",STRINGIMAGE i) - inam := INTERN STRCONC ('"b",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], - ['text,:post],['bcStrings,[10, 1.0, inam, 'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) - htSay '"Please enter the limits of integration:- " - htSay '"\blankline " - htSay '"\menuitemstyle{}\tab{2} Lower limits: \tab{30} " - htSay '"\menuitemstyle{}\tab{32} Upper limits: " - htMakePage equationPart - htMakeDoneButton('"Continue",'d01fcfGen) - htpSetProperty(page,'ndim,ndim) - htpSetProperty(page,'expression,expression) - htpSetProperty(page,'minpts,minpts) - htpSetProperty(page,'maxpts,maxpts) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'lenwrk,lenwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d01fcfDefaultSolve(htPage,minpts,maxpts,eps,lenwrk,expression,ifail) == - ndim := '4 - page := htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "Please enter the limits of integration:- ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Lower limits: \tab{30} ") - (text . "\menuitemstyle{} \tab{32} Upper limits: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a1 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a2 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a3 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a4 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b4 F)) - (text . "\newline ") - (text . "\blankline")) - htMakeDoneButton('"Continue",'d01fcfGen) - htpSetProperty(page,'ndim,ndim) - htpSetProperty(page,'expression,expression) - htpSetProperty(page,'minpts,minpts) - htpSetProperty(page,'maxpts,maxpts) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'lenwrk,lenwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d01fcfGen htPage == - ndim := htpProperty(htPage,'ndim) - minpts := htpProperty(htPage,'minpts) - maxpts := htpProperty(htPage,'maxpts) - eps := htpProperty(htPage,'eps) - lenwrk := htpProperty(htPage,'lenwrk) - expression := htpProperty(htPage,'expression) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := (first y).1 - y := rest y - left := (first y).1 - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - astring := bcwords2liststring reallist - bstring := bcwords2liststring imaglist - prefix := STRCONC("d01fcf(",STRINGIMAGE ndim,", [",astring,"],[",bstring,"], ") - middle := STRCONC(STRINGIMAGE maxpts,", ",eps," ,",STRINGIMAGE lenwrk," ,") - middle := STRCONC(middle,STRINGIMAGE minpts," ,",STRINGIMAGE ifail," ,") - end := STRCONC("(",expression,"::Expression Float) :: ASP4(FUNCTN))") - linkGen STRCONC(prefix,middle,end) - - -d01gbf() == - htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01gbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01gbf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the multidimensional integral ") - (text . "\center{\htbitmap{d01fcf}} with constant finite limits, ") - (text . "using an adaptive Monte-Carlo method;") - (text . " the routine is suitable for low accuracy work. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of dimensions n in the integral, {\it NDIM}:") - (text . "\newline\tab{2} ") - (bcStrings (6 4 ndim F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the integrand {\it f} in terms of X[1]...X[n]: ") - (text . "\newline ") - (bcStrings (60 "4.0*X[1]*X[3]*X[3]*exp(2.0*X[1]*X[3])/((1.0+X[2]+X[4])**2)" expression EM)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Minimum number of FUNCTN calls: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Maximum number of FUNCTN calls: ") - (text . "\newline\tab{2} ") - (bcStrings (10 1000 mincls PI)) - (text . "\tab{34} ") - (bcStrings (10 20000 maxcls PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Relative accuracy required:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.01" eps F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of workspace array: ") - (text . "\newline\tab{2} ") - (bcStrings (10 500 lenwrk PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01gbfSolve) - htShowPage() - - -d01gbfSolve htPage == - ndim := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ndim) - objValUnwrap htpLabelSpadValue(htPage, 'ndim) - expression := htpLabelInputString(htPage,'expression) - mincls := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mincls) - objValUnwrap htpLabelSpadValue(htPage, 'mincls) - maxcls := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxcls) - objValUnwrap htpLabelSpadValue(htPage, 'maxcls) - eps := htpLabelInputString(htPage,'eps) - lenwrk := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lenwrk) - objValUnwrap htpLabelSpadValue(htPage, 'lenwrk) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ndim = '4 => d01gbfDefaultSolve(htPage,mincls,maxcls,eps,lenwrk,expression,ifail) - labelList := - "append"/[f(i) for i in 1..ndim] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{32} ") - rnam := INTERN STRCONC ('"a",STRINGIMAGE i) - inam := INTERN STRCONC ('"b",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], - ['text,:post],['bcStrings,[10, 1.0, inam, 'P]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) - htSay '"Please enter the limits of integration:- " - htSay '"\blankline " - htSay '"\menuitemstyle{}\tab{2} Lower limits: \tab{30} " - htSay '"\menuitemstyle{}\tab{32} Upper limits: " - htMakePage equationPart - htMakeDoneButton('"Continue",'d01gbfGen) - htpSetProperty(page,'ndim,ndim) - htpSetProperty(page,'expression,expression) - htpSetProperty(page,'mincls,mincls) - htpSetProperty(page,'maxcls,maxcls) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'lenwrk,lenwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d01gbfDefaultSolve(htPage,mincls,maxcls,eps,lenwrk,expression,ifail) == - ndim := '4 - page := htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "Please enter the limits of integration:- ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Lower limits: \tab{30} ") - (text . "\menuitemstyle{} \tab{32} Upper limits: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a1 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a2 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a3 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" a4 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0" b4 F)) - (text . "\newline ") - (text . "\blankline")) - htMakeDoneButton('"Continue",'d01gbfGen) - htpSetProperty(page,'ndim,ndim) - htpSetProperty(page,'expression,expression) - htpSetProperty(page,'mincls,mincls) - htpSetProperty(page,'maxcls,maxcls) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'lenwrk,lenwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - - -d01gbfGen htPage == - ndim := htpProperty(htPage,'ndim) - mincls := htpProperty(htPage,'mincls) - maxcls := htpProperty(htPage,'maxcls) - eps := htpProperty(htPage,'eps) - lenwrk := htpProperty(htPage,'lenwrk) - expression := htpProperty(htPage,'expression) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := (first y).1 - y := rest y - left := (first y).1 - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - astring := bcwords2liststring reallist - bstring := bcwords2liststring imaglist - prefix := STRCONC("d01gbf(",STRINGIMAGE ndim,", [",astring,"],[",bstring,"], ") - middle := STRCONC(STRINGIMAGE maxcls,", ",eps," ,",STRINGIMAGE lenwrk," ,") - middle := STRCONC(middle,STRINGIMAGE mincls," ,[[0.0 for i in 1..") - middle := STRCONC(middle,STRINGIMAGE lenwrk,"]],",STRINGIMAGE ifail," ,") - end := STRCONC("(",expression,"::Expression Float) :: ASP4(FUNCTN))") - linkGen STRCONC(prefix,middle,end) - -d01bbf() == - htInitPage('"D01BBF - Weights and abscissae for Gaussian quadrature rules",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd01bbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01bbf| '|NagIntegrationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Returns the weights and abscissae appropriate to a Gaussian ") - (text . "quadrature formula with a specified number of abscissae. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the D01XXX subroutine: ") - (radioButtons gtype - ("" " D01BAZ" gZero) - ("" " D01BAY" gOne) - ("" " D01BAX" gTwo) - ("" " D01BAW" gThree)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound of the interval: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound:") - (text . "\newline\tab{2} ") - (bcStrings (20 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (20 "1.0" b EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Type of weights for Gauss-Laguerre or Gauss-Hermite quadrature:") - (radioButtons itype - ("" " adjusted weights" iOne) - ("" " normal weights" iZero)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Number of weights & abscissae to be used {\em n}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "6" n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd01bbfGen) - htShowPage() - -d01bbfGen htPage == - sub := htpButtonValue(htPage,'gtype) - gtype := - sub = 'gZero => 0 - sub = 'gOne => 1 - sub = 'gTwo => 2 - 3 - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - wgts := htpButtonValue(htPage,'itype) - itype := - wgts = 'iOne => 1 - 0 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC("d01bbf(",a," ,",b," ,",STRINGIMAGE itype," ,") - end := STRCONC(STRINGIMAGE n," ,",STRINGIMAGE gtype," ,",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,end) diff --git a/src/interp/nag-d01.boot.pamphlet b/src/interp/nag-d01.boot.pamphlet new file mode 100644 index 00000000..a4b2f373 --- /dev/null +++ b/src/interp/nag-d01.boot.pamphlet @@ -0,0 +1,1359 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-d01.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +d01ajf() == + htInitPage('"D01AJF - 1-D quadrature, adaptive, finite interval, allowing for badly-behaved integrands", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01ajf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01ajf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the integral ") + (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx ") + (text . "using an adaptive method. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} f to be integrated in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "X*sin(30*X)/(sqrt(1-(X/(2*\%pi))**2))" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (20 "\%pi*2" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01ajfGen) + htShowPage() + +d01ajfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/4 + prefix := STRCONC("d01ajf(",a," ,",b," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) + middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC("(",express,"::Expression Float) :: ASP1(F))") + linkGen STRCONC(prefix,middle,end) + +d01akf() == + htInitPage('"D01AKF - 1-D quadrature, adaptive, finite interval, method suitable for oscillating functions", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01akf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01akf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes \space{1} \inputbitmap{\htbmdir{}/integral.bitmap} ") + (text . "f(x) dx using an adaptive method, ") + (text . "especially suited to oscillating, non-singular integrands. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} f to be integrated in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "X*sin(30*X)*cos(X)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (20 "\%pi*2" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01akfGen) + htShowPage() + +d01akfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/4 + prefix := STRCONC("d01akf(",a," ,",b," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) + middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC("(",express,"::Expression Float) :: ASP1(F))") + linkGen STRCONC(prefix,middle,end) + +d01alf() == + htInitPage('"D01ALF - 1-D quadrature, adaptive, finite interval, allowing for singularities at user-specified break-points ", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01alf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01alf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the integral \space{1} ") + (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx; ") + (text . "the integrand may have local singular behaviour at a ") + (text . "finite number of points within [a,b]. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} f to be integrated in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "1/sqrt(abs(X-1/7))" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (20 "1.0" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Number of user supplied break-points: \tab{38}") + (bcStrings (10 "1" npts PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline User supplied break-points (separated by commas): ") + (text . "\newline \tab{2} ") + (bcStrings (40 "1/7" points EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01alfGen) + htShowPage() + +d01alfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + npts := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npts) + objValUnwrap htpLabelSpadValue(htPage, 'npts) + points := htpLabelInputString(htPage, 'points) + points := STRCONC ('"[[",points,"]]") + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/2 + prefix := STRCONC('"d01alf(",a," ,",b," ,",STRINGIMAGE npts,",",points,",") + prefix := STRCONC(prefix,epsabs," ,",epsrel," ,",STRINGIMAGE lw) + middle := STRCONC('" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC('"(",express,"::Expression Float) :: ASP1(F))") + linkGen STRCONC(prefix,middle,end) + +d01amf() == + htInitPage('"D01AMF 1-D quadrature, adaptive, infinite or semi-infinite interval",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01amf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01amf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Evaluates the integral \space{1} ") + (text . "\inputbitmap{\htbmdir{}/integral.bitmap} f(x) dx, ") + (text . "where (a,b) can be an infinite or semi-infinite interval.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} f to be integrated in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "1/((X+1)*sqrt(X))" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Bound} the finite limit of the integration range: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" a F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Choose the kind of integration range: ") + (radioButtons inf + (" 1" "\tab{2} Range is [Bound, +infinity] " plus) + ("-1" "\tab{2} Range is [-infinity, Bound] " minus) + ("2" "\tab{2} Range is [-infinity, +infinity] (Bound is not used) " minusPlus)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01amfGen) + htShowPage() + +d01amfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + infinity := htpButtonValue(htPage,'inf) + inf := + infinity = 'plus => 1 + infinity = 'minus => -1 + 2 + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/4 + prefix := STRCONC('"d01amf(",a," ,",STRINGIMAGE inf," ,") + prefix := STRCONC(prefix,epsabs," ,",epsrel," ,",STRINGIMAGE lw) + middle := STRCONC('" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC('"(",express,"::Expression Float) :: ASP1(F))") + linkGen STRCONC(prefix,middle,end) + +d01anf() == + htInitPage('"D01ANF - 1-D quadrature, adaptive, finite interval, weight function cos(\omega x) or sin(\omega x)", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01anf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01anf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates \inputbitmap{\htbmdir{}/integral.bitmap} g(x)sin(\omega x) dx ") + (text . "or \inputbitmap{\htbmdir{}/integral.bitmap} g(x)cos(\omega x) dx, ") + (text . "the sine and cosine transform respectively. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} f to be integrated in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "log(X)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "1.0e-6" a F)) + (text . "\tab{34} ") + (bcStrings (20 "1.0" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\omega the weight function:") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\tab{34} ") + (bcStrings (20 "10*\%pi" omega F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Key value, indicates which integral is to be computed:") + (radioButtons key + ("" " sin" sin) + ("" " cos" cos)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01anfGen) + htShowPage() + +d01anfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + omega := htpLabelInputString(htPage,'omega) + type := htpButtonValue(htPage,'key) + key := + type = 'cos => 1 + 2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/4 + prefix := STRCONC("d01anf(",a," ,",b," ,",omega," ,",STRINGIMAGE key," ,",epsabs," ,",epsrel," ,",STRINGIMAGE lw) + middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") + linkGen STRCONC(prefix,middle,end) + +d01apf() == + htInitPage('"D01APF - 1-D quadrature, adaptive, finite interval, weight function with end point singularities of algebraico-logarithmic type", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01apf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01apf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates \inputbitmap{\htbmdir{}/integral.bitmap} g(x)w(x) dx, where w(x) ") + (text . "has end-point singularities of algebraico-logarithmic type. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the {\em function} g(x) in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "sin(10*X)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "1.0e-6" a F)) + (text . "\tab{34} ") + (bcStrings (20 "1.0" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline \alpha in the weight function:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\beta in the weight function:") + (text . "\newline\tab{2} ") + (bcStrings (10 "-0.5" alpha F)) + (text . "\tab{34} ") + (bcStrings (10 "-0.5" beta F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Key value, indicates which weight function is to be used: ") + (radioButtons key + ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta" kone) + ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(x-a)" ktwo) + ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(b-x)" kthree) + ("" "\space{1}w(x) = (x-a)**\alpha\space{1}* (b-x)**\beta * ln(x-a) * ln(b-x) " kfour)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01apfGen) + htShowPage() + +d01apfGen htPage == + express := htpLabelInputString(htPage,'expression) + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + alpha := htpLabelInputString(htPage,'alpha) + beta := htpLabelInputString(htPage,'beta) + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + type := htpButtonValue(htPage,'key) + key := + type = 'kone => 1 + type = 'ktwo => 2 + type = 'kthree => 3 + 4 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + liw := lw/4 + prefix := STRCONC("d01apf(",a," ,",b," ,",alpha," ,",beta," ,") + prefix := STRCONC(prefix,STRINGIMAGE key," ,",epsabs," ,",epsrel," ,") + prefix := STRCONC(prefix,STRINGIMAGE lw," ,",STRINGIMAGE liw," ,") + end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") + linkGen STRCONC(prefix,STRINGIMAGE ifail," ,",end) + +d01aqf() == + htInitPage('"D01AQF - 1-D quadrature, adaptive, finite interval, weight function 1/(x-c), Cauchy principal value (Hilbert transform)",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01aqf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01aqf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the Hilbert transform \inputbitmap{\htbmdir{}/integral.bitmap}") + (text . "g(x)/(x-c) dx.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the function {\it g(x)} in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (55 "(X**2+0.01**2)**-1" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval {\it a}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound {\it b}:") + (text . "\newline\tab{2} ") + (bcStrings (20 "-1.0" a F)) + (text . "\tab{34} ") + (bcStrings (20 "1.0" b F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "Parameter {\it c} \notequal {\it a} or {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.5" c F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Relative accuracy:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" epsabs F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0e-4" epsrel F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01aqfGen) + htShowPage() + +d01aqfGen htPage == + express := htpLabelInputString(htPage,'expression) + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + c := htpLabelInputString(htPage,'c) + epsabs := htpLabelInputString(htPage,'epsabs) + epsrel := htpLabelInputString(htPage,'epsrel) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + liw := lw/4 + prefix := STRCONC("d01aqf(",a," ,",b," ,",c," ,",epsabs," ,",epsrel," ,") + prefix := STRCONC(prefix,STRINGIMAGE lw," ,",STRINGIMAGE liw," ,") + end := STRCONC("((",express,")::Expression Float) :: ASP1(G))") + linkGen STRCONC(prefix,STRINGIMAGE ifail," ,",end) + +d01asf() == + htInitPage('"D01ASF - 1-D quadrature, adaptive, semi-infinite interval, weight function cos(\omega x) or sin(\omega x)", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01asf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01asf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates \inputbitmap{\htbmdir{}/si-integral.bitmap} ") + (text . "g(x)sin(\omega x) dx ") + (text . "or \inputbitmap{\htbmdir{}/si-integral.bitmap} ") + (text . "g(x)cos(\omega x) dx, ") + (text . "the sine and cosine transform respectively. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the function {\it g(x)} in terms of X: ") + (text . "\newline \tab{2} ") + (bcStrings (45 "1/sqrt(X)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "1.0e-12" a F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Parameter \omega in the weight function of the transform: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "\%pi/2" omega F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Absolute accuracy required:") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-3" epsabs F)) + (text . "\newline \menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 800 lw PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it LIMLST} upper bound on number of intervals:") + (text . "\newline\tab{2} ") + (bcStrings (10 50 limlst PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Key value, indicates which integral is to be computed:") + (radioButtons key + ("" " cos(\omega x)" cos) + ("" " sin(\omega x)" sin)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01asfGen) + htShowPage() + +d01asfGen htPage == + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + limlst := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'limlst) + objValUnwrap htpLabelSpadValue(htPage, 'limlst) + a := htpLabelInputString(htPage,'a) + epsabs := htpLabelInputString(htPage,'epsabs) + omega := htpLabelInputString(htPage,'omega) + type := htpButtonValue(htPage,'key) + key := + type = 'cos => 1 + 2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + express := htpLabelInputString(htPage,'expression) + liw := lw/2 + prefix := STRCONC("d01asf(",a," ,",omega," ,",STRINGIMAGE key," ,",epsabs) + prefix := STRCONC(prefix," ,",STRINGIMAGE limlst," ,",STRINGIMAGE lw) + middle := STRCONC(" ,",STRINGIMAGE liw," ,",STRINGIMAGE ifail," ,") + end := STRCONC("(",express,"::Expression Float) :: ASP1(G))") + linkGen STRCONC(prefix,middle,end) + + + +d01gaf() == + htInitPage('"D01GAF - \space{1} 1-D quadrature, integration of function defined by data values, Gill-Miller method", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd01gaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01gaf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the integral ") + (text . "\inputbitmap{\htbmdir{}/d01gaf1.bitmap} y(x)dx ") + (text . "where the numerical value of the function {\em y} is ") + (text . "specified at the n distinct points \vspace{-26} ") + (text . "\inputbitmap{\htbmdir{}/d01gaf2.bitmap} ") + (text . "\blankline ") + (text . "Enter the number of points:") + (text . "\newline\tab{2} ") + (bcStrings (5 21 n PI)) + (text . "\blankline ") + (text . "\newline Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01gafSolve) + htShowPage() + +d01gafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '21 => d01gafDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{40} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, xnam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("D01GAF - 1-D quadrature, integration of function defined by data values", htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Enter values for {\em x}: \tab{38} " + htSay '"\menuitemstyle{}\tab{40} Enter values for {\em y}: " + htMakePage equationPart + htSay '"\blankline " + htSay '"Note:\space{1}{\em x} values in ascending or descending order only " + htMakeDoneButton('"Continue",'d01gafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d01gafDefaultSolve (htPage, ifail) == + n := '21 + page := htInitPage('"D01GAF - 1-D quadrature, integration of function defined by data values",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values for {\em x}: \tab{38} ") + (text . "\menuitemstyle{}\tab{40} Enter values for {\em y}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.00" x1 F)) + (text . "\tab{40} ") + (bcStrings (10 "4.0000" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.04" x2 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.9936" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.08" x3 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.9746" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.12" x4 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.9432" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.22" x5 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.8153" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.26" x6 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.7467" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.30" x7 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.6697" y7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.38" x8 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.4943" y8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.39" x9 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.4719" y9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.42" x10 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.4002" y10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.45" x11 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.3264" y11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.46" x12 F)) + (text . "\tab{40} ") + (bcStrings (10 "3.3014" y12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.60" x13 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.9412" y13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.68" x14 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.7352" y14 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.72" x15 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.6344" y15 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.73" x16 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.6094" y16 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.83" x17 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.3684" y17 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.85" x18 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.3222" y18 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.88" x19 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.2543" y19 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.90" x20 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.2099" y20 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x21 F)) + (text . "\tab{40} ") + (bcStrings (10 "2.0000" y21 F)) + (text . "\newline \tab{2} ") + (text . "\blankline ") + (text . "Note:\space{1}{\em x} values in ascending or descending order only ") + (text . "\blankline")) + htMakeDoneButton('"Continue",'d01gafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +d01gafGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + linkGen STRCONC ('"d01gaf([",realstring,"],[",imagstring,"],",STRINGIMAGE n,",", STRINGIMAGE ifail,")") + +d01fcf() == + htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01fcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01fcf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the multi-dimensional integral ") + (text . "\center{\htbitmap{d01fcf}}") + (text . "with constant finite limits, using an adaptive subdivision ") + (text . "strategy.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of dimensions n in the integral, 2 \htbitmap{less=} ") + (text . "{\it NDIM} \htbitmap{less=} 15: ") + (text . "\newline\tab{2} ") + (bcStrings (6 4 ndim F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the integrand {\it f} in terms of X[1]...X[n]: ") + (text . "\newline ") + (bcStrings (58 "4.0*X[1]*X[3]*X[3]*exp(2.0*X[1]*X[3])/((1.0+X[2]+X[4])**2)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Minimum number of evaluations: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Maximum number of evaluations: ") + (text . "\newline\tab{2} ") + (bcStrings (10 1000 minpts PI)) + (text . "\tab{34} ") + (bcStrings (10 5700 maxpts PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Relative accuracy required:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" eps F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 606 lenwrk PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01fcfSolve) + htShowPage() + + +d01fcfSolve htPage == + ndim := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ndim) + objValUnwrap htpLabelSpadValue(htPage, 'ndim) + expression := htpLabelInputString(htPage,'expression) + minpts := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'minpts) + objValUnwrap htpLabelSpadValue(htPage, 'minpts) + maxpts := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxpts) + objValUnwrap htpLabelSpadValue(htPage, 'maxpts) + eps := htpLabelInputString(htPage,'eps) + lenwrk := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lenwrk) + objValUnwrap htpLabelSpadValue(htPage, 'lenwrk) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ndim = '4 => d01fcfDefaultSolve(htPage,minpts,maxpts,eps,lenwrk,expression,ifail) + labelList := + "append"/[f(i) for i in 1..ndim] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{32} ") + rnam := INTERN STRCONC ('"a",STRINGIMAGE i) + inam := INTERN STRCONC ('"b",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], + ['text,:post],['bcStrings,[10, 1.0, inam, 'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) + htSay '"Please enter the limits of integration:- " + htSay '"\blankline " + htSay '"\menuitemstyle{}\tab{2} Lower limits: \tab{30} " + htSay '"\menuitemstyle{}\tab{32} Upper limits: " + htMakePage equationPart + htMakeDoneButton('"Continue",'d01fcfGen) + htpSetProperty(page,'ndim,ndim) + htpSetProperty(page,'expression,expression) + htpSetProperty(page,'minpts,minpts) + htpSetProperty(page,'maxpts,maxpts) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'lenwrk,lenwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d01fcfDefaultSolve(htPage,minpts,maxpts,eps,lenwrk,expression,ifail) == + ndim := '4 + page := htInitPage('"D01FCF - Multi-dimensional adaptive quadrature over hyper-rectangle",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "Please enter the limits of integration:- ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Lower limits: \tab{30} ") + (text . "\menuitemstyle{} \tab{32} Upper limits: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a1 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a2 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a3 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a4 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b4 F)) + (text . "\newline ") + (text . "\blankline")) + htMakeDoneButton('"Continue",'d01fcfGen) + htpSetProperty(page,'ndim,ndim) + htpSetProperty(page,'expression,expression) + htpSetProperty(page,'minpts,minpts) + htpSetProperty(page,'maxpts,maxpts) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'lenwrk,lenwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d01fcfGen htPage == + ndim := htpProperty(htPage,'ndim) + minpts := htpProperty(htPage,'minpts) + maxpts := htpProperty(htPage,'maxpts) + eps := htpProperty(htPage,'eps) + lenwrk := htpProperty(htPage,'lenwrk) + expression := htpProperty(htPage,'expression) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := (first y).1 + y := rest y + left := (first y).1 + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + astring := bcwords2liststring reallist + bstring := bcwords2liststring imaglist + prefix := STRCONC("d01fcf(",STRINGIMAGE ndim,", [",astring,"],[",bstring,"], ") + middle := STRCONC(STRINGIMAGE maxpts,", ",eps," ,",STRINGIMAGE lenwrk," ,") + middle := STRCONC(middle,STRINGIMAGE minpts," ,",STRINGIMAGE ifail," ,") + end := STRCONC("(",expression,"::Expression Float) :: ASP4(FUNCTN))") + linkGen STRCONC(prefix,middle,end) + + +d01gbf() == + htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01gbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01gbf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the multidimensional integral ") + (text . "\center{\htbitmap{d01fcf}} with constant finite limits, ") + (text . "using an adaptive Monte-Carlo method;") + (text . " the routine is suitable for low accuracy work. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of dimensions n in the integral, {\it NDIM}:") + (text . "\newline\tab{2} ") + (bcStrings (6 4 ndim F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the integrand {\it f} in terms of X[1]...X[n]: ") + (text . "\newline ") + (bcStrings (60 "4.0*X[1]*X[3]*X[3]*exp(2.0*X[1]*X[3])/((1.0+X[2]+X[4])**2)" expression EM)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Minimum number of FUNCTN calls: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Maximum number of FUNCTN calls: ") + (text . "\newline\tab{2} ") + (bcStrings (10 1000 mincls PI)) + (text . "\tab{34} ") + (bcStrings (10 20000 maxcls PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Relative accuracy required:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.01" eps F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of workspace array: ") + (text . "\newline\tab{2} ") + (bcStrings (10 500 lenwrk PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01gbfSolve) + htShowPage() + + +d01gbfSolve htPage == + ndim := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ndim) + objValUnwrap htpLabelSpadValue(htPage, 'ndim) + expression := htpLabelInputString(htPage,'expression) + mincls := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mincls) + objValUnwrap htpLabelSpadValue(htPage, 'mincls) + maxcls := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxcls) + objValUnwrap htpLabelSpadValue(htPage, 'maxcls) + eps := htpLabelInputString(htPage,'eps) + lenwrk := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lenwrk) + objValUnwrap htpLabelSpadValue(htPage, 'lenwrk) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ndim = '4 => d01gbfDefaultSolve(htPage,mincls,maxcls,eps,lenwrk,expression,ifail) + labelList := + "append"/[f(i) for i in 1..ndim] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{32} ") + rnam := INTERN STRCONC ('"a",STRINGIMAGE i) + inam := INTERN STRCONC ('"b",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, rnam, 'P]], + ['text,:post],['bcStrings,[10, 1.0, inam, 'P]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) + htSay '"Please enter the limits of integration:- " + htSay '"\blankline " + htSay '"\menuitemstyle{}\tab{2} Lower limits: \tab{30} " + htSay '"\menuitemstyle{}\tab{32} Upper limits: " + htMakePage equationPart + htMakeDoneButton('"Continue",'d01gbfGen) + htpSetProperty(page,'ndim,ndim) + htpSetProperty(page,'expression,expression) + htpSetProperty(page,'mincls,mincls) + htpSetProperty(page,'maxcls,maxcls) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'lenwrk,lenwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d01gbfDefaultSolve(htPage,mincls,maxcls,eps,lenwrk,expression,ifail) == + ndim := '4 + page := htInitPage('"D01GBF - Multi-dimensional quadrature over hyper-rectangle, Monte Carlo method",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "Please enter the limits of integration:- ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Lower limits: \tab{30} ") + (text . "\menuitemstyle{} \tab{32} Upper limits: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a1 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a2 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a3 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" a4 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0" b4 F)) + (text . "\newline ") + (text . "\blankline")) + htMakeDoneButton('"Continue",'d01gbfGen) + htpSetProperty(page,'ndim,ndim) + htpSetProperty(page,'expression,expression) + htpSetProperty(page,'mincls,mincls) + htpSetProperty(page,'maxcls,maxcls) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'lenwrk,lenwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + + +d01gbfGen htPage == + ndim := htpProperty(htPage,'ndim) + mincls := htpProperty(htPage,'mincls) + maxcls := htpProperty(htPage,'maxcls) + eps := htpProperty(htPage,'eps) + lenwrk := htpProperty(htPage,'lenwrk) + expression := htpProperty(htPage,'expression) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := (first y).1 + y := rest y + left := (first y).1 + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + astring := bcwords2liststring reallist + bstring := bcwords2liststring imaglist + prefix := STRCONC("d01gbf(",STRINGIMAGE ndim,", [",astring,"],[",bstring,"], ") + middle := STRCONC(STRINGIMAGE maxcls,", ",eps," ,",STRINGIMAGE lenwrk," ,") + middle := STRCONC(middle,STRINGIMAGE mincls," ,[[0.0 for i in 1..") + middle := STRCONC(middle,STRINGIMAGE lenwrk,"]],",STRINGIMAGE ifail," ,") + end := STRCONC("(",expression,"::Expression Float) :: ASP4(FUNCTN))") + linkGen STRCONC(prefix,middle,end) + +d01bbf() == + htInitPage('"D01BBF - Weights and abscissae for Gaussian quadrature rules",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd01bbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d01bbf| '|NagIntegrationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Returns the weights and abscissae appropriate to a Gaussian ") + (text . "quadrature formula with a specified number of abscissae. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the D01XXX subroutine: ") + (radioButtons gtype + ("" " D01BAZ" gZero) + ("" " D01BAY" gOne) + ("" " D01BAX" gTwo) + ("" " D01BAW" gThree)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound of the interval: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound:") + (text . "\newline\tab{2} ") + (bcStrings (20 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (20 "1.0" b EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Type of weights for Gauss-Laguerre or Gauss-Hermite quadrature:") + (radioButtons itype + ("" " adjusted weights" iOne) + ("" " normal weights" iZero)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Number of weights & abscissae to be used {\em n}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "6" n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd01bbfGen) + htShowPage() + +d01bbfGen htPage == + sub := htpButtonValue(htPage,'gtype) + gtype := + sub = 'gZero => 0 + sub = 'gOne => 1 + sub = 'gTwo => 2 + 3 + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + wgts := htpButtonValue(htPage,'itype) + itype := + wgts = 'iOne => 1 + 0 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC("d01bbf(",a," ,",b," ,",STRINGIMAGE itype," ,") + end := STRCONC(STRINGIMAGE n," ,",STRINGIMAGE gtype," ,",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,end) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-d02.boot b/src/interp/nag-d02.boot deleted file mode 100644 index 6d8f5924..00000000 --- a/src/interp/nag-d02.boot +++ /dev/null @@ -1,2146 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -d02bbf() == - htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02bbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02bbf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02BBF integrates a system of {\it n} ordinary differential ") - (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") - (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") - (text . "conditions using a Runge-Kutta-Merson method; the solution ") - (text . "may be output at specified points.") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Initial value of {\it x}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "0.0" x F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "End of integration range {\it xend}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "8.0" xend F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of differential equations {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Tolerance required {\it tol}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Error control indicator {\it irelab}:") - (radioButtons irelab - ("" " 0, mixed" mix) - ("" " 1, absolute" abs) - ("" " 2, relative" rel)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd02bbfSolve) - htShowPage() - -d02bbfSolve htPage == - x := htpLabelInputString(htPage,'x) - xend := htpLabelInputString(htPage,'xend) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - tol := htpLabelInputString(htPage,'tol) - control := htpButtonValue(htPage,'irelab) - irelab := - control = 'mix => '0 - control = 'abs => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'minusOne => '-1 - '1 - n = '3 => d02bbfDefaultSolve(htPage,x,xend,tol,irelab,ifail) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") - middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline \tab{2}") - yList := - "append"/[fb(i) for i in 1..n] where fb(i) == - ynam := INTERN STRCONC ('"u",STRINGIMAGE i) - [['bcStrings,[6, 0, ynam, 'F]]] - yList := [['text,:middle],:yList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") - mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline \tab{2}") - vList := [['bcStrings,[30, "0", 'out, 'EM]]] - vList := [['text,:mid],:vList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:yList,:vList] - page := htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions (i.e. the derivatives) below " - htSay '"as functions of Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02bbfGen) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'irelab,irelab) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02bbfDefaultSolve(htPage,x,xend,tol,irelab,ifail) == - n := '3 - page := htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions (i.e. the derivatives) below ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (44 "tan(Y[3])" f1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the initial values of \htbitmap{yi}:") - (text . "\newline \tab{2}") - (bcStrings (8 "0.0" y1 EM)) - (bcStrings (8 "0.5" y2 EM)) - (bcStrings (8 "\%pi*0.2" y3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Intermediate values of {\it x} at which \htbitmap{yi} is required:") - (text . "\newline \tab{2}") - (bcStrings (30 "1,2,3,4,5,6,7,8" out EM))) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'irelab,irelab) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02bbfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02bbfGen htPage == - x := htpProperty(htPage, 'x) - xend := htpProperty(htPage, 'xend) - n := htpProperty(htPage, 'n) - tol := htpProperty(htPage, 'tol) - irelab := htpProperty(htPage, 'irelab) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - outp := ((first y).1) - oList := [outp,:oList] - y := rest y - ostring := bcwords2liststring oList - -- This is distictly horrible! OUTP is a comma-seperated string so we - -- count up the commas to see how many elements it has. We return this - -- quantity plus 1 since the ASP OUTPUT is always called at least once. - numberOfPoints := - ZEROP LENGTH(outp) => 1 - 2+COUNT(CHARACTER(44),outp) - for i in 1..n repeat - ytemp := STRCONC((first y).1," ") - yList := [ytemp,:yList] - y := rest y - ystring := bcwords2liststring yList - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - prefix := STRCONC("d02bbf(", xend,", ", STRINGIMAGE numberOfPoints, ", ",STRINGIMAGE n,", ",STRINGIMAGE irelab) - prefix := STRCONC(prefix,", ",x,", [", ystring,"],",tol) - prefix := STRCONC(prefix,", ",STRINGIMAGE ifail,",(") - end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN),(",ostring) - end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") - linkGen STRCONC(prefix,end) - -d02bhf() == - htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02bhf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02bhf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02BHF integrates a system of {\it n} ordinary differential ") - (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") - (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") - (text . "conditions using a Runge-Kutta-Merson method until a specified ") - (text . "function {\em g(x,y)} of the solution is zero. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Initial value of {\it x}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "0.0" x F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "End of integration range {\it xend}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "10.0" xend F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of differential equations {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Tolerance required {\it tol}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Error control indicator {\it irelab}:") - (radioButtons irelab - ("" " 0, mixed" mix) - ("" " 1, absolute" abs) - ("" " 2, relative" rel)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Upper bound on size of the interval {\it hmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" hmax F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd02bhfSolve) - htShowPage() - -d02bhfSolve htPage == - x := htpLabelInputString(htPage,'x) - xend := htpLabelInputString(htPage,'xend) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - tol := htpLabelInputString(htPage,'tol) - control := htpButtonValue(htPage,'irelab) - irelab := - control = 'mix => '0 - control = 'abs => '1 - '2 - hmax := htpLabelInputString(htPage,'hmax) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '3 => d02bhfDefaultSolve(htPage,x,xend,tol,irelab,hmax,ifail) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") - middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") - yList := - "append"/[fb(i) for i in 1..n] where fb(i) == - ynam := INTERN STRCONC ('"u",STRINGIMAGE i) - [['bcStrings,[6, 0, ynam, 'F]]] - yList := [['text,:middle],:yList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") - mid := STRCONC(mid,'"{\em g(x,y)}: \newline ") - vList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] - vList := [['text,:mid],:vList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:yList,:vList] - page := htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " - htSay '"as functions of Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02bhfGen) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'irelab,irelab) - htpSetProperty(page,'hmax,hmax) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02bhfDefaultSolve(htPage,x,xend,tol,irelab,hmax,ifail) == - n := '3 - page := htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (44 "tan(Y[3])" f1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the initial values of \htbitmap{yi}:") - (text . "\newline ") - (bcStrings (8 "0.5" y1 EM)) - (bcStrings (8 "0.5" y2 EM)) - (bcStrings (8 "\%pi*0.2" y3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the function below {\em g(x,y)}: ") - (text . "\newline ") - (bcStrings (30 "Y[1]" g EM))) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'irelab,irelab) - htpSetProperty(page,'hmax,hmax) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02bhfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02bhfGen htPage == - x := htpProperty(htPage, 'x) - xend := htpProperty(htPage, 'xend) - n := htpProperty(htPage, 'n) - tol := htpProperty(htPage, 'tol) - irelab := htpProperty(htPage, 'irelab) - hmax := htpProperty(htPage, 'hmax) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - g := ((first y).1) - y := rest y - for i in 1..n repeat - ytemp := STRCONC((first y).1," ") - yList := [ytemp,:yList] - y := rest y - ystring := bcwords2liststring yList - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - prefix := STRCONC("d02bhf(", xend,", ",STRINGIMAGE n,", ",STRINGIMAGE irelab) - mid := STRCONC(", ",hmax,", ",x,", [", ystring,"],") - mid := STRCONC(mid,tol,", ",STRINGIMAGE ifail,",(",g) - mid := STRCONC(mid,"::Expression Float)::ASP9('G),(") - end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN))") - linkGen STRCONC(prefix,mid,end) - - -d02cjf() == - htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02cjf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02cjf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02CJF integrates a system of {\it n} ordinary differential ") - (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") - (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") - (text . "conditions using an Adams method until a specified ") - (text . "function {\em g(x,y)} of the solution is zero; the solution may ") - (text . "be output at specified points. \blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Initial value of {\it x}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "0.0" x F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "End of integration range {\it xend}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "10.0" xend F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of differential equations {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Tolerance required {\it tol}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Type of error test used {\it relabs}:") - (radioButtons relabs - ("" " D, default (mixed)" mix) - ("" " A, absolute" abs) - ("" " R, relative" rel)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd02cjfSolve) - htShowPage() - -d02cjfSolve htPage == - x := htpLabelInputString(htPage,'x) - xend := htpLabelInputString(htPage,'xend) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - tol := htpLabelInputString(htPage,'tol) - control := htpButtonValue(htPage,'relabs) - relabs := - control = 'mix => '"D" - control = 'abs => '"A" - '"R" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '3 => d02cjfDefaultSolve(htPage,x,xend,tol,relabs,ifail) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") - middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") - yList := - "append"/[fb(i) for i in 1..n] where fb(i) == - ynam := INTERN STRCONC ('"u",STRINGIMAGE i) - [['bcStrings,[6, 0, ynam, 'F]]] - yList := [['text,:middle],:yList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") - mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline ") - vList := [['bcStrings,[30, "2,4", 'out, 'EM]]] - vList := [['text,:mid],:vList] - midd := ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") - midd := STRCONC(midd,'"{\em g(x,y)}: \newline ") - uList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] - uList := [['text,:midd],:uList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:yList,:vList,:uList] - page := htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " - htSay '"as functions of Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02cjfGen) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'relabs,relabs) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02cjfDefaultSolve(htPage,x,xend,tol,relabs,ifail) == - n := '3 - page := htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (44 "tan(Y[3])" f1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the initial values of \htbitmap{yi}:") - (text . "\newline ") - (bcStrings (8 "0.5" y1 EM)) - (bcStrings (8 "0.5" y2 EM)) - (bcStrings (8 "\%pi*0.2" y3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Intermediate") - (text . " values of {\it x} at which \htbitmap{yi} is required:") - (text . "\newline ") - (bcStrings (30 "2,4,6,8" out EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the function below {\em g(x,y)}: ") - (text . "\newline ") - (bcStrings (30 "Y[1]" g EM))) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'relabs,relabs) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02cjfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02cjfGen htPage == - x := htpProperty(htPage, 'x) - xend := htpProperty(htPage, 'xend) - n := htpProperty(htPage, 'n) - tol := htpProperty(htPage, 'tol) - relabs := htpProperty(htPage, 'relabs) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - g := ((first y).1) - y := rest y - outp := ((first y).1) - oList := [outp,:oList] - ostring := bcwords2liststring oList - -- This is distictly horrible! OUTP is a comma-seperated string so we - -- count up the commas to see how many elements it has. We return this - -- quantity plus 1 since the ASP OUTPUT is always called at least once. - numberOfPoints := - ZEROP LENGTH(outp) => 1 - 2+COUNT(CHARACTER(44),outp) - y := rest y - for i in 1..n repeat - ytemp := STRCONC((first y).1," ") - yList := [ytemp,:yList] - y := rest y - ystring := bcwords2liststring yList - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - prefix := STRCONC("d02cjf(",xend,", ",STRINGIMAGE numberOfPoints ,", ", STRINGIMAGE n,", ",tol,",_"",relabs) - mid := STRCONC("_", ",x ,", [", ystring,"],",STRINGIMAGE ifail) - mid := STRCONC(mid,",(",g,"::Expression Float)::ASP9('G),(",fstring) - end := STRCONC("::Vector Expression Float)::ASP7('FCN),(",ostring) - end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") - linkGen STRCONC(prefix,mid,end) - - - -d02ejf() == - htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02ejf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02ejf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02EJF integrates a system of {\em n} ordinary differential ") - (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for {\it i} ") - (text . "= 1,,2,...,{\it n}, over a range with given initial conditions") - (text . " using backward differentiation formulae until a specified ") - (text . "function {\em g(x,y)} of the solution is zero; the solution may ") - (text . "be output at specified points. \blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Initial value of {\it x}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "0.0" x F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "End of integration range {\it xend}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "10.0" xend F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of differential equations {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Tolerance required {\it tol}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Type of error test used {\it relabs}:") - (radioButtons relabs - ("" " D, default (mixed)" mix) - ("" " A, absolute" abs) - ("" " R, relative" rel)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd02ejfSolve) - htShowPage() - -d02ejfSolve htPage == - x := htpLabelInputString(htPage,'x) - xend := htpLabelInputString(htPage,'xend) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - tol := htpLabelInputString(htPage,'tol) - control := htpButtonValue(htPage,'relabs) - relabs := - control = 'mix => '"D" - control = 'abs => '"A" - '"R" - iw := (n + 12) * n + 50 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '3 => d02ejfDefaultSolve(htPage,x,xend,tol,relabs,iw,ifail) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") - middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") - yList := - "append"/[fb(i) for i in 1..n] where fb(i) == - ynam := INTERN STRCONC ('"u",STRINGIMAGE i) - [['bcStrings,[6, 0, ynam, 'F]]] - yList := [['text,:middle],:yList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") - mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline ") - vList := [['bcStrings,[30, "2,4,6,8", 'out, 'EM]]] - vList := [['text,:mid],:vList] - midd := ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") - midd := STRCONC(midd,'"{\em g(x,y)}: \newline ") - uList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] - uList := [['text,:midd],:uList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:yList,:vList,:uList] - page := htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " - htSay '"as functions of Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htSay '"\blankline {\em Note:} PEDERV is automatically generated using the vector " - htSay '"of derivatives given above. " - htMakeDoneButton('"Continue",'d02ejfGen) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'relabs,relabs) - htpSetProperty(page,'iw,iw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02ejfDefaultSolve(htPage,x,xend,tol,relabs,iw,ifail) == - n := '3 - page := htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (44 "-0.04*Y[1]+1.0E4*Y[2]*Y[3]" f1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (44 "0.04*Y[1]-1.0E4*Y[2]*Y[3]-3.0E7*Y[2]*Y[2]" f2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (44 "3.0E7*Y[2]*Y[2]" f3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the initial values of \htbitmap{yi}:") - (text . "\newline ") - (bcStrings (8 "1.0" y1 EM)) - (bcStrings (8 "0.0" y2 EM)) - (bcStrings (8 "0.0" y3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Intermediate") - (text . " values of {\it x} at which \htbitmap{yi} is required:") - (text . "\newline ") - (bcStrings (30 "2,4,6,8" out EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the function below {\em g(x,y)}: ") - (text . "\newline ") - (bcStrings (30 "Y[1]-0.9" g EM)) - (text . "\blankline ") - (text . "{\em Note:} PEDERV is automatically generated using the vector ") - (text . "of derivatives given above. ")) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xend,xend) - htpSetProperty(page,'n,n) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'relabs,relabs) - htpSetProperty(page,'iw,iw) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02ejfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02ejfGen htPage == - x := htpProperty(htPage, 'x) - xend := htpProperty(htPage, 'xend) - n := htpProperty(htPage, 'n) - tol := htpProperty(htPage, 'tol) - relabs := htpProperty(htPage, 'relabs) - iw := htpProperty(htPage, 'iw) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - g := ((first y).1) - y := rest y - outp := ((first y).1) - oList := [outp,:oList] - ostring := bcwords2liststring oList - -- This is distictly horrible! OUTP is a comma-seperated string so we - -- count up the commas to see how many elements it has. We return this - -- quantity plus 1 since the ASP OUTPUT is always called at least once. - numberOfPoints := - ZEROP LENGTH(outp) => 1 - 2+COUNT(CHARACTER(44),outp) - y := rest y - for i in 1..n repeat - ytemp := STRCONC((first y).1," ") - yList := [ytemp,:yList] - y := rest y - ystring := bcwords2liststring yList - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - prefix := STRCONC("d02ejf(",xend,", ",STRINGIMAGE numberOfPoints,", ", STRINGIMAGE n,",_"",relabs,"_", ") - mid:=STRCONC(STRINGIMAGE iw,", ",x ,", [", ystring,"], ",tol,", ") - mid := STRCONC(mid,STRINGIMAGE ifail,",(",g,"::Expression Float)::ASP9(G),(") - end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN),(",fstring) - end := STRCONC(end,"::Vector Expression Float)::ASP31('PEDERV),(",ostring) - end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") - linkGen STRCONC(prefix,mid,end) - -d02gaf() == - htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02gaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02gaf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02GAF solves a two-point boundary value problem for a system ") - (text . "of n ODEs \center{\htbitmap{d02gaf},} for i = 1,2,...,n, on ") - (text . "the range [a,b] with assigned boundary conditions using a ") - (text . "deferred correction technique and a Newton iteration; ") - (text . "the solution is computed on a mesh. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of equations in the system {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Left hand boundary point {\it a}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Right hand boundary {\it b}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (10 "10.0" b F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Max number of mesh points {\it mnp}:") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Number of points {\it np} ({\it np} = 0 or {\it np} ") - (text . "\htbitmap{great=} 4): ") - (text . "\newline\tab{2} ") - (bcStrings (10 64 mnp PI)) - (text . "\tab{34} ") - (bcStrings (10 26 np PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Accuracy required {\it tol}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-3" tol F)) - (text . "\blankline ") - (text . "\newline \tab{2} ") - (text . "Ifail is input in three components: ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it a} ") - (radioButtons afail - ("" " 0, hard failure" azero) - ("" " 1, soft failure" aone)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it b} ") - (radioButtons bfail - ("" " 1, print error messages" bone) - ("" " 0, suppress error messages" bzero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it c} ") - (radioButtons cfail - ("" " 1, print warning messages" cone) - ("" " 0, suppress warning messages" czero))) - htMakeDoneButton('"Continue", 'd02gafSolve) - htShowPage() - -d02gafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - mnp := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) - objValUnwrap htpLabelSpadValue(htPage, 'mnp) - np := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) - objValUnwrap htpLabelSpadValue(htPage, 'np) - lw := mnp * (3*n*n + 6*n + 2) + 4*n*n + 4*n - liw := mnp * (2*n + 1) + n*n + 4*n + 2 - tol := htpLabelInputString(htPage,'tol) - aerror := htpButtonValue(htPage,'afail) - afail := - aerror = 'azero => '0 - '1 - berror := htpButtonValue(htPage,'bfail) - bfail := - berror = 'bone => '1 - '0 - cerror := htpButtonValue(htPage,'cfail) - cfail := - cerror = 'cone => '1 - '0 - ifail := 100*cfail + 10*bfail + afail - n = '3 => d02gafDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter known or estimated ") - middle := STRCONC(middle,'"values of \htbitmap{yi} at a and b, ") - middle := STRCONC(middle,"{\it U(n,2)}. [\htbitmap{yi}(a) in the first ") - middle := STRCONC(middle,"column, \htbitmap{yi}(b) in the second.] ") - middle := STRCONC(middle,"\newline ") - uList := - "append"/[fb(i) for i in 1..n] where fb(i) == - labelList := - "append"/[fc(i,j) for j in 1..2] where fc(i,j) == - unam := INTERN STRCONC ('"u",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, unam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - uList := [['text,:middle],:uList] - mid := ('"\blankline \menuitemstyle{} \tab{2} Enter {\it V(n,2)}. ") - mid := STRCONC(mid,'"If U(i,j) is known V(i,j) ") - mid := STRCONC(mid,'"= 0.0, else V(i,j) = 1.0. \newline ") - vList := - "append"/[fd(i) for i in 1..n] where fd(i) == - labelList := - "append"/[fe(i,j) for j in 1..2] where fe(i,j) == - vnam := INTERN STRCONC ('"v",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, vnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - vList := [['text,:mid],:vList] - xList := - "append"/[ff(i) for i in 1..mnp] where ff(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, "0.0", xnam, 'F]]] - end := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial mesh ") - end := STRCONC(end,'"{\it X(mnp)}: \newline ") - xList := [['text,:end],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:uList,:vList,:xList] - page := htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions (i.e. the derivatives) below as functions of " - htSay '"Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02gafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02gafDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) == - n := '3 - page := htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions (i.e. the derivatives) below ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (42 "Y[2]" f1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (42 "Y[3]" f2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (42 "-Y[1]*Y[3]-0.2*(1-Y[2]*Y[2])" f3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter known or estimated values of \htbitmap{yi} at a and b,") - (text . " {\it U(n,2)}. ") - (text . " [\htbitmap{yi}(a) in the first column, \htbitmap{yi}(b) ") - (text . "in the second.] \newline ") - (bcStrings (6 "0" u11 F)) - (bcStrings (6 "10" u21 F)) - (text . "\newline ") - (bcStrings (6 "0" u12 F)) - (bcStrings (6 "1" u22 F)) - (text . "\newline ") - (bcStrings (6 "0" u13 F)) - (bcStrings (6 "0" u23 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter {\it V(n,2)}. ") - (text . "If U(i,j) is known V(i,j) = 0.0, else V(i,j) = 1.0: \newline") - (bcStrings (6 "0.0" v11 F)) - (bcStrings (6 "1.0" v21 F)) - (text . "\newline ") - (bcStrings (6 "0.0" v12 F)) - (bcStrings (6 "0.0" v22 F)) - (text . "\newline ") - (bcStrings (6 "1.0" v13 F)) - (bcStrings (6 "1.0" v23 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the initial mesh {\it X(mnp)}: ") - (text . "\newline ") - (bcStrings (8 "0.0" x1 F)) - (bcStrings (8 "0.4" x2 F)) - (bcStrings (8 "0.8" x3 F)) - (bcStrings (8 "1.2" x4 F)) - (bcStrings (8 "1.6" x5 F)) - (bcStrings (8 "2.0" x6 F)) - (bcStrings (8 "2.4" x7 F)) - (bcStrings (8 "2.8" x8 F)) - (bcStrings (8 "3.2" x9 F)) - (bcStrings (8 "3.6" x10 F)) - (bcStrings (8 "4.0" x11 F)) - (bcStrings (8 "4.4" x12 F)) - (bcStrings (8 "4.8" x13 F)) - (bcStrings (8 "5.2" x14 F)) - (bcStrings (8 "5.6" x15 F)) - (bcStrings (8 "6.0" x16 F)) - (bcStrings (8 "6.4" x17 F)) - (bcStrings (8 "6.8" x18 F)) - (bcStrings (8 "7.2" x19 F)) - (bcStrings (8 "7.6" x20 F)) - (bcStrings (8 "8.0" x21 F)) - (bcStrings (8 "8.4" x22 F)) - (bcStrings (8 "8.8" x23 F)) - (bcStrings (8 "9.2" x24 F)) - (bcStrings (8 "9.6" x25 F)) - (bcStrings (8 "10.0" x26 F)) - (bcStrings (8 "0.0" x27 F)) - (bcStrings (8 "0.0" x28 F)) - (bcStrings (8 "0.0" x29 F)) - (bcStrings (8 "0.0" x30 F)) - (bcStrings (8 "0.0" x31 F)) - (bcStrings (8 "0.0" x32 F)) - (bcStrings (8 "0.0" x33 F)) - (bcStrings (8 "0.0" x34 F)) - (bcStrings (8 "0.0" x35 F)) - (bcStrings (8 "0.0" x36 F)) - (bcStrings (8 "0.0" x37 F)) - (bcStrings (8 "0.0" x38 F)) - (bcStrings (8 "0.0" x39 F)) - (bcStrings (8 "0.0" x40 F)) - (bcStrings (8 "0.0" x41 F)) - (bcStrings (8 "0.0" x42 F)) - (bcStrings (8 "0.0" x43 F)) - (bcStrings (8 "0.0" x44 F)) - (bcStrings (8 "0.0" x45 F)) - (bcStrings (8 "0.0" x46 F)) - (bcStrings (8 "0.0" x47 F)) - (bcStrings (8 "0.0" x48 F)) - (bcStrings (8 "0.0" x49 F)) - (bcStrings (8 "0.0" x50 F)) - (bcStrings (8 "0.0" x51 F)) - (bcStrings (8 "0.0" x52 F)) - (bcStrings (8 "0.0" x53 F)) - (bcStrings (8 "0.0" x54 F)) - (bcStrings (8 "0.0" x55 F)) - (bcStrings (8 "0.0" x56 F)) - (bcStrings (8 "0.0" x57 F)) - (bcStrings (8 "0.0" x58 F)) - (bcStrings (8 "0.0" x59 F)) - (bcStrings (8 "0.0" x60 F)) - (bcStrings (8 "0.0" x61 F)) - (bcStrings (8 "0.0" x62 F)) - (bcStrings (8 "0.0" x63 F)) - (bcStrings (8 "0.0" x64 F))) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02gafGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02gafGen htPage == - n := htpProperty(htPage, 'n) - a := htpProperty(htPage, 'a) - b := htpProperty(htPage, 'b) - mnp := htpProperty(htPage, 'mnp) - np := htpProperty(htPage, 'np) - lw := htpProperty(htPage, 'lw) - liw := htpProperty(htPage, 'liw) - ifail := htpProperty(htPage,'ifail) - tol := htpProperty(htPage,'tol) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..mnp repeat - x := STRCONC((first y).1," ") - xList := [x,:xList] - y := rest y - xstring := bcwords2liststring xList - for i in 1..n repeat - for j in 1..2 repeat - v := STRCONC((first y).1," ") - rowList := [v,:rowList] - y := rest y - vList := [:vList,rowList] - rowList := [] - for i in 1..n repeat - for j in 1..2 repeat - u := STRCONC((first y).1," ") - rowList := [u,:rowList] - y := rest y - uList := [:uList,rowList] - rowList := [] - vList := reverse vList - uList := reverse uList - vstring := bcwords2liststring [bcwords2liststring x for x in vList] - ustring := bcwords2liststring [bcwords2liststring x for x in uList] - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - Y:='Y - prefix := STRCONC("d02gaf(",ustring,", ",vstring,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,a,", ",b,", ",tol,", ") - prefix := STRCONC(prefix,STRINGIMAGE mnp,", ",STRINGIMAGE lw,", ") - prefix := STRCONC(prefix,STRINGIMAGE liw,", [",xstring,"], ",STRINGIMAGE np) - end:=STRCONC (",",STRINGIMAGE ifail,",(",fstring,"::Vector Expression Float") - linkGen STRCONC (prefix,end,")::ASP7('FCN))") - -d02gbf() == - htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02gbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02gbf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02GBF solves a general linear two-point boundary value problem ") - (text . "for a system of n ODEs {\it y' = F(x)y + g(x)} on the range ") - (text . "[a,b] with boundary conditions {\it Cy(a) + Dy(b) = \gamma} ") - (text . "using a deferred correction technique.") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of equations in the system {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 2 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Left hand boundary point {\it a}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Right hand boundary {\it b}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" a F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0" b F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Max number of mesh points {\it mnp}:") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Number of points {\it np}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 70 mnp PI)) - (text . "\tab{34} ") - (bcStrings (10 0 np PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Accuracy required {\it tol}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-3" tol F)) - (text . "\blankline ") - (text . "\newline \tab{2} ") - (text . "Ifail is input in three components: ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it a} ") - (radioButtons afail - ("" " 0, hard failure" azero) - ("" " 1, soft failure" aone)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it b} ") - (radioButtons bfail - ("" " 1, print error messages" bone) - ("" " 0, suppress error messages" bzero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it c} ") - (radioButtons cfail - ("" " 1, print warning messages" cone) - ("" " 0, suppress warning messages" czero))) - htMakeDoneButton('"Continue", 'd02gbfSolve) - htShowPage() - -d02gbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - mnp := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) - objValUnwrap htpLabelSpadValue(htPage, 'mnp) - np := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) - objValUnwrap htpLabelSpadValue(htPage, 'np) - lw := mnp * (3*n*n + 5*n + 2) + 3*n*n + 5*n - liw := mnp * (2*n + 1) + n - tol := htpLabelInputString(htPage,'tol) - aerror := htpButtonValue(htPage,'afail) - afail := - aerror = 'azero => '0 - '1 - berror := htpButtonValue(htPage,'bfail) - bfail := - berror = 'bone => '1 - '0 - cerror := htpButtonValue(htPage,'cfail) - cfail := - cerror = 'cone => '1 - '0 - ifail := 100*cfail + 10*bfail + afail - n = '2 => d02gbfDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) - cList := - "append"/[fa(i,n) for i in 1..n] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - cnam := INTERN STRCONC ('"c",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, cnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix {\it D}: ") - middle := STRCONC(middle,"\newline ") - dList := - "append"/[fc(i,n) for i in 1..n] where fc(i,n) == - labelList := - "append"/[fd(i,j) for j in 1..n] where fd(i,j) == - dnam := INTERN STRCONC ('"d",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, dnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - dList := [['text,:middle],:dList] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the vector \gamma: ") - middle := STRCONC(middle,"\newline ") - gamList := - "append"/[fe(i) for i in 1..n] where fe(i) == - gamnam := INTERN STRCONC ('"gam",STRINGIMAGE i) - [['bcStrings,[6, 0, gamnam, 'F]]] - prefix := ('"\newline ") - gamList := [['text,:middle],:gamList] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") - middle := STRCONC(middle,"{\it F(x)} from the equation {\it y' =} ") - middle := STRCONC(middle,"{\it F(x)y + g(x)}: \newline ") - fList := - "append"/[ff(i,n) for i in 1..n] where ff(i,n) == - labelList := - "append"/[fg(i,j) for j in 1..n] where fg(i,j) == - fnam := INTERN STRCONC ('"f",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, fnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - fList := [['text,:middle],:fList] - mid := ('"\blankline \menuitemstyle{} \tab{2} Enter the vector {\it g(x)}: ") - mid := STRCONC(mid,'"\newline ") - gList := - "append"/[fh(i) for i in 1..n] where fh(i) == - gnam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['bcStrings,[6, 0, gnam, 'F]]] - prefix := ('"\newline ") - gList := [['text,:middle],:gList] - xList := - "append"/[fi(i) for i in 1..mnp] where fi(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, "0.0", xnam, 'F]]] - end := ('"\blankline \menuitemstyle{} \tab{2} The initial mesh {\it X(mnp)}") - end := STRCONC(end,'", (all entries = 0 if np < 4): \newline ") - xList := [['text,:end],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :cList,:dList,:gamList,:fList,:gList,:xList] - page := htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the matrix {\it C} form the equation {\it Cy(a) + Dy(b)} " - htSay '"= \gamma \newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02gbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02gbfDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) == - n := '2 - page := htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it C} from the equation {\it Cy(a) + Dy(b)} = \gamma:") - (text . "\newline ") - (bcStrings (6 "1" c11 F)) - (bcStrings (6 "0" c12 F)) - (text . "\newline ") - (bcStrings (6 "0" c21 F)) - (bcStrings (6 "0" c22 F)) - (text . "\blankline \menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it D}: \newline ") - (bcStrings (6 "0" d11 F)) - (bcStrings (6 "0" d12 F)) - (text . "\newline ") - (bcStrings (6 "1" d21 F)) - (bcStrings (6 "0" d22 F)) - (text . "\blankline \menuitemstyle{}\tab{2}") - (text . "Enter the vector \gamma: \newline ") - (bcStrings (6 "0" gam1 F)) - (bcStrings (6 "1" gam2 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it F(x)} from the equation {\it y' = F(x)y + g(x)} : ") - (text . "\newline ") - (bcStrings (6 "0" f11 F)) - (bcStrings (6 "1" f12 F)) - (text . "\newline ") - (bcStrings (6 "0" f21 F)) - (bcStrings (6 "-10" f22 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the vector {\it g(x)}: ") - (text . "\newline ") - (bcStrings (6 "0" g1 F)) - (bcStrings (6 "0" g2 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} The initial mesh {\it X(mnp)}, ") - (text . "(all entries = 0 if np < 4): \newline ") - (bcStrings (8 "0.0" x1 F)) - (bcStrings (8 "0.0" x2 F)) - (bcStrings (8 "0.0" x3 F)) - (bcStrings (8 "0.0" x4 F)) - (bcStrings (8 "0.0" x5 F)) - (bcStrings (8 "0.0" x6 F)) - (bcStrings (8 "0.0" x7 F)) - (bcStrings (8 "0.0" x8 F)) - (bcStrings (8 "0.0" x9 F)) - (bcStrings (8 "0.0" x10 F)) - (bcStrings (8 "0.0" x11 F)) - (bcStrings (8 "0.0" x12 F)) - (bcStrings (8 "0.0" x13 F)) - (bcStrings (8 "0.0" x14 F)) - (bcStrings (8 "0.0" x15 F)) - (bcStrings (8 "0.0" x16 F)) - (bcStrings (8 "0.0" x17 F)) - (bcStrings (8 "0.0" x18 F)) - (bcStrings (8 "0.0" x19 F)) - (bcStrings (8 "0.0" x20 F)) - (bcStrings (8 "0.0" x21 F)) - (bcStrings (8 "0.0" x22 F)) - (bcStrings (8 "0.0" x23 F)) - (bcStrings (8 "0.0" x24 F)) - (bcStrings (8 "0.0" x25 F)) - (bcStrings (8 "0.0" x26 F)) - (bcStrings (8 "0.0" x27 F)) - (bcStrings (8 "0.0" x28 F)) - (bcStrings (8 "0.0" x29 F)) - (bcStrings (8 "0.0" x30 F)) - (bcStrings (8 "0.0" x31 F)) - (bcStrings (8 "0.0" x32 F)) - (bcStrings (8 "0.0" x33 F)) - (bcStrings (8 "0.0" x34 F)) - (bcStrings (8 "0.0" x35 F)) - (bcStrings (8 "0.0" x36 F)) - (bcStrings (8 "0.0" x37 F)) - (bcStrings (8 "0.0" x38 F)) - (bcStrings (8 "0.0" x39 F)) - (bcStrings (8 "0.0" x40 F)) - (bcStrings (8 "0.0" x41 F)) - (bcStrings (8 "0.0" x42 F)) - (bcStrings (8 "0.0" x43 F)) - (bcStrings (8 "0.0" x44 F)) - (bcStrings (8 "0.0" x45 F)) - (bcStrings (8 "0.0" x46 F)) - (bcStrings (8 "0.0" x47 F)) - (bcStrings (8 "0.0" x48 F)) - (bcStrings (8 "0.0" x49 F)) - (bcStrings (8 "0.0" x50 F)) - (bcStrings (8 "0.0" x51 F)) - (bcStrings (8 "0.0" x52 F)) - (bcStrings (8 "0.0" x53 F)) - (bcStrings (8 "0.0" x54 F)) - (bcStrings (8 "0.0" x55 F)) - (bcStrings (8 "0.0" x56 F)) - (bcStrings (8 "0.0" x57 F)) - (bcStrings (8 "0.0" x58 F)) - (bcStrings (8 "0.0" x59 F)) - (bcStrings (8 "0.0" x60 F)) - (bcStrings (8 "0.0" x61 F)) - (bcStrings (8 "0.0" x62 F)) - (bcStrings (8 "0.0" x63 F)) - (bcStrings (8 "0.0" x64 F)) - (bcStrings (8 "0.0" x65 F)) - (bcStrings (8 "0.0" x66 F)) - (bcStrings (8 "0.0" x67 F)) - (bcStrings (8 "0.0" x68 F)) - (bcStrings (8 "0.0" x69 F)) - (bcStrings (8 "0.0" x70 F))) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02gbfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02gbfGen htPage == - n := htpProperty(htPage, 'n) - a := htpProperty(htPage, 'a) - b := htpProperty(htPage, 'b) - mnp := htpProperty(htPage, 'mnp) - np := htpProperty(htPage, 'np) - lw := htpProperty(htPage, 'lw) - liw := htpProperty(htPage, 'liw) - ifail := htpProperty(htPage,'ifail) - tol := htpProperty(htPage,'tol) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..mnp repeat -- matrix - x := STRCONC((first y).1," ") - xList := [x,:xList] - y := rest y - xstring := bcwords2liststring xList - for i in 1..n repeat -- vector g - g := STRCONC((first y).1," ") - gList := [g,:gList] - y := rest y - gstring := bcwords2liststring gList - for i in 1..n repeat -- matrix F - for j in 1..n repeat - f := STRCONC((first y).1," ") - flist := [f,:flist] - y := rest y - fmatlist := [:fmatlist,flist] - flist := [] - fmatlist := reverse fmatlist - fmatstr := bcwords2liststring [bcwords2liststring x for x in fmatlist] - for i in 1..n repeat -- vector gamma - gam := STRCONC((first y).1," ") - gamList := [gam,:gamList] - y := rest y - gamstr := bcwords2liststring gamList - for i in 1..n repeat -- matrix D - for j in 1..n repeat - d := STRCONC((first y).1," ") - dlist := [d,:dlist] - y := rest y - dmatlist := [:dmatlist,dlist] - dlist := [] - dmatlist := reverse dmatlist - dmatstr := bcwords2liststring [bcwords2liststring x for x in dmatlist] - for i in 1..n repeat -- matrix C - for j in 1..n repeat - c := STRCONC((first y).1," ") - clist := [c,:clist] - y := rest y - cmatlist := [:cmatlist,clist] - clist := [] - cmatlist := reverse cmatlist - cmatstr := bcwords2liststring [bcwords2liststring x for x in cmatlist] - prefix := STRCONC("d02gbf(",STRINGIMAGE a,", ",STRINGIMAGE b,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",tol,", ",STRINGIMAGE mnp,", ") - prefix := STRCONC(prefix,STRINGIMAGE lw,", ",STRINGIMAGE liw,", ") - prefix := STRCONC(prefix,cmatstr,"::Matrix DoubleFloat,",dmatstr,"::Matrix DoubleFloat,[",gamstr,"]::Matrix DoubleFloat,[",xstring,"]::Matrix DoubleFloat, ") - mid := STRCONC(STRINGIMAGE np,", ",STRINGIMAGE ifail,", ") - end := STRCONC("(",fmatstr,"::Matrix(Expression(Float)))::ASP77(FCNF),(",gstring) - linkGen STRCONC(prefix,mid,end,"::Vector(Expression(Float)))::ASP78(FCNG))") - -d02kef() == - htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02kef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02kef| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02KEF finds a specified eigenvalue \htbitmap{lamdab} of a ") - (text . "regular or second-order Sturm-Liouville system ") - (text . "{\it(p(x)y')' + q(x; \lambda)y = 0} on a finite or infinite ") - (text . "range [a,b]; a Pruefer transformation and shooting method ") - (text . "are used; discontinuities in coefficient functions or their ") - (text . "derivatives are permitted. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of points in XPOINT {\it m}:") - (text . "\newline\tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Index of the `break-point' {\it match}:") - (text . "\newline\tab{2} ") - (bcStrings (6 0 match PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Index of the required eigenvalue {\it k}:") - (text . "\newline\tab{2} ") - (bcStrings (6 11 k PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Accuracy required {\it tol}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0001" tol F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Eigenvalue estimate {\it elam}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Scale of the problem {\it delam}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "14" elam F)) - (text . "\tab{34} ") - (bcStrings (10 "1" delam F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Max iterations {\it maxit}:") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Max COEFFN calls {\it maxfun}:") - (text . "\newline\tab{2} ") - (bcStrings (10 0 maxit PI)) - (text . "\tab{34} ") - (bcStrings (10 0 maxfun PI)) - (text . "\blankline ") - (text . "\tab{2} \newline {\it Note:} no bound is assumed ") - (text . "if maxit = 0 \blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd02kefSolve) - htShowPage() - -d02kefSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - match := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'match) - objValUnwrap htpLabelSpadValue(htPage, 'match) - k := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) - objValUnwrap htpLabelSpadValue(htPage, 'k) - tol := htpLabelInputString(htPage,'tol) - elam := htpLabelInputString(htPage,'elam) - delam := htpLabelInputString(htPage,'delam) - maxit := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) - objValUnwrap htpLabelSpadValue(htPage, 'maxit) - maxfun := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxfun) - objValUnwrap htpLabelSpadValue(htPage, 'maxfun) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'minusOne => '-1 - '1 - m = '5 =>d02kefDefaultSolve(htPage,match,k,tol,elam,delam,maxit,maxfun,ifail) - xpList := - "append"/[fa(i) for i in 1..m] where fa(i) == - xpnam := INTERN STRCONC ('"xp",STRINGIMAGE i) - [['bcStrings,[10, "0.0", xpnam, 'EM]]] - middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it p} for COEFFN:") - middle := STRCONC(middle,"\newline ") - cList := [['text,:middle],['bcStrings,[42, "0.0", 'c1, 'EM]]] - middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it q} for COEFFN:") - middle := STRCONC(middle,"\newline ") - c1List := [['text,:middle],['bcStrings,[42, "0.0", 'c2, 'EM]]] - cList := [:cList,:c1List] - middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it dqdl}") - middle := STRCONC(middle," for COEFFN: \newline ") - c2List := [['text,:middle],['bcStrings,[42, "0.0", 'c3, 'EM]]] - cList := [:cList,:c2List] - middle:=('"\blankline \menuitemstyle{} \tab{2} Values of YL(1) & YL(2) ") - middle := STRCONC(middle,"for BDYVAL: \newline ") - ylList := - "append"/[fb(i) for i in 1..2] where fb(i) == - ylnam := INTERN STRCONC ('"yl",STRINGIMAGE i) - [['bcStrings,[42, "0.0", ylnam, 'EM]]] - ylList := [['text,:middle],:ylList] - middle:=('"\blankline \menuitemstyle{} \tab{2} Values of YR(1) & YR(2) ") - middle := STRCONC(middle,"for BDYVAL: \newline ") - yrList := - "append"/[fc(i) for i in 1..2] where fc(i) == - yrnam := INTERN STRCONC ('"yr",STRINGIMAGE i) - [['bcStrings,[42, "0.0", yrnam, 'EM]]] - yrList := [['text,:middle],:yrList] - middle:=('"\blankline \menuitemstyle{} \tab{2} Maximum step size ") - middle := STRCONC(middle,"{\it hmax(2,m)}: \newline ") - hList := - "append"/[fd(i,m) for i in 1..2] where fd(i,m) == - labelList := - "append"/[fe(i,j) for j in 1..m] where fe(i,j) == - hnam := INTERN STRCONC ('"h",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, "0.0", hnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - hList := [['text,:middle],:hList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :xpList,:cList,:ylList,:yrList,:hList] - page := htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) - htSay '"\menuitemstyle{}\tab{2} Enter points where boundary " - htSay '"conditions are to be imposed {\it xpoint}: \newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02kefGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'match,match) - htpSetProperty(page,'k,k) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'elam,elam) - htpSetProperty(page,'delam,delam) - htpSetProperty(page,'maxit,maxit) - htpSetProperty(page,'maxfun,maxfun) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02kefDefaultSolve(htPage,match,k,tol,elam,delam,maxit,maxfun,ifail) == - m := '5 - page := htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter points where boundary conditions are to be imposed ") - (text . "{\it xpoint}: \newline ") - (bcStrings (10 "0.0" xp1 F)) - (bcStrings (10 "0.1" xp2 F)) - (bcStrings (10 "4**(1/3)" xp3 F)) - (bcStrings (10 "30.0" xp4 F)) - (bcStrings (10 "30.0" xp5 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Value of {\it p} for COEFFN: \newline ") - (bcStrings (42 "1.0" c1 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Value of {\it q} for COEFFN: \newline ") - (bcStrings (42 "ELAM-X-2.0/(X*X)" c2 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Value of {\it dqdl} for COEFFN: \newline ") - (bcStrings (42 "1.0" c3 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Values of YL(1) & YL(2) for BDYVAL: \newline ") - (bcStrings (42 "XL" yl1 EM)) - (bcStrings (42 "2.0" yl2 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Values of YR(1) & YR(2) for BDYVAL: \newline ") - (bcStrings (42 "1.0" yr1 EM)) - (bcStrings (42 "-sqrt(XR-ELAM)" yr2 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Maximum step size {\it hmax(2,m)}: \newline ") - (bcStrings (6 "0.0" h11 F)) - (bcStrings (6 "0.0" h12 F)) - (bcStrings (6 "0.0" h13 F)) - (bcStrings (6 "0.0" h14 F)) - (bcStrings (6 "0.0" h15 F)) - (text . "\newline ") - (bcStrings (6 "0.0" h21 F)) - (bcStrings (6 "0.0" h22 F)) - (bcStrings (6 "0.0" h23 F)) - (bcStrings (6 "0.0" h24 F)) - (bcStrings (6 "0.0" h25 F))) - htpSetProperty(page,'m,m) - htpSetProperty(page,'match,match) - htpSetProperty(page,'k,k) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'elam,elam) - htpSetProperty(page,'delam,delam) - htpSetProperty(page,'maxit,maxit) - htpSetProperty(page,'maxfun,maxfun) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02kefGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02kefGen htPage == - m := htpProperty(htPage, 'm) - match := htpProperty(htPage, 'match) - k := htpProperty(htPage, 'k) - tol := htpProperty(htPage, 'tol) - elam := htpProperty(htPage, 'elam) - delam := htpProperty(htPage, 'delam) - maxit := htpProperty(htPage, 'maxit) - maxfun := htpProperty(htPage, 'maxfun) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..m repeat - for j in 1..2 repeat - h := STRCONC((first y).1," ") - rowList := [h,:rowList] - y := rest y - hList := [:hList,rowList] - rowList := [] - hList := reverse hList - hstring := bcwords2liststring [bcwords2liststring x for x in hList] - for i in 1..2 repeat - for j in 1..2 repeat - b := STRCONC((first y).1," ") - rowList := [b,:rowList] - y := rest y - bList := [:bList,rowList] - rowList := [] - bList := reverse bList - bstring := bcwords2liststring [bcwords2liststring x for x in bList] - for i in 1..3 repeat - c := STRCONC((first y).1," ") - cList := [c,:cList] - y := rest y - cstring := bcwords2liststring cList - while y repeat - x := STRCONC((first y).1," ") - xList := [x,:xList] - y := rest y - xstring := bcwords2liststring xList - prefix := STRCONC("d02kef([",xstring,"]::Matrix DoubleFloat, ",STRINGIMAGE m) - prefix := STRCONC(prefix,", ",STRINGIMAGE k,", ",tol,", ",STRINGIMAGE maxfun) - prefix := STRCONC(prefix,", ",STRINGIMAGE match,", ",STRINGIMAGE elam,", ") - prefix:=STRCONC(prefix,STRINGIMAGE delam,", ",hstring,", ",STRINGIMAGE maxit) - end := STRCONC(", ",STRINGIMAGE ifail,",(",cstring,"::Vector(Expression Float))::ASP10(COEFFN)") - end := STRCONC(end,", (",bstring,"::Matrix Expression Float)::ASP80('BDYVAL))") - linkGen STRCONC (prefix,end) - -d02raf() == - htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXd02raf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02raf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D02RAF solves a two-point boundary value problem for a system ") - (text . "of {\it n} first-order ordinary differential equations ") - (text . "{\it \htbitmap{yi}'= \htbitmap{fi}(x,y)}, for {\it i} = 1,2,...,") - (text . "{\it n}, on the range [a,b] with {\it n} nonlinear boundary ") - (text . "conditions \htbitmap{gi}{\it (y(a),y(b)) = 0} for {\it i} = 1,2,") - (text . "...,{\it n} using a deferred correction technique and a Newton ") - (text . "iteration; the solution is computed on a mesh. A continuation ") - (text . "facility is provided for which a family of problems is solved ") - (text . "posed as {\it y' = f(x,y,\epsilon)} subject to the boundary ") - (text . "conditions {\it g(y(a),y(b),\epsilon) = 0}, where \epsilon ") - (text . "is the continuation parameter. The choice \epsilon = 0 should ") - (text . "define an easy problem to solve and \epsilon = 1 the problem ") - (text . "whose solution is required; a sequence of problems is solved ") - (text . "with 0 = \htbitmap{ep1} < \htbitmap{ep2} < ... \htbitmap{epp} ") - (text . "= 1 where {\it p} and the \htbitmap{epi} are chosen by D02RAF. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of differential equations {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The maximum number of points in the mesh {\it mnp}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 40 mnp PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of points in the initial mesh {\it np}:") - (text . "\newline\tab{2} ") - (bcStrings (5 17 np PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline Number of boundary conditions involving y(a) only ") - (text . "{\it numbeg}: \newline\tab{2} ") - (bcStrings (5 2 numbeg PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Boundary conditions involving both y(a) and ") - (text . "y(b) {\it nummix}: \newline\tab{2} ") - (text . "\newline\tab{2} ") - (bcStrings (5 0 nummix PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Absolute error tolerance {\it tol}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-4" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Do you wish to use an intial mesh or default values,{\it init} ") - (radioButtons init - ("" " default values" init_zero) - ("" " initial mesh" init_nonZero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "First dimension of y, {\it iy}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 3 iy PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Are JACOBF & JACOBG routines being supplied, {\it ijac}:") - (radioButtons ijac - ("" " yes" ijac_nonZero) - ("" " no" ijac_zero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Continuation facility {\it deleps}:") - (text . "\newline\tab{2} ") - (bcStrings (5 "0.1" deleps F)) - (text . "\newline\tab{2} ") - (text . "Note: For 0.0 \htbitmap{great=} deleps > 1.0, continuation ") - (text . "is not used. ") - (text . "\blankline ") - (text . "\newline \tab{2} ") - (text . "Ifail is input in three components: ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it a} ") - (radioButtons afail - ("" " 0, hard failure" azero) - ("" " 1, soft failure" aone)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it b} ") - (radioButtons bfail - ("" " 1, print error messages" bone) - ("" " 0, suppress error messages" bzero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it c} ") - (radioButtons cfail - ("" " 1, print warning messages" cone) - ("" " 0, suppress warning messages" czero))) - htMakeDoneButton('"Continue", 'd02rafSolve) - htShowPage() - -d02rafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - mnp := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) - objValUnwrap htpLabelSpadValue(htPage, 'mnp) - np := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) - objValUnwrap htpLabelSpadValue(htPage, 'np) - numbeg := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'numbeg) - objValUnwrap htpLabelSpadValue(htPage, 'numbeg) - nummix := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nummix) - objValUnwrap htpLabelSpadValue(htPage, 'nummix) - tol := htpLabelInputString(htPage,'tol) - mesh := htpButtonValue(htPage,'init) - init := - mesh = 'init_zero => '0 - '1 - iy := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iy) - objValUnwrap htpLabelSpadValue(htPage, 'iy) - jacob := htpButtonValue(htPage,'ijac) - ijac := - jacob = 'ijac_zero => '0 - '1 - deleps := htpLabelInputString(htPage,'deleps) - lwork := mnp*(3*n*n + 6*n +2) +4*n*n + 3*n - liwork := - ijac = 0 => mnp*(2*n +1) + n*n + 4*n +2 - mnp*(2*n +1) + n - aerror := htpButtonValue(htPage,'afail) - afail := - aerror = 'azero => '0 - '1 - berror := htpButtonValue(htPage,'bfail) - bfail := - berror = 'bone => '1 - '0 - cerror := htpButtonValue(htPage,'cfail) - cfail := - cerror = 'cone => '1 - '0 - ifail := 100*cfail + 10*bfail + afail - (n = '3 and init = '0 and iy = '3 and nummix = '0 and numbeg = '2 and np = '17 and mnp = '40) => d02rafDefaultSolve(htPage,mnp,np,numbeg,nummix,tol,init,iy,ijac,deleps,lwork,liwork,ifail) - init = '1 => d02rafCopOut() - funcList := - "append"/[fa(i) for i in 1..n] where fa(i) == - prefix := ('"\newline {\em Function f") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, fnam, 'EM]]] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the functions ") - middle := STRCONC(middle,'"\htbitmap{gi} below ") - middle := STRCONC(middle,'"as functions of YA[i] and YB[i]: \newline ") - gList := - "append"/[fb(i) for i in 1..n] where fb(i) == - prefix := ('"\newline {\em Function g") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - fnc := STRCONC ('"YA[",STRINGIMAGE i ,"]") - gnam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, fnc, gnam, 'EM]]] - gList := [['text,:middle],:gList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the array ") - mid := STRCONC(mid,'"{\it x(mnp)}: \newline ") - xList := - "append"/[fc(i) for i in 1..mnp] where fc(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[4, 0, xnam, 'F]]] - xList := [['text,:mid],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:gList,:xList] - page := htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions \htbitmap{fi} (i.e. the derivatives) below " - htSay '"as functions of Y[1]...Y[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d02rafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'numbeg,numbeg) - htpSetProperty(page,'nummix,nummix) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'init,init) - htpSetProperty(page,'iy,iy) - htpSetProperty(page,'ijac,ijac) - htpSetProperty(page,'deleps,deleps) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -d02rafDefaultSolve(htPage,mnp,np,numbeg,nummix,tol,init,iy,ijac,deleps,lwork,liwork,ifail) == - n := '3 - page := htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{fi} (i.e. the derivatives) below ") - (text . "as functions of Y[1]...Y[n]: ") - (text . "\newline {\em Function f1:} \space{1}") - (bcStrings (44 "Y[2]" f1 EM)) - (text . "\newline {\em Function f2:} \space{1}") - (bcStrings (44 "Y[3]" f2 EM)) - (text . "\newline {\em Function f3:} \space{1}") - (bcStrings (44 "-Y[1]*Y[3] - 2*EPS*(1-Y[2]*Y[2])" f3 EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{gi} below ") - (text . "as functions of YA[i] and YB[i]: ") - (text . "\newline {\em Function g1:} \space{1}") - (bcStrings (44 "YA[1]" g1 EM)) - (text . "\newline {\em Function g2:} \space{1}") - (bcStrings (44 "YA[2]" g2 EM)) - (text . "\newline {\em Function g3:} \space{1}") - (bcStrings (44 "YB[2] -1" g3 EM)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the array {\it x(mnp)}: \newline ") - (bcStrings (4 "0.0" x1 F)) - (bcStrings (4 "0.0" x2 F)) - (bcStrings (4 "0.0" x3 F)) - (bcStrings (4 "0.0" x4 F)) - (bcStrings (4 "0.0" x5 F)) - (bcStrings (4 "0.0" x6 F)) - (bcStrings (4 "0.0" x7 F)) - (bcStrings (4 "0.0" x8 F)) - (bcStrings (4 "0.0" x9 F)) - (bcStrings (4 "0.0" x10 F)) - (bcStrings (4 "0.0" x11 F)) - (bcStrings (4 "0.0" x12 F)) - (bcStrings (4 "0.0" x13 F)) - (bcStrings (4 "0.0" x14 F)) - (bcStrings (4 "0.0" x15 F)) - (bcStrings (4 "0.0" x16 F)) - (bcStrings (4 "10.0" x17 F)) - (bcStrings (4 "0.0" x18 F)) - (bcStrings (4 "0.0" x19 F)) - (bcStrings (4 "0.0" x20 F)) - (bcStrings (4 "0.0" x21 F)) - (bcStrings (4 "0.0" x22 F)) - (bcStrings (4 "0.0" x23 F)) - (bcStrings (4 "0.0" x24 F)) - (bcStrings (4 "0.0" x25 F)) - (bcStrings (4 "0.0" x26 F)) - (bcStrings (4 "0.0" x27 F)) - (bcStrings (4 "0.0" x28 F)) - (bcStrings (4 "0.0" x29 F)) - (bcStrings (4 "0.0" x30 F)) - (bcStrings (4 "0.0" x31 F)) - (bcStrings (4 "0.0" x32 F)) - (bcStrings (4 "0.0" x33 F)) - (bcStrings (4 "0.0" x34 F)) - (bcStrings (4 "0.0" x35 F)) - (bcStrings (4 "0.0" x36 F)) - (bcStrings (4 "0.0" x37 F)) - (bcStrings (4 "0.0" x38 F)) - (bcStrings (4 "0.0" x39 F)) - (bcStrings (4 "0.0" x40 F))) - htpSetProperty(page,'n,n) - htpSetProperty(page,'mnp,mnp) - htpSetProperty(page,'np,np) - htpSetProperty(page,'numbeg,numbeg) - htpSetProperty(page,'nummix,nummix) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'init,init) - htpSetProperty(page,'iy,iy) - htpSetProperty(page,'ijac,ijac) - htpSetProperty(page,'deleps,deleps) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'d02rafGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d02rafGen htPage == - n := htpProperty(htPage, 'n) - mnp := htpProperty(htPage, 'mnp) - np := htpProperty(htPage, 'np) - numbeg := htpProperty(htPage, 'numbeg) - nummix := htpProperty(htPage, 'nummix) - tol := htpProperty(htPage, 'tol) - init := htpProperty(htPage, 'init) - iy := htpProperty(htPage, 'iy) - ijac := htpProperty(htPage, 'ijac) - deleps := htpProperty(htPage, 'deleps) - lwork := htpProperty(htPage, 'lwork) - liwork := htpProperty(htPage, 'liwork) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..mnp repeat - xtemp := STRCONC((first y).1," ") - xList := [xtemp,:xList] - y := rest y - xstring := bcwords2liststring xList - for i in 1..n repeat - gtemp := STRCONC((first y).1," ") - gList := [gtemp,:gList] - y := rest y - gstring := bcwords2liststring gList - while y repeat - f := STRCONC((first y).1," ") - fList := [f,:fList] - y := rest y - fstring := bcwords2liststring fList - prefix := STRCONC("d02raf(",STRINGIMAGE n,", ",STRINGIMAGE mnp,", ") - prefix := STRCONC(prefix,STRINGIMAGE numbeg,", ",STRINGIMAGE nummix,", ") - prefix := STRCONC(prefix,tol,", ",STRINGIMAGE init,", ",STRINGIMAGE iy,", ") - middle:= STRCONC(STRINGIMAGE ijac,", ",STRINGIMAGE lwork,", ") - middle := STRCONC(middle,STRINGIMAGE liwork,", ",STRINGIMAGE np,", [") - middle := STRCONC(middle,xstring,"],[[0.0 for i in 1..", STRINGIMAGE mnp) - middle := STRCONC(middle,"] for j in 1..",STRINGIMAGE iy,"]") - middle := STRCONC(middle,":: Matrix DoubleFloat,",STRINGIMAGE deleps,", ") - middle := STRCONC(middle,STRINGIMAGE ifail,", (",fstring,"::Vector ") - middle := STRCONC(middle,"Expression Float)::ASP41('FCN,'JACOBF,'JACEPS),(") - middle := STRCONC(middle,gstring,"::Vector Expression Float)::ASP42('G,'JACOBG,") - middle := STRCONC(middle,"'JACGEP))") - linkGen STRCONC(prefix,middle) - - -d02rafCopOut() == - htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\blankline ") - (text . "{\center{\em Hyperdoc interface not available for initial mesh}}") - (text . "\newline ") - (text . "{\center{\em Please use the command line.}}")) - htMakeDoneButton('"Continue",'d02raf) - htShowPage() diff --git a/src/interp/nag-d02.boot.pamphlet b/src/interp/nag-d02.boot.pamphlet new file mode 100644 index 00000000..93edfc46 --- /dev/null +++ b/src/interp/nag-d02.boot.pamphlet @@ -0,0 +1,2168 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-d02.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +d02bbf() == + htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02bbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02bbf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02BBF integrates a system of {\it n} ordinary differential ") + (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") + (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") + (text . "conditions using a Runge-Kutta-Merson method; the solution ") + (text . "may be output at specified points.") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Initial value of {\it x}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "0.0" x F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "End of integration range {\it xend}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "8.0" xend F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of differential equations {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Tolerance required {\it tol}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Error control indicator {\it irelab}:") + (radioButtons irelab + ("" " 0, mixed" mix) + ("" " 1, absolute" abs) + ("" " 2, relative" rel)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd02bbfSolve) + htShowPage() + +d02bbfSolve htPage == + x := htpLabelInputString(htPage,'x) + xend := htpLabelInputString(htPage,'xend) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + tol := htpLabelInputString(htPage,'tol) + control := htpButtonValue(htPage,'irelab) + irelab := + control = 'mix => '0 + control = 'abs => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'minusOne => '-1 + '1 + n = '3 => d02bbfDefaultSolve(htPage,x,xend,tol,irelab,ifail) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") + middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline \tab{2}") + yList := + "append"/[fb(i) for i in 1..n] where fb(i) == + ynam := INTERN STRCONC ('"u",STRINGIMAGE i) + [['bcStrings,[6, 0, ynam, 'F]]] + yList := [['text,:middle],:yList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") + mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline \tab{2}") + vList := [['bcStrings,[30, "0", 'out, 'EM]]] + vList := [['text,:mid],:vList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:yList,:vList] + page := htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions (i.e. the derivatives) below " + htSay '"as functions of Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02bbfGen) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'irelab,irelab) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02bbfDefaultSolve(htPage,x,xend,tol,irelab,ifail) == + n := '3 + page := htInitPage('"D02BBF - ODEs, IVP, Runge-Kutta-Merson method, over a range, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions (i.e. the derivatives) below ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (44 "tan(Y[3])" f1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the initial values of \htbitmap{yi}:") + (text . "\newline \tab{2}") + (bcStrings (8 "0.0" y1 EM)) + (bcStrings (8 "0.5" y2 EM)) + (bcStrings (8 "\%pi*0.2" y3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Intermediate values of {\it x} at which \htbitmap{yi} is required:") + (text . "\newline \tab{2}") + (bcStrings (30 "1,2,3,4,5,6,7,8" out EM))) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'irelab,irelab) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02bbfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02bbfGen htPage == + x := htpProperty(htPage, 'x) + xend := htpProperty(htPage, 'xend) + n := htpProperty(htPage, 'n) + tol := htpProperty(htPage, 'tol) + irelab := htpProperty(htPage, 'irelab) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + outp := ((first y).1) + oList := [outp,:oList] + y := rest y + ostring := bcwords2liststring oList + -- This is distictly horrible! OUTP is a comma-seperated string so we + -- count up the commas to see how many elements it has. We return this + -- quantity plus 1 since the ASP OUTPUT is always called at least once. + numberOfPoints := + ZEROP LENGTH(outp) => 1 + 2+COUNT(CHARACTER(44),outp) + for i in 1..n repeat + ytemp := STRCONC((first y).1," ") + yList := [ytemp,:yList] + y := rest y + ystring := bcwords2liststring yList + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + prefix := STRCONC("d02bbf(", xend,", ", STRINGIMAGE numberOfPoints, ", ",STRINGIMAGE n,", ",STRINGIMAGE irelab) + prefix := STRCONC(prefix,", ",x,", [", ystring,"],",tol) + prefix := STRCONC(prefix,", ",STRINGIMAGE ifail,",(") + end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN),(",ostring) + end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") + linkGen STRCONC(prefix,end) + +d02bhf() == + htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02bhf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02bhf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02BHF integrates a system of {\it n} ordinary differential ") + (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") + (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") + (text . "conditions using a Runge-Kutta-Merson method until a specified ") + (text . "function {\em g(x,y)} of the solution is zero. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Initial value of {\it x}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "0.0" x F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "End of integration range {\it xend}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "10.0" xend F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of differential equations {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Tolerance required {\it tol}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Error control indicator {\it irelab}:") + (radioButtons irelab + ("" " 0, mixed" mix) + ("" " 1, absolute" abs) + ("" " 2, relative" rel)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Upper bound on size of the interval {\it hmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" hmax F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd02bhfSolve) + htShowPage() + +d02bhfSolve htPage == + x := htpLabelInputString(htPage,'x) + xend := htpLabelInputString(htPage,'xend) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + tol := htpLabelInputString(htPage,'tol) + control := htpButtonValue(htPage,'irelab) + irelab := + control = 'mix => '0 + control = 'abs => '1 + '2 + hmax := htpLabelInputString(htPage,'hmax) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '3 => d02bhfDefaultSolve(htPage,x,xend,tol,irelab,hmax,ifail) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") + middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") + yList := + "append"/[fb(i) for i in 1..n] where fb(i) == + ynam := INTERN STRCONC ('"u",STRINGIMAGE i) + [['bcStrings,[6, 0, ynam, 'F]]] + yList := [['text,:middle],:yList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") + mid := STRCONC(mid,'"{\em g(x,y)}: \newline ") + vList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] + vList := [['text,:mid],:vList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:yList,:vList] + page := htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " + htSay '"as functions of Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02bhfGen) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'irelab,irelab) + htpSetProperty(page,'hmax,hmax) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02bhfDefaultSolve(htPage,x,xend,tol,irelab,hmax,ifail) == + n := '3 + page := htInitPage('"D02BHF - ODEs, IVP, Runge-Kutta-Merson method, until function of solution is zero",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (44 "tan(Y[3])" f1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the initial values of \htbitmap{yi}:") + (text . "\newline ") + (bcStrings (8 "0.5" y1 EM)) + (bcStrings (8 "0.5" y2 EM)) + (bcStrings (8 "\%pi*0.2" y3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the function below {\em g(x,y)}: ") + (text . "\newline ") + (bcStrings (30 "Y[1]" g EM))) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'irelab,irelab) + htpSetProperty(page,'hmax,hmax) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02bhfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02bhfGen htPage == + x := htpProperty(htPage, 'x) + xend := htpProperty(htPage, 'xend) + n := htpProperty(htPage, 'n) + tol := htpProperty(htPage, 'tol) + irelab := htpProperty(htPage, 'irelab) + hmax := htpProperty(htPage, 'hmax) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + g := ((first y).1) + y := rest y + for i in 1..n repeat + ytemp := STRCONC((first y).1," ") + yList := [ytemp,:yList] + y := rest y + ystring := bcwords2liststring yList + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + prefix := STRCONC("d02bhf(", xend,", ",STRINGIMAGE n,", ",STRINGIMAGE irelab) + mid := STRCONC(", ",hmax,", ",x,", [", ystring,"],") + mid := STRCONC(mid,tol,", ",STRINGIMAGE ifail,",(",g) + mid := STRCONC(mid,"::Expression Float)::ASP9('G),(") + end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN))") + linkGen STRCONC(prefix,mid,end) + + +d02cjf() == + htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02cjf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02cjf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02CJF integrates a system of {\it n} ordinary differential ") + (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for ") + (text . "{\it i} = 1,2,...,{\it n}, over a range with given initial ") + (text . "conditions using an Adams method until a specified ") + (text . "function {\em g(x,y)} of the solution is zero; the solution may ") + (text . "be output at specified points. \blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Initial value of {\it x}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "0.0" x F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "End of integration range {\it xend}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "10.0" xend F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of differential equations {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Tolerance required {\it tol}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Type of error test used {\it relabs}:") + (radioButtons relabs + ("" " D, default (mixed)" mix) + ("" " A, absolute" abs) + ("" " R, relative" rel)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd02cjfSolve) + htShowPage() + +d02cjfSolve htPage == + x := htpLabelInputString(htPage,'x) + xend := htpLabelInputString(htPage,'xend) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + tol := htpLabelInputString(htPage,'tol) + control := htpButtonValue(htPage,'relabs) + relabs := + control = 'mix => '"D" + control = 'abs => '"A" + '"R" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '3 => d02cjfDefaultSolve(htPage,x,xend,tol,relabs,ifail) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") + middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") + yList := + "append"/[fb(i) for i in 1..n] where fb(i) == + ynam := INTERN STRCONC ('"u",STRINGIMAGE i) + [['bcStrings,[6, 0, ynam, 'F]]] + yList := [['text,:middle],:yList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") + mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline ") + vList := [['bcStrings,[30, "2,4", 'out, 'EM]]] + vList := [['text,:mid],:vList] + midd := ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") + midd := STRCONC(midd,'"{\em g(x,y)}: \newline ") + uList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] + uList := [['text,:midd],:uList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:yList,:vList,:uList] + page := htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " + htSay '"as functions of Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02cjfGen) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'relabs,relabs) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02cjfDefaultSolve(htPage,x,xend,tol,relabs,ifail) == + n := '3 + page := htInitPage('"D02CJF - ODEs, IVP, Adams method, until function of solution is zero, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (44 "tan(Y[3])" f1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (44 "-0.032*tan(Y[3])/Y[2] -0.02*Y[2]/cos(Y[3])" f2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (44 "-0.032/(Y[2]**2)" f3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the initial values of \htbitmap{yi}:") + (text . "\newline ") + (bcStrings (8 "0.5" y1 EM)) + (bcStrings (8 "0.5" y2 EM)) + (bcStrings (8 "\%pi*0.2" y3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Intermediate") + (text . " values of {\it x} at which \htbitmap{yi} is required:") + (text . "\newline ") + (bcStrings (30 "2,4,6,8" out EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the function below {\em g(x,y)}: ") + (text . "\newline ") + (bcStrings (30 "Y[1]" g EM))) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'relabs,relabs) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02cjfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02cjfGen htPage == + x := htpProperty(htPage, 'x) + xend := htpProperty(htPage, 'xend) + n := htpProperty(htPage, 'n) + tol := htpProperty(htPage, 'tol) + relabs := htpProperty(htPage, 'relabs) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + g := ((first y).1) + y := rest y + outp := ((first y).1) + oList := [outp,:oList] + ostring := bcwords2liststring oList + -- This is distictly horrible! OUTP is a comma-seperated string so we + -- count up the commas to see how many elements it has. We return this + -- quantity plus 1 since the ASP OUTPUT is always called at least once. + numberOfPoints := + ZEROP LENGTH(outp) => 1 + 2+COUNT(CHARACTER(44),outp) + y := rest y + for i in 1..n repeat + ytemp := STRCONC((first y).1," ") + yList := [ytemp,:yList] + y := rest y + ystring := bcwords2liststring yList + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + prefix := STRCONC("d02cjf(",xend,", ",STRINGIMAGE numberOfPoints ,", ", STRINGIMAGE n,", ",tol,",_"",relabs) + mid := STRCONC("_", ",x ,", [", ystring,"],",STRINGIMAGE ifail) + mid := STRCONC(mid,",(",g,"::Expression Float)::ASP9('G),(",fstring) + end := STRCONC("::Vector Expression Float)::ASP7('FCN),(",ostring) + end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") + linkGen STRCONC(prefix,mid,end) + + + +d02ejf() == + htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02ejf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02ejf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02EJF integrates a system of {\em n} ordinary differential ") + (text . "equations, {\htbitmap{yi}}' = {\htbitmap{fi}}(x,y), for {\it i} ") + (text . "= 1,,2,...,{\it n}, over a range with given initial conditions") + (text . " using backward differentiation formulae until a specified ") + (text . "function {\em g(x,y)} of the solution is zero; the solution may ") + (text . "be output at specified points. \blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Initial value of {\it x}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "0.0" x F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "End of integration range {\it xend}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "10.0" xend F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of differential equations {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Tolerance required {\it tol}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Type of error test used {\it relabs}:") + (radioButtons relabs + ("" " D, default (mixed)" mix) + ("" " A, absolute" abs) + ("" " R, relative" rel)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd02ejfSolve) + htShowPage() + +d02ejfSolve htPage == + x := htpLabelInputString(htPage,'x) + xend := htpLabelInputString(htPage,'xend) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + tol := htpLabelInputString(htPage,'tol) + control := htpButtonValue(htPage,'relabs) + relabs := + control = 'mix => '"D" + control = 'abs => '"A" + '"R" + iw := (n + 12) * n + 50 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '3 => d02ejfDefaultSolve(htPage,x,xend,tol,relabs,iw,ifail) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial ") + middle := STRCONC(middle,'"values of \htbitmap{yi}: \newline ") + yList := + "append"/[fb(i) for i in 1..n] where fb(i) == + ynam := INTERN STRCONC ('"u",STRINGIMAGE i) + [['bcStrings,[6, 0, ynam, 'F]]] + yList := [['text,:middle],:yList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Intermediate values of {\it x}") + mid := STRCONC(mid,'" at which \htbitmap{yi} is required: \newline ") + vList := [['bcStrings,[30, "2,4,6,8", 'out, 'EM]]] + vList := [['text,:mid],:vList] + midd := ('"\blankline \menuitemstyle{} \tab{2} Enter the function below ") + midd := STRCONC(midd,'"{\em g(x,y)}: \newline ") + uList := [['bcStrings,[30, '"Y[1]", 'g, 'EM]]] + uList := [['text,:midd],:uList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:yList,:vList,:uList] + page := htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions (i.e. the derivatives) below \htbitmap{fi} " + htSay '"as functions of Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htSay '"\blankline {\em Note:} PEDERV is automatically generated using the vector " + htSay '"of derivatives given above. " + htMakeDoneButton('"Continue",'d02ejfGen) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'relabs,relabs) + htpSetProperty(page,'iw,iw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02ejfDefaultSolve(htPage,x,xend,tol,relabs,iw,ifail) == + n := '3 + page := htInitPage('"D02EJF - ODEs, stiff IVP, BDF method, until function of solution is zero, intermediate output",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions (i.e. the derivatives) below \htbitmap{fi} ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (44 "-0.04*Y[1]+1.0E4*Y[2]*Y[3]" f1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (44 "0.04*Y[1]-1.0E4*Y[2]*Y[3]-3.0E7*Y[2]*Y[2]" f2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (44 "3.0E7*Y[2]*Y[2]" f3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the initial values of \htbitmap{yi}:") + (text . "\newline ") + (bcStrings (8 "1.0" y1 EM)) + (bcStrings (8 "0.0" y2 EM)) + (bcStrings (8 "0.0" y3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Intermediate") + (text . " values of {\it x} at which \htbitmap{yi} is required:") + (text . "\newline ") + (bcStrings (30 "2,4,6,8" out EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the function below {\em g(x,y)}: ") + (text . "\newline ") + (bcStrings (30 "Y[1]-0.9" g EM)) + (text . "\blankline ") + (text . "{\em Note:} PEDERV is automatically generated using the vector ") + (text . "of derivatives given above. ")) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xend,xend) + htpSetProperty(page,'n,n) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'relabs,relabs) + htpSetProperty(page,'iw,iw) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02ejfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02ejfGen htPage == + x := htpProperty(htPage, 'x) + xend := htpProperty(htPage, 'xend) + n := htpProperty(htPage, 'n) + tol := htpProperty(htPage, 'tol) + relabs := htpProperty(htPage, 'relabs) + iw := htpProperty(htPage, 'iw) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + g := ((first y).1) + y := rest y + outp := ((first y).1) + oList := [outp,:oList] + ostring := bcwords2liststring oList + -- This is distictly horrible! OUTP is a comma-seperated string so we + -- count up the commas to see how many elements it has. We return this + -- quantity plus 1 since the ASP OUTPUT is always called at least once. + numberOfPoints := + ZEROP LENGTH(outp) => 1 + 2+COUNT(CHARACTER(44),outp) + y := rest y + for i in 1..n repeat + ytemp := STRCONC((first y).1," ") + yList := [ytemp,:yList] + y := rest y + ystring := bcwords2liststring yList + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + prefix := STRCONC("d02ejf(",xend,", ",STRINGIMAGE numberOfPoints,", ", STRINGIMAGE n,",_"",relabs,"_", ") + mid:=STRCONC(STRINGIMAGE iw,", ",x ,", [", ystring,"], ",tol,", ") + mid := STRCONC(mid,STRINGIMAGE ifail,",(",g,"::Expression Float)::ASP9(G),(") + end := STRCONC(fstring,"::Vector Expression Float)::ASP7('FCN),(",fstring) + end := STRCONC(end,"::Vector Expression Float)::ASP31('PEDERV),(",ostring) + end := STRCONC(end,"::Vector MachineFloat)::ASP8('OUTPUT))") + linkGen STRCONC(prefix,mid,end) + +d02gaf() == + htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02gaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02gaf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02GAF solves a two-point boundary value problem for a system ") + (text . "of n ODEs \center{\htbitmap{d02gaf},} for i = 1,2,...,n, on ") + (text . "the range [a,b] with assigned boundary conditions using a ") + (text . "deferred correction technique and a Newton iteration; ") + (text . "the solution is computed on a mesh. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of equations in the system {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Left hand boundary point {\it a}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Right hand boundary {\it b}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (10 "10.0" b F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Max number of mesh points {\it mnp}:") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Number of points {\it np} ({\it np} = 0 or {\it np} ") + (text . "\htbitmap{great=} 4): ") + (text . "\newline\tab{2} ") + (bcStrings (10 64 mnp PI)) + (text . "\tab{34} ") + (bcStrings (10 26 np PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Accuracy required {\it tol}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-3" tol F)) + (text . "\blankline ") + (text . "\newline \tab{2} ") + (text . "Ifail is input in three components: ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it a} ") + (radioButtons afail + ("" " 0, hard failure" azero) + ("" " 1, soft failure" aone)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it b} ") + (radioButtons bfail + ("" " 1, print error messages" bone) + ("" " 0, suppress error messages" bzero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it c} ") + (radioButtons cfail + ("" " 1, print warning messages" cone) + ("" " 0, suppress warning messages" czero))) + htMakeDoneButton('"Continue", 'd02gafSolve) + htShowPage() + +d02gafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + mnp := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) + objValUnwrap htpLabelSpadValue(htPage, 'mnp) + np := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) + objValUnwrap htpLabelSpadValue(htPage, 'np) + lw := mnp * (3*n*n + 6*n + 2) + 4*n*n + 4*n + liw := mnp * (2*n + 1) + n*n + 4*n + 2 + tol := htpLabelInputString(htPage,'tol) + aerror := htpButtonValue(htPage,'afail) + afail := + aerror = 'azero => '0 + '1 + berror := htpButtonValue(htPage,'bfail) + bfail := + berror = 'bone => '1 + '0 + cerror := htpButtonValue(htPage,'cfail) + cfail := + cerror = 'cone => '1 + '0 + ifail := 100*cfail + 10*bfail + afail + n = '3 => d02gafDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter known or estimated ") + middle := STRCONC(middle,'"values of \htbitmap{yi} at a and b, ") + middle := STRCONC(middle,"{\it U(n,2)}. [\htbitmap{yi}(a) in the first ") + middle := STRCONC(middle,"column, \htbitmap{yi}(b) in the second.] ") + middle := STRCONC(middle,"\newline ") + uList := + "append"/[fb(i) for i in 1..n] where fb(i) == + labelList := + "append"/[fc(i,j) for j in 1..2] where fc(i,j) == + unam := INTERN STRCONC ('"u",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, unam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + uList := [['text,:middle],:uList] + mid := ('"\blankline \menuitemstyle{} \tab{2} Enter {\it V(n,2)}. ") + mid := STRCONC(mid,'"If U(i,j) is known V(i,j) ") + mid := STRCONC(mid,'"= 0.0, else V(i,j) = 1.0. \newline ") + vList := + "append"/[fd(i) for i in 1..n] where fd(i) == + labelList := + "append"/[fe(i,j) for j in 1..2] where fe(i,j) == + vnam := INTERN STRCONC ('"v",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, vnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + vList := [['text,:mid],:vList] + xList := + "append"/[ff(i) for i in 1..mnp] where ff(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, "0.0", xnam, 'F]]] + end := ('"\blankline \menuitemstyle{} \tab{2} Enter the initial mesh ") + end := STRCONC(end,'"{\it X(mnp)}: \newline ") + xList := [['text,:end],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:uList,:vList,:xList] + page := htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions (i.e. the derivatives) below as functions of " + htSay '"Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02gafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02gafDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) == + n := '3 + page := htInitPage('"D02GAF - ODEs, boundary value problem, finite difference technique with deferred correction, simple nonlinear problem", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions (i.e. the derivatives) below ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (42 "Y[2]" f1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (42 "Y[3]" f2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (42 "-Y[1]*Y[3]-0.2*(1-Y[2]*Y[2])" f3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter known or estimated values of \htbitmap{yi} at a and b,") + (text . " {\it U(n,2)}. ") + (text . " [\htbitmap{yi}(a) in the first column, \htbitmap{yi}(b) ") + (text . "in the second.] \newline ") + (bcStrings (6 "0" u11 F)) + (bcStrings (6 "10" u21 F)) + (text . "\newline ") + (bcStrings (6 "0" u12 F)) + (bcStrings (6 "1" u22 F)) + (text . "\newline ") + (bcStrings (6 "0" u13 F)) + (bcStrings (6 "0" u23 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter {\it V(n,2)}. ") + (text . "If U(i,j) is known V(i,j) = 0.0, else V(i,j) = 1.0: \newline") + (bcStrings (6 "0.0" v11 F)) + (bcStrings (6 "1.0" v21 F)) + (text . "\newline ") + (bcStrings (6 "0.0" v12 F)) + (bcStrings (6 "0.0" v22 F)) + (text . "\newline ") + (bcStrings (6 "1.0" v13 F)) + (bcStrings (6 "1.0" v23 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the initial mesh {\it X(mnp)}: ") + (text . "\newline ") + (bcStrings (8 "0.0" x1 F)) + (bcStrings (8 "0.4" x2 F)) + (bcStrings (8 "0.8" x3 F)) + (bcStrings (8 "1.2" x4 F)) + (bcStrings (8 "1.6" x5 F)) + (bcStrings (8 "2.0" x6 F)) + (bcStrings (8 "2.4" x7 F)) + (bcStrings (8 "2.8" x8 F)) + (bcStrings (8 "3.2" x9 F)) + (bcStrings (8 "3.6" x10 F)) + (bcStrings (8 "4.0" x11 F)) + (bcStrings (8 "4.4" x12 F)) + (bcStrings (8 "4.8" x13 F)) + (bcStrings (8 "5.2" x14 F)) + (bcStrings (8 "5.6" x15 F)) + (bcStrings (8 "6.0" x16 F)) + (bcStrings (8 "6.4" x17 F)) + (bcStrings (8 "6.8" x18 F)) + (bcStrings (8 "7.2" x19 F)) + (bcStrings (8 "7.6" x20 F)) + (bcStrings (8 "8.0" x21 F)) + (bcStrings (8 "8.4" x22 F)) + (bcStrings (8 "8.8" x23 F)) + (bcStrings (8 "9.2" x24 F)) + (bcStrings (8 "9.6" x25 F)) + (bcStrings (8 "10.0" x26 F)) + (bcStrings (8 "0.0" x27 F)) + (bcStrings (8 "0.0" x28 F)) + (bcStrings (8 "0.0" x29 F)) + (bcStrings (8 "0.0" x30 F)) + (bcStrings (8 "0.0" x31 F)) + (bcStrings (8 "0.0" x32 F)) + (bcStrings (8 "0.0" x33 F)) + (bcStrings (8 "0.0" x34 F)) + (bcStrings (8 "0.0" x35 F)) + (bcStrings (8 "0.0" x36 F)) + (bcStrings (8 "0.0" x37 F)) + (bcStrings (8 "0.0" x38 F)) + (bcStrings (8 "0.0" x39 F)) + (bcStrings (8 "0.0" x40 F)) + (bcStrings (8 "0.0" x41 F)) + (bcStrings (8 "0.0" x42 F)) + (bcStrings (8 "0.0" x43 F)) + (bcStrings (8 "0.0" x44 F)) + (bcStrings (8 "0.0" x45 F)) + (bcStrings (8 "0.0" x46 F)) + (bcStrings (8 "0.0" x47 F)) + (bcStrings (8 "0.0" x48 F)) + (bcStrings (8 "0.0" x49 F)) + (bcStrings (8 "0.0" x50 F)) + (bcStrings (8 "0.0" x51 F)) + (bcStrings (8 "0.0" x52 F)) + (bcStrings (8 "0.0" x53 F)) + (bcStrings (8 "0.0" x54 F)) + (bcStrings (8 "0.0" x55 F)) + (bcStrings (8 "0.0" x56 F)) + (bcStrings (8 "0.0" x57 F)) + (bcStrings (8 "0.0" x58 F)) + (bcStrings (8 "0.0" x59 F)) + (bcStrings (8 "0.0" x60 F)) + (bcStrings (8 "0.0" x61 F)) + (bcStrings (8 "0.0" x62 F)) + (bcStrings (8 "0.0" x63 F)) + (bcStrings (8 "0.0" x64 F))) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02gafGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02gafGen htPage == + n := htpProperty(htPage, 'n) + a := htpProperty(htPage, 'a) + b := htpProperty(htPage, 'b) + mnp := htpProperty(htPage, 'mnp) + np := htpProperty(htPage, 'np) + lw := htpProperty(htPage, 'lw) + liw := htpProperty(htPage, 'liw) + ifail := htpProperty(htPage,'ifail) + tol := htpProperty(htPage,'tol) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..mnp repeat + x := STRCONC((first y).1," ") + xList := [x,:xList] + y := rest y + xstring := bcwords2liststring xList + for i in 1..n repeat + for j in 1..2 repeat + v := STRCONC((first y).1," ") + rowList := [v,:rowList] + y := rest y + vList := [:vList,rowList] + rowList := [] + for i in 1..n repeat + for j in 1..2 repeat + u := STRCONC((first y).1," ") + rowList := [u,:rowList] + y := rest y + uList := [:uList,rowList] + rowList := [] + vList := reverse vList + uList := reverse uList + vstring := bcwords2liststring [bcwords2liststring x for x in vList] + ustring := bcwords2liststring [bcwords2liststring x for x in uList] + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + Y:='Y + prefix := STRCONC("d02gaf(",ustring,", ",vstring,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,a,", ",b,", ",tol,", ") + prefix := STRCONC(prefix,STRINGIMAGE mnp,", ",STRINGIMAGE lw,", ") + prefix := STRCONC(prefix,STRINGIMAGE liw,", [",xstring,"], ",STRINGIMAGE np) + end:=STRCONC (",",STRINGIMAGE ifail,",(",fstring,"::Vector Expression Float") + linkGen STRCONC (prefix,end,")::ASP7('FCN))") + +d02gbf() == + htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02gbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02gbf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02GBF solves a general linear two-point boundary value problem ") + (text . "for a system of n ODEs {\it y' = F(x)y + g(x)} on the range ") + (text . "[a,b] with boundary conditions {\it Cy(a) + Dy(b) = \gamma} ") + (text . "using a deferred correction technique.") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of equations in the system {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 2 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Left hand boundary point {\it a}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Right hand boundary {\it b}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" a F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0" b F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Max number of mesh points {\it mnp}:") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Number of points {\it np}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 70 mnp PI)) + (text . "\tab{34} ") + (bcStrings (10 0 np PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Accuracy required {\it tol}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-3" tol F)) + (text . "\blankline ") + (text . "\newline \tab{2} ") + (text . "Ifail is input in three components: ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it a} ") + (radioButtons afail + ("" " 0, hard failure" azero) + ("" " 1, soft failure" aone)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it b} ") + (radioButtons bfail + ("" " 1, print error messages" bone) + ("" " 0, suppress error messages" bzero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it c} ") + (radioButtons cfail + ("" " 1, print warning messages" cone) + ("" " 0, suppress warning messages" czero))) + htMakeDoneButton('"Continue", 'd02gbfSolve) + htShowPage() + +d02gbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + mnp := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) + objValUnwrap htpLabelSpadValue(htPage, 'mnp) + np := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) + objValUnwrap htpLabelSpadValue(htPage, 'np) + lw := mnp * (3*n*n + 5*n + 2) + 3*n*n + 5*n + liw := mnp * (2*n + 1) + n + tol := htpLabelInputString(htPage,'tol) + aerror := htpButtonValue(htPage,'afail) + afail := + aerror = 'azero => '0 + '1 + berror := htpButtonValue(htPage,'bfail) + bfail := + berror = 'bone => '1 + '0 + cerror := htpButtonValue(htPage,'cfail) + cfail := + cerror = 'cone => '1 + '0 + ifail := 100*cfail + 10*bfail + afail + n = '2 => d02gbfDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) + cList := + "append"/[fa(i,n) for i in 1..n] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + cnam := INTERN STRCONC ('"c",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, cnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix {\it D}: ") + middle := STRCONC(middle,"\newline ") + dList := + "append"/[fc(i,n) for i in 1..n] where fc(i,n) == + labelList := + "append"/[fd(i,j) for j in 1..n] where fd(i,j) == + dnam := INTERN STRCONC ('"d",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, dnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + dList := [['text,:middle],:dList] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the vector \gamma: ") + middle := STRCONC(middle,"\newline ") + gamList := + "append"/[fe(i) for i in 1..n] where fe(i) == + gamnam := INTERN STRCONC ('"gam",STRINGIMAGE i) + [['bcStrings,[6, 0, gamnam, 'F]]] + prefix := ('"\newline ") + gamList := [['text,:middle],:gamList] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") + middle := STRCONC(middle,"{\it F(x)} from the equation {\it y' =} ") + middle := STRCONC(middle,"{\it F(x)y + g(x)}: \newline ") + fList := + "append"/[ff(i,n) for i in 1..n] where ff(i,n) == + labelList := + "append"/[fg(i,j) for j in 1..n] where fg(i,j) == + fnam := INTERN STRCONC ('"f",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, fnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + fList := [['text,:middle],:fList] + mid := ('"\blankline \menuitemstyle{} \tab{2} Enter the vector {\it g(x)}: ") + mid := STRCONC(mid,'"\newline ") + gList := + "append"/[fh(i) for i in 1..n] where fh(i) == + gnam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['bcStrings,[6, 0, gnam, 'F]]] + prefix := ('"\newline ") + gList := [['text,:middle],:gList] + xList := + "append"/[fi(i) for i in 1..mnp] where fi(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, "0.0", xnam, 'F]]] + end := ('"\blankline \menuitemstyle{} \tab{2} The initial mesh {\it X(mnp)}") + end := STRCONC(end,'", (all entries = 0 if np < 4): \newline ") + xList := [['text,:end],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :cList,:dList,:gamList,:fList,:gList,:xList] + page := htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the matrix {\it C} form the equation {\it Cy(a) + Dy(b)} " + htSay '"= \gamma \newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02gbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02gbfDefaultSolve(htPage,a,b,mnp,np,lw,liw,tol,ifail) == + n := '2 + page := htInitPage('"D02GBF - ODEs, boundary value problem, finite difference technique with deferred correction, general nonlinear problem", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it C} from the equation {\it Cy(a) + Dy(b)} = \gamma:") + (text . "\newline ") + (bcStrings (6 "1" c11 F)) + (bcStrings (6 "0" c12 F)) + (text . "\newline ") + (bcStrings (6 "0" c21 F)) + (bcStrings (6 "0" c22 F)) + (text . "\blankline \menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it D}: \newline ") + (bcStrings (6 "0" d11 F)) + (bcStrings (6 "0" d12 F)) + (text . "\newline ") + (bcStrings (6 "1" d21 F)) + (bcStrings (6 "0" d22 F)) + (text . "\blankline \menuitemstyle{}\tab{2}") + (text . "Enter the vector \gamma: \newline ") + (bcStrings (6 "0" gam1 F)) + (bcStrings (6 "1" gam2 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it F(x)} from the equation {\it y' = F(x)y + g(x)} : ") + (text . "\newline ") + (bcStrings (6 "0" f11 F)) + (bcStrings (6 "1" f12 F)) + (text . "\newline ") + (bcStrings (6 "0" f21 F)) + (bcStrings (6 "-10" f22 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the vector {\it g(x)}: ") + (text . "\newline ") + (bcStrings (6 "0" g1 F)) + (bcStrings (6 "0" g2 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} The initial mesh {\it X(mnp)}, ") + (text . "(all entries = 0 if np < 4): \newline ") + (bcStrings (8 "0.0" x1 F)) + (bcStrings (8 "0.0" x2 F)) + (bcStrings (8 "0.0" x3 F)) + (bcStrings (8 "0.0" x4 F)) + (bcStrings (8 "0.0" x5 F)) + (bcStrings (8 "0.0" x6 F)) + (bcStrings (8 "0.0" x7 F)) + (bcStrings (8 "0.0" x8 F)) + (bcStrings (8 "0.0" x9 F)) + (bcStrings (8 "0.0" x10 F)) + (bcStrings (8 "0.0" x11 F)) + (bcStrings (8 "0.0" x12 F)) + (bcStrings (8 "0.0" x13 F)) + (bcStrings (8 "0.0" x14 F)) + (bcStrings (8 "0.0" x15 F)) + (bcStrings (8 "0.0" x16 F)) + (bcStrings (8 "0.0" x17 F)) + (bcStrings (8 "0.0" x18 F)) + (bcStrings (8 "0.0" x19 F)) + (bcStrings (8 "0.0" x20 F)) + (bcStrings (8 "0.0" x21 F)) + (bcStrings (8 "0.0" x22 F)) + (bcStrings (8 "0.0" x23 F)) + (bcStrings (8 "0.0" x24 F)) + (bcStrings (8 "0.0" x25 F)) + (bcStrings (8 "0.0" x26 F)) + (bcStrings (8 "0.0" x27 F)) + (bcStrings (8 "0.0" x28 F)) + (bcStrings (8 "0.0" x29 F)) + (bcStrings (8 "0.0" x30 F)) + (bcStrings (8 "0.0" x31 F)) + (bcStrings (8 "0.0" x32 F)) + (bcStrings (8 "0.0" x33 F)) + (bcStrings (8 "0.0" x34 F)) + (bcStrings (8 "0.0" x35 F)) + (bcStrings (8 "0.0" x36 F)) + (bcStrings (8 "0.0" x37 F)) + (bcStrings (8 "0.0" x38 F)) + (bcStrings (8 "0.0" x39 F)) + (bcStrings (8 "0.0" x40 F)) + (bcStrings (8 "0.0" x41 F)) + (bcStrings (8 "0.0" x42 F)) + (bcStrings (8 "0.0" x43 F)) + (bcStrings (8 "0.0" x44 F)) + (bcStrings (8 "0.0" x45 F)) + (bcStrings (8 "0.0" x46 F)) + (bcStrings (8 "0.0" x47 F)) + (bcStrings (8 "0.0" x48 F)) + (bcStrings (8 "0.0" x49 F)) + (bcStrings (8 "0.0" x50 F)) + (bcStrings (8 "0.0" x51 F)) + (bcStrings (8 "0.0" x52 F)) + (bcStrings (8 "0.0" x53 F)) + (bcStrings (8 "0.0" x54 F)) + (bcStrings (8 "0.0" x55 F)) + (bcStrings (8 "0.0" x56 F)) + (bcStrings (8 "0.0" x57 F)) + (bcStrings (8 "0.0" x58 F)) + (bcStrings (8 "0.0" x59 F)) + (bcStrings (8 "0.0" x60 F)) + (bcStrings (8 "0.0" x61 F)) + (bcStrings (8 "0.0" x62 F)) + (bcStrings (8 "0.0" x63 F)) + (bcStrings (8 "0.0" x64 F)) + (bcStrings (8 "0.0" x65 F)) + (bcStrings (8 "0.0" x66 F)) + (bcStrings (8 "0.0" x67 F)) + (bcStrings (8 "0.0" x68 F)) + (bcStrings (8 "0.0" x69 F)) + (bcStrings (8 "0.0" x70 F))) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02gbfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02gbfGen htPage == + n := htpProperty(htPage, 'n) + a := htpProperty(htPage, 'a) + b := htpProperty(htPage, 'b) + mnp := htpProperty(htPage, 'mnp) + np := htpProperty(htPage, 'np) + lw := htpProperty(htPage, 'lw) + liw := htpProperty(htPage, 'liw) + ifail := htpProperty(htPage,'ifail) + tol := htpProperty(htPage,'tol) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..mnp repeat -- matrix + x := STRCONC((first y).1," ") + xList := [x,:xList] + y := rest y + xstring := bcwords2liststring xList + for i in 1..n repeat -- vector g + g := STRCONC((first y).1," ") + gList := [g,:gList] + y := rest y + gstring := bcwords2liststring gList + for i in 1..n repeat -- matrix F + for j in 1..n repeat + f := STRCONC((first y).1," ") + flist := [f,:flist] + y := rest y + fmatlist := [:fmatlist,flist] + flist := [] + fmatlist := reverse fmatlist + fmatstr := bcwords2liststring [bcwords2liststring x for x in fmatlist] + for i in 1..n repeat -- vector gamma + gam := STRCONC((first y).1," ") + gamList := [gam,:gamList] + y := rest y + gamstr := bcwords2liststring gamList + for i in 1..n repeat -- matrix D + for j in 1..n repeat + d := STRCONC((first y).1," ") + dlist := [d,:dlist] + y := rest y + dmatlist := [:dmatlist,dlist] + dlist := [] + dmatlist := reverse dmatlist + dmatstr := bcwords2liststring [bcwords2liststring x for x in dmatlist] + for i in 1..n repeat -- matrix C + for j in 1..n repeat + c := STRCONC((first y).1," ") + clist := [c,:clist] + y := rest y + cmatlist := [:cmatlist,clist] + clist := [] + cmatlist := reverse cmatlist + cmatstr := bcwords2liststring [bcwords2liststring x for x in cmatlist] + prefix := STRCONC("d02gbf(",STRINGIMAGE a,", ",STRINGIMAGE b,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",tol,", ",STRINGIMAGE mnp,", ") + prefix := STRCONC(prefix,STRINGIMAGE lw,", ",STRINGIMAGE liw,", ") + prefix := STRCONC(prefix,cmatstr,"::Matrix DoubleFloat,",dmatstr,"::Matrix DoubleFloat,[",gamstr,"]::Matrix DoubleFloat,[",xstring,"]::Matrix DoubleFloat, ") + mid := STRCONC(STRINGIMAGE np,", ",STRINGIMAGE ifail,", ") + end := STRCONC("(",fmatstr,"::Matrix(Expression(Float)))::ASP77(FCNF),(",gstring) + linkGen STRCONC(prefix,mid,end,"::Vector(Expression(Float)))::ASP78(FCNG))") + +d02kef() == + htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02kef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02kef| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02KEF finds a specified eigenvalue \htbitmap{lamdab} of a ") + (text . "regular or second-order Sturm-Liouville system ") + (text . "{\it(p(x)y')' + q(x; \lambda)y = 0} on a finite or infinite ") + (text . "range [a,b]; a Pruefer transformation and shooting method ") + (text . "are used; discontinuities in coefficient functions or their ") + (text . "derivatives are permitted. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of points in XPOINT {\it m}:") + (text . "\newline\tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Index of the `break-point' {\it match}:") + (text . "\newline\tab{2} ") + (bcStrings (6 0 match PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Index of the required eigenvalue {\it k}:") + (text . "\newline\tab{2} ") + (bcStrings (6 11 k PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Accuracy required {\it tol}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0001" tol F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Eigenvalue estimate {\it elam}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Scale of the problem {\it delam}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "14" elam F)) + (text . "\tab{34} ") + (bcStrings (10 "1" delam F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Max iterations {\it maxit}:") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Max COEFFN calls {\it maxfun}:") + (text . "\newline\tab{2} ") + (bcStrings (10 0 maxit PI)) + (text . "\tab{34} ") + (bcStrings (10 0 maxfun PI)) + (text . "\blankline ") + (text . "\tab{2} \newline {\it Note:} no bound is assumed ") + (text . "if maxit = 0 \blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd02kefSolve) + htShowPage() + +d02kefSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + match := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'match) + objValUnwrap htpLabelSpadValue(htPage, 'match) + k := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) + objValUnwrap htpLabelSpadValue(htPage, 'k) + tol := htpLabelInputString(htPage,'tol) + elam := htpLabelInputString(htPage,'elam) + delam := htpLabelInputString(htPage,'delam) + maxit := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) + objValUnwrap htpLabelSpadValue(htPage, 'maxit) + maxfun := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxfun) + objValUnwrap htpLabelSpadValue(htPage, 'maxfun) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'minusOne => '-1 + '1 + m = '5 =>d02kefDefaultSolve(htPage,match,k,tol,elam,delam,maxit,maxfun,ifail) + xpList := + "append"/[fa(i) for i in 1..m] where fa(i) == + xpnam := INTERN STRCONC ('"xp",STRINGIMAGE i) + [['bcStrings,[10, "0.0", xpnam, 'EM]]] + middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it p} for COEFFN:") + middle := STRCONC(middle,"\newline ") + cList := [['text,:middle],['bcStrings,[42, "0.0", 'c1, 'EM]]] + middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it q} for COEFFN:") + middle := STRCONC(middle,"\newline ") + c1List := [['text,:middle],['bcStrings,[42, "0.0", 'c2, 'EM]]] + cList := [:cList,:c1List] + middle:=('"\blankline \menuitemstyle{} \tab{2} Value of {\it dqdl}") + middle := STRCONC(middle," for COEFFN: \newline ") + c2List := [['text,:middle],['bcStrings,[42, "0.0", 'c3, 'EM]]] + cList := [:cList,:c2List] + middle:=('"\blankline \menuitemstyle{} \tab{2} Values of YL(1) & YL(2) ") + middle := STRCONC(middle,"for BDYVAL: \newline ") + ylList := + "append"/[fb(i) for i in 1..2] where fb(i) == + ylnam := INTERN STRCONC ('"yl",STRINGIMAGE i) + [['bcStrings,[42, "0.0", ylnam, 'EM]]] + ylList := [['text,:middle],:ylList] + middle:=('"\blankline \menuitemstyle{} \tab{2} Values of YR(1) & YR(2) ") + middle := STRCONC(middle,"for BDYVAL: \newline ") + yrList := + "append"/[fc(i) for i in 1..2] where fc(i) == + yrnam := INTERN STRCONC ('"yr",STRINGIMAGE i) + [['bcStrings,[42, "0.0", yrnam, 'EM]]] + yrList := [['text,:middle],:yrList] + middle:=('"\blankline \menuitemstyle{} \tab{2} Maximum step size ") + middle := STRCONC(middle,"{\it hmax(2,m)}: \newline ") + hList := + "append"/[fd(i,m) for i in 1..2] where fd(i,m) == + labelList := + "append"/[fe(i,j) for j in 1..m] where fe(i,j) == + hnam := INTERN STRCONC ('"h",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, "0.0", hnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + hList := [['text,:middle],:hList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :xpList,:cList,:ylList,:yrList,:hList] + page := htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) + htSay '"\menuitemstyle{}\tab{2} Enter points where boundary " + htSay '"conditions are to be imposed {\it xpoint}: \newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02kefGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'match,match) + htpSetProperty(page,'k,k) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'elam,elam) + htpSetProperty(page,'delam,delam) + htpSetProperty(page,'maxit,maxit) + htpSetProperty(page,'maxfun,maxfun) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02kefDefaultSolve(htPage,match,k,tol,elam,delam,maxit,maxfun,ifail) == + m := '5 + page := htInitPage('"D02KEF - 2nd order Sturm-Liouville problem, regular/singular system, finite/infinite range, eigenvalue and eigenfunction, user-specified break-points", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter points where boundary conditions are to be imposed ") + (text . "{\it xpoint}: \newline ") + (bcStrings (10 "0.0" xp1 F)) + (bcStrings (10 "0.1" xp2 F)) + (bcStrings (10 "4**(1/3)" xp3 F)) + (bcStrings (10 "30.0" xp4 F)) + (bcStrings (10 "30.0" xp5 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Value of {\it p} for COEFFN: \newline ") + (bcStrings (42 "1.0" c1 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Value of {\it q} for COEFFN: \newline ") + (bcStrings (42 "ELAM-X-2.0/(X*X)" c2 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Value of {\it dqdl} for COEFFN: \newline ") + (bcStrings (42 "1.0" c3 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Values of YL(1) & YL(2) for BDYVAL: \newline ") + (bcStrings (42 "XL" yl1 EM)) + (bcStrings (42 "2.0" yl2 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Values of YR(1) & YR(2) for BDYVAL: \newline ") + (bcStrings (42 "1.0" yr1 EM)) + (bcStrings (42 "-sqrt(XR-ELAM)" yr2 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Maximum step size {\it hmax(2,m)}: \newline ") + (bcStrings (6 "0.0" h11 F)) + (bcStrings (6 "0.0" h12 F)) + (bcStrings (6 "0.0" h13 F)) + (bcStrings (6 "0.0" h14 F)) + (bcStrings (6 "0.0" h15 F)) + (text . "\newline ") + (bcStrings (6 "0.0" h21 F)) + (bcStrings (6 "0.0" h22 F)) + (bcStrings (6 "0.0" h23 F)) + (bcStrings (6 "0.0" h24 F)) + (bcStrings (6 "0.0" h25 F))) + htpSetProperty(page,'m,m) + htpSetProperty(page,'match,match) + htpSetProperty(page,'k,k) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'elam,elam) + htpSetProperty(page,'delam,delam) + htpSetProperty(page,'maxit,maxit) + htpSetProperty(page,'maxfun,maxfun) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02kefGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02kefGen htPage == + m := htpProperty(htPage, 'm) + match := htpProperty(htPage, 'match) + k := htpProperty(htPage, 'k) + tol := htpProperty(htPage, 'tol) + elam := htpProperty(htPage, 'elam) + delam := htpProperty(htPage, 'delam) + maxit := htpProperty(htPage, 'maxit) + maxfun := htpProperty(htPage, 'maxfun) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..m repeat + for j in 1..2 repeat + h := STRCONC((first y).1," ") + rowList := [h,:rowList] + y := rest y + hList := [:hList,rowList] + rowList := [] + hList := reverse hList + hstring := bcwords2liststring [bcwords2liststring x for x in hList] + for i in 1..2 repeat + for j in 1..2 repeat + b := STRCONC((first y).1," ") + rowList := [b,:rowList] + y := rest y + bList := [:bList,rowList] + rowList := [] + bList := reverse bList + bstring := bcwords2liststring [bcwords2liststring x for x in bList] + for i in 1..3 repeat + c := STRCONC((first y).1," ") + cList := [c,:cList] + y := rest y + cstring := bcwords2liststring cList + while y repeat + x := STRCONC((first y).1," ") + xList := [x,:xList] + y := rest y + xstring := bcwords2liststring xList + prefix := STRCONC("d02kef([",xstring,"]::Matrix DoubleFloat, ",STRINGIMAGE m) + prefix := STRCONC(prefix,", ",STRINGIMAGE k,", ",tol,", ",STRINGIMAGE maxfun) + prefix := STRCONC(prefix,", ",STRINGIMAGE match,", ",STRINGIMAGE elam,", ") + prefix:=STRCONC(prefix,STRINGIMAGE delam,", ",hstring,", ",STRINGIMAGE maxit) + end := STRCONC(", ",STRINGIMAGE ifail,",(",cstring,"::Vector(Expression Float))::ASP10(COEFFN)") + end := STRCONC(end,", (",bstring,"::Matrix Expression Float)::ASP80('BDYVAL))") + linkGen STRCONC (prefix,end) + +d02raf() == + htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXd02raf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d02raf| '|NagOrdinaryDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D02RAF solves a two-point boundary value problem for a system ") + (text . "of {\it n} first-order ordinary differential equations ") + (text . "{\it \htbitmap{yi}'= \htbitmap{fi}(x,y)}, for {\it i} = 1,2,...,") + (text . "{\it n}, on the range [a,b] with {\it n} nonlinear boundary ") + (text . "conditions \htbitmap{gi}{\it (y(a),y(b)) = 0} for {\it i} = 1,2,") + (text . "...,{\it n} using a deferred correction technique and a Newton ") + (text . "iteration; the solution is computed on a mesh. A continuation ") + (text . "facility is provided for which a family of problems is solved ") + (text . "posed as {\it y' = f(x,y,\epsilon)} subject to the boundary ") + (text . "conditions {\it g(y(a),y(b),\epsilon) = 0}, where \epsilon ") + (text . "is the continuation parameter. The choice \epsilon = 0 should ") + (text . "define an easy problem to solve and \epsilon = 1 the problem ") + (text . "whose solution is required; a sequence of problems is solved ") + (text . "with 0 = \htbitmap{ep1} < \htbitmap{ep2} < ... \htbitmap{epp} ") + (text . "= 1 where {\it p} and the \htbitmap{epi} are chosen by D02RAF. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of differential equations {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The maximum number of points in the mesh {\it mnp}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 40 mnp PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of points in the initial mesh {\it np}:") + (text . "\newline\tab{2} ") + (bcStrings (5 17 np PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline Number of boundary conditions involving y(a) only ") + (text . "{\it numbeg}: \newline\tab{2} ") + (bcStrings (5 2 numbeg PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Boundary conditions involving both y(a) and ") + (text . "y(b) {\it nummix}: \newline\tab{2} ") + (text . "\newline\tab{2} ") + (bcStrings (5 0 nummix PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Absolute error tolerance {\it tol}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-4" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Do you wish to use an intial mesh or default values,{\it init} ") + (radioButtons init + ("" " default values" init_zero) + ("" " initial mesh" init_nonZero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "First dimension of y, {\it iy}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 3 iy PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Are JACOBF & JACOBG routines being supplied, {\it ijac}:") + (radioButtons ijac + ("" " yes" ijac_nonZero) + ("" " no" ijac_zero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Continuation facility {\it deleps}:") + (text . "\newline\tab{2} ") + (bcStrings (5 "0.1" deleps F)) + (text . "\newline\tab{2} ") + (text . "Note: For 0.0 \htbitmap{great=} deleps > 1.0, continuation ") + (text . "is not used. ") + (text . "\blankline ") + (text . "\newline \tab{2} ") + (text . "Ifail is input in three components: ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it a} ") + (radioButtons afail + ("" " 0, hard failure" azero) + ("" " 1, soft failure" aone)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it b} ") + (radioButtons bfail + ("" " 1, print error messages" bone) + ("" " 0, suppress error messages" bzero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it c} ") + (radioButtons cfail + ("" " 1, print warning messages" cone) + ("" " 0, suppress warning messages" czero))) + htMakeDoneButton('"Continue", 'd02rafSolve) + htShowPage() + +d02rafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + mnp := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mnp) + objValUnwrap htpLabelSpadValue(htPage, 'mnp) + np := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'np) + objValUnwrap htpLabelSpadValue(htPage, 'np) + numbeg := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'numbeg) + objValUnwrap htpLabelSpadValue(htPage, 'numbeg) + nummix := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nummix) + objValUnwrap htpLabelSpadValue(htPage, 'nummix) + tol := htpLabelInputString(htPage,'tol) + mesh := htpButtonValue(htPage,'init) + init := + mesh = 'init_zero => '0 + '1 + iy := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iy) + objValUnwrap htpLabelSpadValue(htPage, 'iy) + jacob := htpButtonValue(htPage,'ijac) + ijac := + jacob = 'ijac_zero => '0 + '1 + deleps := htpLabelInputString(htPage,'deleps) + lwork := mnp*(3*n*n + 6*n +2) +4*n*n + 3*n + liwork := + ijac = 0 => mnp*(2*n +1) + n*n + 4*n +2 + mnp*(2*n +1) + n + aerror := htpButtonValue(htPage,'afail) + afail := + aerror = 'azero => '0 + '1 + berror := htpButtonValue(htPage,'bfail) + bfail := + berror = 'bone => '1 + '0 + cerror := htpButtonValue(htPage,'cfail) + cfail := + cerror = 'cone => '1 + '0 + ifail := 100*cfail + 10*bfail + afail + (n = '3 and init = '0 and iy = '3 and nummix = '0 and numbeg = '2 and np = '17 and mnp = '40) => d02rafDefaultSolve(htPage,mnp,np,numbeg,nummix,tol,init,iy,ijac,deleps,lwork,liwork,ifail) + init = '1 => d02rafCopOut() + funcList := + "append"/[fa(i) for i in 1..n] where fa(i) == + prefix := ('"\newline {\em Function f") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := STRCONC ('"Y[",STRINGIMAGE i ,"]") + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, fnam, 'EM]]] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the functions ") + middle := STRCONC(middle,'"\htbitmap{gi} below ") + middle := STRCONC(middle,'"as functions of YA[i] and YB[i]: \newline ") + gList := + "append"/[fb(i) for i in 1..n] where fb(i) == + prefix := ('"\newline {\em Function g") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + fnc := STRCONC ('"YA[",STRINGIMAGE i ,"]") + gnam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, fnc, gnam, 'EM]]] + gList := [['text,:middle],:gList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the array ") + mid := STRCONC(mid,'"{\it x(mnp)}: \newline ") + xList := + "append"/[fc(i) for i in 1..mnp] where fc(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[4, 0, xnam, 'F]]] + xList := [['text,:mid],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:gList,:xList] + page := htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions \htbitmap{fi} (i.e. the derivatives) below " + htSay '"as functions of Y[1]...Y[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d02rafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'numbeg,numbeg) + htpSetProperty(page,'nummix,nummix) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'init,init) + htpSetProperty(page,'iy,iy) + htpSetProperty(page,'ijac,ijac) + htpSetProperty(page,'deleps,deleps) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +d02rafDefaultSolve(htPage,mnp,np,numbeg,nummix,tol,init,iy,ijac,deleps,lwork,liwork,ifail) == + n := '3 + page := htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{fi} (i.e. the derivatives) below ") + (text . "as functions of Y[1]...Y[n]: ") + (text . "\newline {\em Function f1:} \space{1}") + (bcStrings (44 "Y[2]" f1 EM)) + (text . "\newline {\em Function f2:} \space{1}") + (bcStrings (44 "Y[3]" f2 EM)) + (text . "\newline {\em Function f3:} \space{1}") + (bcStrings (44 "-Y[1]*Y[3] - 2*EPS*(1-Y[2]*Y[2])" f3 EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{gi} below ") + (text . "as functions of YA[i] and YB[i]: ") + (text . "\newline {\em Function g1:} \space{1}") + (bcStrings (44 "YA[1]" g1 EM)) + (text . "\newline {\em Function g2:} \space{1}") + (bcStrings (44 "YA[2]" g2 EM)) + (text . "\newline {\em Function g3:} \space{1}") + (bcStrings (44 "YB[2] -1" g3 EM)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the array {\it x(mnp)}: \newline ") + (bcStrings (4 "0.0" x1 F)) + (bcStrings (4 "0.0" x2 F)) + (bcStrings (4 "0.0" x3 F)) + (bcStrings (4 "0.0" x4 F)) + (bcStrings (4 "0.0" x5 F)) + (bcStrings (4 "0.0" x6 F)) + (bcStrings (4 "0.0" x7 F)) + (bcStrings (4 "0.0" x8 F)) + (bcStrings (4 "0.0" x9 F)) + (bcStrings (4 "0.0" x10 F)) + (bcStrings (4 "0.0" x11 F)) + (bcStrings (4 "0.0" x12 F)) + (bcStrings (4 "0.0" x13 F)) + (bcStrings (4 "0.0" x14 F)) + (bcStrings (4 "0.0" x15 F)) + (bcStrings (4 "0.0" x16 F)) + (bcStrings (4 "10.0" x17 F)) + (bcStrings (4 "0.0" x18 F)) + (bcStrings (4 "0.0" x19 F)) + (bcStrings (4 "0.0" x20 F)) + (bcStrings (4 "0.0" x21 F)) + (bcStrings (4 "0.0" x22 F)) + (bcStrings (4 "0.0" x23 F)) + (bcStrings (4 "0.0" x24 F)) + (bcStrings (4 "0.0" x25 F)) + (bcStrings (4 "0.0" x26 F)) + (bcStrings (4 "0.0" x27 F)) + (bcStrings (4 "0.0" x28 F)) + (bcStrings (4 "0.0" x29 F)) + (bcStrings (4 "0.0" x30 F)) + (bcStrings (4 "0.0" x31 F)) + (bcStrings (4 "0.0" x32 F)) + (bcStrings (4 "0.0" x33 F)) + (bcStrings (4 "0.0" x34 F)) + (bcStrings (4 "0.0" x35 F)) + (bcStrings (4 "0.0" x36 F)) + (bcStrings (4 "0.0" x37 F)) + (bcStrings (4 "0.0" x38 F)) + (bcStrings (4 "0.0" x39 F)) + (bcStrings (4 "0.0" x40 F))) + htpSetProperty(page,'n,n) + htpSetProperty(page,'mnp,mnp) + htpSetProperty(page,'np,np) + htpSetProperty(page,'numbeg,numbeg) + htpSetProperty(page,'nummix,nummix) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'init,init) + htpSetProperty(page,'iy,iy) + htpSetProperty(page,'ijac,ijac) + htpSetProperty(page,'deleps,deleps) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'d02rafGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d02rafGen htPage == + n := htpProperty(htPage, 'n) + mnp := htpProperty(htPage, 'mnp) + np := htpProperty(htPage, 'np) + numbeg := htpProperty(htPage, 'numbeg) + nummix := htpProperty(htPage, 'nummix) + tol := htpProperty(htPage, 'tol) + init := htpProperty(htPage, 'init) + iy := htpProperty(htPage, 'iy) + ijac := htpProperty(htPage, 'ijac) + deleps := htpProperty(htPage, 'deleps) + lwork := htpProperty(htPage, 'lwork) + liwork := htpProperty(htPage, 'liwork) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..mnp repeat + xtemp := STRCONC((first y).1," ") + xList := [xtemp,:xList] + y := rest y + xstring := bcwords2liststring xList + for i in 1..n repeat + gtemp := STRCONC((first y).1," ") + gList := [gtemp,:gList] + y := rest y + gstring := bcwords2liststring gList + while y repeat + f := STRCONC((first y).1," ") + fList := [f,:fList] + y := rest y + fstring := bcwords2liststring fList + prefix := STRCONC("d02raf(",STRINGIMAGE n,", ",STRINGIMAGE mnp,", ") + prefix := STRCONC(prefix,STRINGIMAGE numbeg,", ",STRINGIMAGE nummix,", ") + prefix := STRCONC(prefix,tol,", ",STRINGIMAGE init,", ",STRINGIMAGE iy,", ") + middle:= STRCONC(STRINGIMAGE ijac,", ",STRINGIMAGE lwork,", ") + middle := STRCONC(middle,STRINGIMAGE liwork,", ",STRINGIMAGE np,", [") + middle := STRCONC(middle,xstring,"],[[0.0 for i in 1..", STRINGIMAGE mnp) + middle := STRCONC(middle,"] for j in 1..",STRINGIMAGE iy,"]") + middle := STRCONC(middle,":: Matrix DoubleFloat,",STRINGIMAGE deleps,", ") + middle := STRCONC(middle,STRINGIMAGE ifail,", (",fstring,"::Vector ") + middle := STRCONC(middle,"Expression Float)::ASP41('FCN,'JACOBF,'JACEPS),(") + middle := STRCONC(middle,gstring,"::Vector Expression Float)::ASP42('G,'JACOBG,") + middle := STRCONC(middle,"'JACGEP))") + linkGen STRCONC(prefix,middle) + + +d02rafCopOut() == + htInitPage('"D02RAF - ODEs, general nonlinear boundary value problem, finite difference technique with deferred correction, continuation facility",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\blankline ") + (text . "{\center{\em Hyperdoc interface not available for initial mesh}}") + (text . "\newline ") + (text . "{\center{\em Please use the command line.}}")) + htMakeDoneButton('"Continue",'d02raf) + htShowPage() +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-d03.boot b/src/interp/nag-d03.boot deleted file mode 100644 index b8e727b9..00000000 --- a/src/interp/nag-d03.boot +++ /dev/null @@ -1,639 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -d03edf() == - htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd03edf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03edf| '|NagPartialDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D03EDF solves, by multigrid iteration, the seven point scheme ") - (text . "\newline \htbitmap{d03edf} \newline which arises from the ") - (text . "discretization of an elliptic partial differential equation of ") - (text . "the form \center{\htbitmap{d03edf1}} and its boundary conditions") - (text . ", defined on a rectangular region. This we can write in matrix ") - (text . "form as \newline \center{{\it Au =f}}") - (text . "\blankline") - (text . "\newline ") - (text . "Read the input file to see the example program. ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\spadcommand{)read d03edf \bound{s0}} ") - (text . "\blankline") - (text . "\newline ") - (text . "If you would like to enter a problem, ") - (text . "how would you like to input the matrices? ") - (radioButtons matrix - ("" " By entering individual entries" long) - ("" " By entering matrix names already defined on the command line" short))) - htMakeDoneButton('"Continue", 'd03edfControl) - htShowPage() - -d03edfControl(htPage) == - type := htpButtonValue(htPage,'matrix) - if (type = 'long) then - d03edfLong() - else - d03edfShort() - -d03edfLong() == - htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it x}-direction ") - (text . "{\it ngx}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 3 ngx PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it y}-direction ") - (text . "{\it ngy}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 3 ngy PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "First dimension of A, {\it lda}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 22 lda PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Maximum permitted number of multigrid iterations, {\it maxit}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 1 maxit PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Tolerance required, {\it acc}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-4" acc F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Output of printed information for routine {\it iout}:") - (radioButtons iout - ("" " 0 - no output" zero) - ("" " 1 - the solution \htbitmap{uij} {\it i} = 1,2,...,NGX; {\it j} = 1,2,...,NGY" one) - ("" " 2 - residual 2-norm after each iteration " two) - ("" " 3 - as for iout = 1 & iout = 2" three) - ("" " 4 - as for iout = 3, plus the final residual" four) - ("" " 5 - as for iout = 4, plus initial elements of A & RHS" five) - ("" " 6 - as for iout = 5, plus Galerkin coarse grid approximations" six) - ("" " 7 - as for iout = 6, plus the incomplete Crout decompositions" seven) - ("" " 8 - as for iout = 7, plus the residual after each iteration" eight)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" ifail_minusOne) - ("" " 1, Suppress error messages" ifail_one))) - htMakeDoneButton('"Continue", 'd03edfSolve) - htShowPage() - - -d03edfSolve htPage == - ngx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) - objValUnwrap htpLabelSpadValue(htPage, 'ngx) - ngy := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) - objValUnwrap htpLabelSpadValue(htPage, 'ngy) - lda := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) - objValUnwrap htpLabelSpadValue(htPage, 'lda) - maxit := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) - objValUnwrap htpLabelSpadValue(htPage, 'maxit) - acc := htpLabelInputString(htPage,'acc) - control := htpButtonValue(htPage,'iout) - iout := - control = 'zero => '0 - control = 'one => '1 - control = 'two => '2 - control = 'three => '3 - control = 'four => '4 - control = 'five => '5 - control = 'six => '6 - control = 'seven => '7 - '8 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'ifail_one => '1 - '-1 - aList := - "append"/[fa(i) for i in 1..lda] where fa(i) == - labelList := - "append"/[fb(i,j) for j in 1..7] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[5, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") - middle := STRCONC(middle,'"{\it rhs(lda)}: \newline ") - rList := - "append"/[fc(i) for i in 1..lda] where fc(i) == - rnam := INTERN STRCONC ('"r",STRINGIMAGE i) - [['bcStrings,[6, "0.0", rnam, 'F]]] - rList := [['text,:middle],:rList] - mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") - mid := STRCONC(mid,'" {\it ub(ngx*ngy)}: \newline ") - uList := - "append"/[fd(i) for i in 1..(ngx*ngy)] where fd(i) == - unam := INTERN STRCONC ('"u",STRINGIMAGE i) - [['bcStrings,[6, 0, unam, 'F]]] - uList := [['text,:mid],:uList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList,:rList,:uList] - page := htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the matrix {\it a(lda,7)}: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'d03edfLongGen) - htpSetProperty(page,'ngx,ngx) - htpSetProperty(page,'ngy,ngy) - htpSetProperty(page,'lda,lda) - htpSetProperty(page,'maxit,maxit) - htpSetProperty(page,'acc,acc) - htpSetProperty(page,'iout,iout) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d03edfLongGen htPage == - ngx := htpProperty(htPage, 'ngx) - ngy := htpProperty(htPage, 'ngy) - lda := htpProperty(htPage, 'lda) - maxit := htpProperty(htPage, 'maxit) - acc := htpProperty(htPage, 'acc) - iout := htpProperty(htPage, 'iout) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(ngx*ngy) repeat - utemp := STRCONC((first y).1," ") - uList := [utemp,:uList] - y := rest y - ustring := bcwords2liststring uList - for i in 1..lda repeat - rtemp := STRCONC((first y).1," ") - rList := [rtemp,:rList] - y := rest y - rstring := bcwords2liststring rList - for i in 1..lda repeat - for j in 1..7 repeat - v := STRCONC((first y).1," ") - rowList := [v,:rowList] - y := rest y - vList := [:vList,rowList] - rowList := [] - vList := reverse vList - astring := bcwords2liststring [bcwords2liststring x for x in vList] - prefix := STRCONC("d03edf(", STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE maxit,", ",acc) - mid := STRCONC(", ",STRINGIMAGE iout,", ",astring,"::Matrix DoubleFloat,[") - mid := STRCONC(mid,rstring,"],[",ustring,"],",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,mid) - -d03edfShort() == - htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it x}-direction ") - (text . "\htbitmap{nx}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 0 ngx PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it y}-direction ") - (text . "\htbitmap{ny}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 0 ngy PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "First dimension of A, {\it lda}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 0 lda PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Name of the array {\it a(lda,7)} defined on the command line: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "a" a EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Name of the array {\it rhs(lda)} defined on the command line: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "rhs" rhs EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Name of the array {\it ub(ngx*ngy)} defined on the command line:") - (text . "\newline\tab{2} ") - (bcStrings (10 "ub" ub EM)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Maximum permitted number of multigrid iterations, {\it maxit}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 0 maxit PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Tolerance required, {\it acc}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e-4" acc F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Output of printed information for routine {\it iout}:") - (radioButtons iout - ("" " 0 - no output" zero) - ("" " 1 - the solution \htbitmap{uij} {\it i} = 1,2,...,NGX; {\it j} = 1,2,...,NGY" one) - ("" " 2 - residual 2-norm after each iteration " two) - ("" " 3 - as for iout = 1 & iout = 2" three) - ("" " 4 - as for iout = 3, plus the final residual" four) - ("" " 5 - as for iout = 4, plus initial elements of A & RHS" five) - ("" " 6 - as for iout = 5, plus Galerkin coarse grid approximations" six) - ("" " 7 - as for iout = 6, plus the incomplete Crout decompositions" seven) - ("" " 8 - as for iout = 7, plus the residual after each iteration" eight)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" ifail_minusOne) - ("" " 1, Suppress error messages" ifail_one))) - htMakeDoneButton('"Continue", 'd03edfShortGen) - htShowPage() - - -d03edfShortGen htPage == - ngx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) - objValUnwrap htpLabelSpadValue(htPage, 'ngx) - ngy := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) - objValUnwrap htpLabelSpadValue(htPage, 'ngy) - lda := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) - objValUnwrap htpLabelSpadValue(htPage, 'lda) - maxit := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) - objValUnwrap htpLabelSpadValue(htPage, 'maxit) - a := htpLabelInputString(htPage, 'a) - rhs := htpLabelInputString(htPage, 'rhs) - ub := htpLabelInputString(htPage, 'ub) - acc := htpLabelInputString(htPage,'acc) - control := htpButtonValue(htPage,'iout) - iout := - control = 'zero => '0 - control = 'one => '1 - control = 'two => '2 - control = 'three => '3 - control = 'four => '4 - control = 'five => '5 - control = 'six => '6 - control = 'seven => '7 - '8 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'ifail_one => '1 - '-1 - prefix := STRCONC("d03edf(", STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE maxit,", ",acc) - mid := STRCONC(", ",STRINGIMAGE iout,", ",a,", ") - mid := STRCONC(mid,rhs,", ",ub,", ",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,mid) - - - -d03eef() == - htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd03eef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03eef| '|NagPartialDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D03EEF discretizes a second order linear elliptic partial ") - (text . "differential equation of the form \center{\htbitmap{d03eef}} ") - (text . "on a rectangular region \newline \tab{2} ") - (text . "{\it x}a \htbitmap{less=} {\it x} \htbitmap{less=} {\it x}b ") - (text . "\newline \tab{2} {\it y}a \htbitmap{less=} {\it y} ") - (text . "\htbitmap{less=} {\it y}b \newline subject to the boundary ") - (text . "conditions of the form \newline \htbitmap{d03eef1} \newline ") - (text . "where {\it \delta U/ \delta n} denotes the outward pointing ") - (text . "normal derivative on the boundary. The equation is said to be ") - (text . "elliptic if \center{\htbitmap{d03eef2}} \newline for all points ") - (text . "in the rectangular region. The seven-diagonal linear equations ") - (text . "produced are in a form suitable for passing directly to the ") - (text . "multigrid routine D03EDF. \blankline ") - (text . "The equation is discretized on a rectangular grid, with ") - (text . "\htbitmap{nx} grid points in the {\it x}-direction and ") - (text . "\htbitmap{ny} grid points in the {\it y}-direction. ")) - htMakeDoneButton('"Continue", 'd03eefInput) - htShowPage() - -d03eefInput() == - htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the value {\it x}a, {\it xmin}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" xmin F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the value {\it x}b, {\it xmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0" xmax F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the value {\it y}a, {\it ymin}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" ymin F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the value {\it y}b, {\it ymax}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0" ymax F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it x}-direction ") - (text . "{\it ngx}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 9 ngx PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Number of interior grid points in the {\it y}-direction ") - (text . "{\it ngy}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 9 ngy PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "First dimension of A, {\it lda}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 133 lda PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Which {\it scheme} would you like to use: ") - (radioButtons scheme - (" C" " central differences" cent) - (" U" " upwind differences" up)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\newline Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'd03eefSolve) - htShowPage() - - - -d03eefSolve htPage == - xmin := htpLabelInputString(htPage,'xmin) - xmax := htpLabelInputString(htPage,'xmax) - ymin := htpLabelInputString(htPage,'ymin) - ymax := htpLabelInputString(htPage,'ymax) - ngx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) - objValUnwrap htpLabelSpadValue(htPage, 'ngx) - ngy := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) - objValUnwrap htpLabelSpadValue(htPage, 'ngy) - lda := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) - objValUnwrap htpLabelSpadValue(htPage, 'lda) - diff := htpButtonValue(htPage,'scheme) - scheme := - diff = 'cent => '"C" - '"U" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - d03eefDefaultSolve(htPage,xmin,xmax,ymin,ymax,ngx,ngy,lda,scheme,ifail) - -d03eefDefaultSolve(htPage,xmin,xmax,ymin,ymax,ngx,ngy,lda,scheme,ifail) == - page := htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "Please enter the values of \alpha to \psi to construct PDEF.") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\alpha (x,y): \tab{10} ") - (bcStrings (46 1 alpha F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\beta (x,y): \tab{10} ") - (bcStrings (46 0 beta F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\gamma (x,y): \tab{10} ") - (bcStrings (46 1 gamma F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\delta (x,y): \tab{10} ") - (bcStrings (46 50 delta F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\epsilon (x,y): \tab{10} ") - (bcStrings (46 50 eps F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\phi (x,y): \tab{10} ") - (bcStrings (46 0 phi F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\psi (x,y): \tab{10} ") - (bcStrings (55 "-2*sin(X)*sin(Y) + 50*cos(X)*sin(Y) +50*sin(X)*cos(Y)" psi EM)) - (text . "\blankline ") - (text . "Please enter the boundary conditions a(x,y), b(x,y), and c(x,y) ") - (text . "for the top, bottom, left and right hand sides, to construct ") - (text . "BNDY. \blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Bottom boundary conditions: ") - (text . "\newline a(x,y): \tab{10} ") - (bcStrings (46 0 a11 F)) - (text . "\newline b(x,y): \tab{10} ") - (bcStrings (46 1 a12 F)) - (text . "\newline c(x,y): \tab{10} ") - (bcStrings (46 "-sin(X)" a13 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Right boundary conditions: ") - (text . "\newline a(x,y): \tab{10} ") - (bcStrings (46 1 a21 F)) - (text . "\newline b(x,y): \tab{10} ") - (bcStrings (46 0 a22 F)) - (text . "\newline c(x,y): \tab{10} ") - (bcStrings (46 "sin(X)*sin(Y)" a23 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Top boundary conditions: ") - (text . "\newline a(x,y): \tab{10} ") - (bcStrings (46 1 a31 F)) - (text . "\newline b(x,y): \tab{10} ") - (bcStrings (46 0 a32 F)) - (text . "\newline c(x,y): \tab{10} ") - (bcStrings (46 "sin(X)*sin(Y)" a33 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Left boundary conditions: ") - (text . "\newline a(x,y): \tab{10} ") - (bcStrings (46 0 a41 F)) - (text . "\newline b(x,y): \tab{10} ") - (bcStrings (46 1 a42 F)) - (text . "\newline c(x,y): \tab{10} ") - (bcStrings (46 "-sin(Y)" a43 EM))) - htMakeDoneButton('"Continue",'d03eefGen) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'ymin,ymin) - htpSetProperty(page,'ymax,ymax) - htpSetProperty(page,'ngx,ngx) - htpSetProperty(page,'ngy,ngy) - htpSetProperty(page,'lda,lda) - htpSetProperty(page,'scheme,scheme) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -d03eefGen htPage == - xmin := htpProperty(htPage, 'xmin) - xmax := htpProperty(htPage, 'xmax) - ymin := htpProperty(htPage, 'ymin) - ymax := htpProperty(htPage, 'ymax) - ngx := htpProperty(htPage, 'ngx) - ngy := htpProperty(htPage, 'ngy) - lda := htpProperty(htPage, 'lda) - scheme := htpProperty(htPage, 'scheme) - ifail := htpProperty(htPage, 'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..4 repeat - for j in 1..3 repeat - v := STRCONC((first y).1," ") - rowList := [v,:rowList] - y := rest y - vList := [:vList,rowList] - rowList := [] - vList := reverse vList - astring := bcwords2liststring [bcwords2liststring x for x in vList] - for i in 1..7 repeat - utemp := STRCONC((first y).1," ") - uList := [utemp,:uList] - y := rest y - ustring := bcwords2liststring uList - prefix := STRCONC("d03eef(",xmin,", ",xmax,", ",ymin,", ",ymax,", ") - prefix := STRCONC(prefix,STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,",_"",scheme,"_", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,", (",ustring) - prefix := STRCONC(prefix,"::Vector Expression Float)::ASP73('PDEF),(") - prefix := STRCONC(prefix,astring,"::Matrix Expression Float)::ASP74('BNDY))") - linkGen prefix - -d03faf() == - htInitPage('"D03FAF - Elliptic PDE, Helmholtz equation, 3-D Cartesian co-ordinates",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXd03faf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03faf| '|NagPartialDifferentialEquationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "D03FAF solves the three-dimensional Helmholtz equation ") - (text . "in cartesian co-ordinates: \center{\htbitmap{d03faf}} \newline ") - (text . "This subroutine forms the system of linear equations resulting ") - (text . "fom the standard seven-point finite difference equations, ") - (text . "and then solves the system using a method based on the fast ") - (text . "Fourier transform (FFT) described by Swartztrauber. ") - (text . "\blankline") - (text . "\newline ") - (text . "Read the input file to see the example program. ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\spadcommand{)read d03faf \bound{s0}} ")) - htShowPage() diff --git a/src/interp/nag-d03.boot.pamphlet b/src/interp/nag-d03.boot.pamphlet new file mode 100644 index 00000000..19717651 --- /dev/null +++ b/src/interp/nag-d03.boot.pamphlet @@ -0,0 +1,661 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-d03.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +d03edf() == + htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd03edf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03edf| '|NagPartialDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D03EDF solves, by multigrid iteration, the seven point scheme ") + (text . "\newline \htbitmap{d03edf} \newline which arises from the ") + (text . "discretization of an elliptic partial differential equation of ") + (text . "the form \center{\htbitmap{d03edf1}} and its boundary conditions") + (text . ", defined on a rectangular region. This we can write in matrix ") + (text . "form as \newline \center{{\it Au =f}}") + (text . "\blankline") + (text . "\newline ") + (text . "Read the input file to see the example program. ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\spadcommand{)read d03edf \bound{s0}} ") + (text . "\blankline") + (text . "\newline ") + (text . "If you would like to enter a problem, ") + (text . "how would you like to input the matrices? ") + (radioButtons matrix + ("" " By entering individual entries" long) + ("" " By entering matrix names already defined on the command line" short))) + htMakeDoneButton('"Continue", 'd03edfControl) + htShowPage() + +d03edfControl(htPage) == + type := htpButtonValue(htPage,'matrix) + if (type = 'long) then + d03edfLong() + else + d03edfShort() + +d03edfLong() == + htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it x}-direction ") + (text . "{\it ngx}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 3 ngx PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it y}-direction ") + (text . "{\it ngy}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 3 ngy PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "First dimension of A, {\it lda}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 22 lda PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Maximum permitted number of multigrid iterations, {\it maxit}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 1 maxit PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Tolerance required, {\it acc}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-4" acc F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Output of printed information for routine {\it iout}:") + (radioButtons iout + ("" " 0 - no output" zero) + ("" " 1 - the solution \htbitmap{uij} {\it i} = 1,2,...,NGX; {\it j} = 1,2,...,NGY" one) + ("" " 2 - residual 2-norm after each iteration " two) + ("" " 3 - as for iout = 1 & iout = 2" three) + ("" " 4 - as for iout = 3, plus the final residual" four) + ("" " 5 - as for iout = 4, plus initial elements of A & RHS" five) + ("" " 6 - as for iout = 5, plus Galerkin coarse grid approximations" six) + ("" " 7 - as for iout = 6, plus the incomplete Crout decompositions" seven) + ("" " 8 - as for iout = 7, plus the residual after each iteration" eight)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" ifail_minusOne) + ("" " 1, Suppress error messages" ifail_one))) + htMakeDoneButton('"Continue", 'd03edfSolve) + htShowPage() + + +d03edfSolve htPage == + ngx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) + objValUnwrap htpLabelSpadValue(htPage, 'ngx) + ngy := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) + objValUnwrap htpLabelSpadValue(htPage, 'ngy) + lda := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) + objValUnwrap htpLabelSpadValue(htPage, 'lda) + maxit := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) + objValUnwrap htpLabelSpadValue(htPage, 'maxit) + acc := htpLabelInputString(htPage,'acc) + control := htpButtonValue(htPage,'iout) + iout := + control = 'zero => '0 + control = 'one => '1 + control = 'two => '2 + control = 'three => '3 + control = 'four => '4 + control = 'five => '5 + control = 'six => '6 + control = 'seven => '7 + '8 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'ifail_one => '1 + '-1 + aList := + "append"/[fa(i) for i in 1..lda] where fa(i) == + labelList := + "append"/[fb(i,j) for j in 1..7] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[5, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + middle := ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") + middle := STRCONC(middle,'"{\it rhs(lda)}: \newline ") + rList := + "append"/[fc(i) for i in 1..lda] where fc(i) == + rnam := INTERN STRCONC ('"r",STRINGIMAGE i) + [['bcStrings,[6, "0.0", rnam, 'F]]] + rList := [['text,:middle],:rList] + mid:= ('"\blankline \menuitemstyle{} \tab{2} Enter the matrix ") + mid := STRCONC(mid,'" {\it ub(ngx*ngy)}: \newline ") + uList := + "append"/[fd(i) for i in 1..(ngx*ngy)] where fd(i) == + unam := INTERN STRCONC ('"u",STRINGIMAGE i) + [['bcStrings,[6, 0, unam, 'F]]] + uList := [['text,:mid],:uList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList,:rList,:uList] + page := htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the matrix {\it a(lda,7)}: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'d03edfLongGen) + htpSetProperty(page,'ngx,ngx) + htpSetProperty(page,'ngy,ngy) + htpSetProperty(page,'lda,lda) + htpSetProperty(page,'maxit,maxit) + htpSetProperty(page,'acc,acc) + htpSetProperty(page,'iout,iout) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d03edfLongGen htPage == + ngx := htpProperty(htPage, 'ngx) + ngy := htpProperty(htPage, 'ngy) + lda := htpProperty(htPage, 'lda) + maxit := htpProperty(htPage, 'maxit) + acc := htpProperty(htPage, 'acc) + iout := htpProperty(htPage, 'iout) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(ngx*ngy) repeat + utemp := STRCONC((first y).1," ") + uList := [utemp,:uList] + y := rest y + ustring := bcwords2liststring uList + for i in 1..lda repeat + rtemp := STRCONC((first y).1," ") + rList := [rtemp,:rList] + y := rest y + rstring := bcwords2liststring rList + for i in 1..lda repeat + for j in 1..7 repeat + v := STRCONC((first y).1," ") + rowList := [v,:rowList] + y := rest y + vList := [:vList,rowList] + rowList := [] + vList := reverse vList + astring := bcwords2liststring [bcwords2liststring x for x in vList] + prefix := STRCONC("d03edf(", STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE maxit,", ",acc) + mid := STRCONC(", ",STRINGIMAGE iout,", ",astring,"::Matrix DoubleFloat,[") + mid := STRCONC(mid,rstring,"],[",ustring,"],",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,mid) + +d03edfShort() == + htInitPage('"D03EDF - Elliptic PDE, solution of finite difference equations by a multigrid technique ",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it x}-direction ") + (text . "\htbitmap{nx}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 0 ngx PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it y}-direction ") + (text . "\htbitmap{ny}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 0 ngy PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "First dimension of A, {\it lda}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 0 lda PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Name of the array {\it a(lda,7)} defined on the command line: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "a" a EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Name of the array {\it rhs(lda)} defined on the command line: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "rhs" rhs EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Name of the array {\it ub(ngx*ngy)} defined on the command line:") + (text . "\newline\tab{2} ") + (bcStrings (10 "ub" ub EM)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Maximum permitted number of multigrid iterations, {\it maxit}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 0 maxit PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Tolerance required, {\it acc}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e-4" acc F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Output of printed information for routine {\it iout}:") + (radioButtons iout + ("" " 0 - no output" zero) + ("" " 1 - the solution \htbitmap{uij} {\it i} = 1,2,...,NGX; {\it j} = 1,2,...,NGY" one) + ("" " 2 - residual 2-norm after each iteration " two) + ("" " 3 - as for iout = 1 & iout = 2" three) + ("" " 4 - as for iout = 3, plus the final residual" four) + ("" " 5 - as for iout = 4, plus initial elements of A & RHS" five) + ("" " 6 - as for iout = 5, plus Galerkin coarse grid approximations" six) + ("" " 7 - as for iout = 6, plus the incomplete Crout decompositions" seven) + ("" " 8 - as for iout = 7, plus the residual after each iteration" eight)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" ifail_minusOne) + ("" " 1, Suppress error messages" ifail_one))) + htMakeDoneButton('"Continue", 'd03edfShortGen) + htShowPage() + + +d03edfShortGen htPage == + ngx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) + objValUnwrap htpLabelSpadValue(htPage, 'ngx) + ngy := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) + objValUnwrap htpLabelSpadValue(htPage, 'ngy) + lda := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) + objValUnwrap htpLabelSpadValue(htPage, 'lda) + maxit := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'maxit) + objValUnwrap htpLabelSpadValue(htPage, 'maxit) + a := htpLabelInputString(htPage, 'a) + rhs := htpLabelInputString(htPage, 'rhs) + ub := htpLabelInputString(htPage, 'ub) + acc := htpLabelInputString(htPage,'acc) + control := htpButtonValue(htPage,'iout) + iout := + control = 'zero => '0 + control = 'one => '1 + control = 'two => '2 + control = 'three => '3 + control = 'four => '4 + control = 'five => '5 + control = 'six => '6 + control = 'seven => '7 + '8 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'ifail_one => '1 + '-1 + prefix := STRCONC("d03edf(", STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE maxit,", ",acc) + mid := STRCONC(", ",STRINGIMAGE iout,", ",a,", ") + mid := STRCONC(mid,rhs,", ",ub,", ",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,mid) + + + +d03eef() == + htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd03eef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03eef| '|NagPartialDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D03EEF discretizes a second order linear elliptic partial ") + (text . "differential equation of the form \center{\htbitmap{d03eef}} ") + (text . "on a rectangular region \newline \tab{2} ") + (text . "{\it x}a \htbitmap{less=} {\it x} \htbitmap{less=} {\it x}b ") + (text . "\newline \tab{2} {\it y}a \htbitmap{less=} {\it y} ") + (text . "\htbitmap{less=} {\it y}b \newline subject to the boundary ") + (text . "conditions of the form \newline \htbitmap{d03eef1} \newline ") + (text . "where {\it \delta U/ \delta n} denotes the outward pointing ") + (text . "normal derivative on the boundary. The equation is said to be ") + (text . "elliptic if \center{\htbitmap{d03eef2}} \newline for all points ") + (text . "in the rectangular region. The seven-diagonal linear equations ") + (text . "produced are in a form suitable for passing directly to the ") + (text . "multigrid routine D03EDF. \blankline ") + (text . "The equation is discretized on a rectangular grid, with ") + (text . "\htbitmap{nx} grid points in the {\it x}-direction and ") + (text . "\htbitmap{ny} grid points in the {\it y}-direction. ")) + htMakeDoneButton('"Continue", 'd03eefInput) + htShowPage() + +d03eefInput() == + htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the value {\it x}a, {\it xmin}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" xmin F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the value {\it x}b, {\it xmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0" xmax F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the value {\it y}a, {\it ymin}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" ymin F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the value {\it y}b, {\it ymax}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0" ymax F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it x}-direction ") + (text . "{\it ngx}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 9 ngx PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Number of interior grid points in the {\it y}-direction ") + (text . "{\it ngy}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 9 ngy PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "First dimension of A, {\it lda}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 133 lda PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Which {\it scheme} would you like to use: ") + (radioButtons scheme + (" C" " central differences" cent) + (" U" " upwind differences" up)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\newline Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'd03eefSolve) + htShowPage() + + + +d03eefSolve htPage == + xmin := htpLabelInputString(htPage,'xmin) + xmax := htpLabelInputString(htPage,'xmax) + ymin := htpLabelInputString(htPage,'ymin) + ymax := htpLabelInputString(htPage,'ymax) + ngx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngx) + objValUnwrap htpLabelSpadValue(htPage, 'ngx) + ngy := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ngy) + objValUnwrap htpLabelSpadValue(htPage, 'ngy) + lda := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) + objValUnwrap htpLabelSpadValue(htPage, 'lda) + diff := htpButtonValue(htPage,'scheme) + scheme := + diff = 'cent => '"C" + '"U" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + d03eefDefaultSolve(htPage,xmin,xmax,ymin,ymax,ngx,ngy,lda,scheme,ifail) + +d03eefDefaultSolve(htPage,xmin,xmax,ymin,ymax,ngx,ngy,lda,scheme,ifail) == + page := htInitPage('"D03EEF - Discretize a 2nd order elliptic PDE on a rectangle",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "Please enter the values of \alpha to \psi to construct PDEF.") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\alpha (x,y): \tab{10} ") + (bcStrings (46 1 alpha F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\beta (x,y): \tab{10} ") + (bcStrings (46 0 beta F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\gamma (x,y): \tab{10} ") + (bcStrings (46 1 gamma F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\delta (x,y): \tab{10} ") + (bcStrings (46 50 delta F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\epsilon (x,y): \tab{10} ") + (bcStrings (46 50 eps F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\phi (x,y): \tab{10} ") + (bcStrings (46 0 phi F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\psi (x,y): \tab{10} ") + (bcStrings (55 "-2*sin(X)*sin(Y) + 50*cos(X)*sin(Y) +50*sin(X)*cos(Y)" psi EM)) + (text . "\blankline ") + (text . "Please enter the boundary conditions a(x,y), b(x,y), and c(x,y) ") + (text . "for the top, bottom, left and right hand sides, to construct ") + (text . "BNDY. \blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Bottom boundary conditions: ") + (text . "\newline a(x,y): \tab{10} ") + (bcStrings (46 0 a11 F)) + (text . "\newline b(x,y): \tab{10} ") + (bcStrings (46 1 a12 F)) + (text . "\newline c(x,y): \tab{10} ") + (bcStrings (46 "-sin(X)" a13 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Right boundary conditions: ") + (text . "\newline a(x,y): \tab{10} ") + (bcStrings (46 1 a21 F)) + (text . "\newline b(x,y): \tab{10} ") + (bcStrings (46 0 a22 F)) + (text . "\newline c(x,y): \tab{10} ") + (bcStrings (46 "sin(X)*sin(Y)" a23 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Top boundary conditions: ") + (text . "\newline a(x,y): \tab{10} ") + (bcStrings (46 1 a31 F)) + (text . "\newline b(x,y): \tab{10} ") + (bcStrings (46 0 a32 F)) + (text . "\newline c(x,y): \tab{10} ") + (bcStrings (46 "sin(X)*sin(Y)" a33 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Left boundary conditions: ") + (text . "\newline a(x,y): \tab{10} ") + (bcStrings (46 0 a41 F)) + (text . "\newline b(x,y): \tab{10} ") + (bcStrings (46 1 a42 F)) + (text . "\newline c(x,y): \tab{10} ") + (bcStrings (46 "-sin(Y)" a43 EM))) + htMakeDoneButton('"Continue",'d03eefGen) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'ymin,ymin) + htpSetProperty(page,'ymax,ymax) + htpSetProperty(page,'ngx,ngx) + htpSetProperty(page,'ngy,ngy) + htpSetProperty(page,'lda,lda) + htpSetProperty(page,'scheme,scheme) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +d03eefGen htPage == + xmin := htpProperty(htPage, 'xmin) + xmax := htpProperty(htPage, 'xmax) + ymin := htpProperty(htPage, 'ymin) + ymax := htpProperty(htPage, 'ymax) + ngx := htpProperty(htPage, 'ngx) + ngy := htpProperty(htPage, 'ngy) + lda := htpProperty(htPage, 'lda) + scheme := htpProperty(htPage, 'scheme) + ifail := htpProperty(htPage, 'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..4 repeat + for j in 1..3 repeat + v := STRCONC((first y).1," ") + rowList := [v,:rowList] + y := rest y + vList := [:vList,rowList] + rowList := [] + vList := reverse vList + astring := bcwords2liststring [bcwords2liststring x for x in vList] + for i in 1..7 repeat + utemp := STRCONC((first y).1," ") + uList := [utemp,:uList] + y := rest y + ustring := bcwords2liststring uList + prefix := STRCONC("d03eef(",xmin,", ",xmax,", ",ymin,", ",ymax,", ") + prefix := STRCONC(prefix,STRINGIMAGE ngx,", ",STRINGIMAGE ngy,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,",_"",scheme,"_", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,", (",ustring) + prefix := STRCONC(prefix,"::Vector Expression Float)::ASP73('PDEF),(") + prefix := STRCONC(prefix,astring,"::Matrix Expression Float)::ASP74('BNDY))") + linkGen prefix + +d03faf() == + htInitPage('"D03FAF - Elliptic PDE, Helmholtz equation, 3-D Cartesian co-ordinates",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXd03faf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|d03faf| '|NagPartialDifferentialEquationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "D03FAF solves the three-dimensional Helmholtz equation ") + (text . "in cartesian co-ordinates: \center{\htbitmap{d03faf}} \newline ") + (text . "This subroutine forms the system of linear equations resulting ") + (text . "fom the standard seven-point finite difference equations, ") + (text . "and then solves the system using a method based on the fast ") + (text . "Fourier transform (FFT) described by Swartztrauber. ") + (text . "\blankline") + (text . "\newline ") + (text . "Read the input file to see the example program. ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\spadcommand{)read d03faf \bound{s0}} ")) + htShowPage() +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-e01.boot b/src/interp/nag-e01.boot deleted file mode 100644 index 4cc2edad..00000000 --- a/src/interp/nag-e01.boot +++ /dev/null @@ -1,1758 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -e01baf() == - htInitPage('"E01BAF - Interpolating functions, cubic spline interpolant, one variable", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01baf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01baf| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a cubic B-spline interpolant ") - (text . "\center{s(x) = \htbitmap{e01baf}} to the points ") - (text . "(\htbitmap{xiii}, \htbitmap{yi}), for i = 1,2,...,m. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data points, {\it m}:") - (text . "\newline\tab{2} ") - (bcStrings (5 7 m PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01bafSolve) - htShowPage() - -e01bafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - m = '7 => e01bafDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{32} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01BAF - Interpolating functions, cubic spline interpolant, one variable",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of x: \tab{30} " - htSay '"\menuitemstyle{}\tab{32} Corresponding values of y: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01bafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01bafDefaultSolve (htPage, ifail) == - m := '7 - page := htInitPage('"E01BAF - Interpolating functions, cubic spline interpolant, one variable",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of x: \tab{30} ") - (text . "\menuitemstyle{}\tab{32} Corresponding values of y: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.0" x1 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.0000" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.2" x2 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.2214" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.4" x3 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.4918" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.6" x4 F)) - (text . "\tab{32} ") - (bcStrings (10 "1.8221" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.75" x5 F)) - (text . "\tab{32} ") - (bcStrings (10 "2.1170" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.9" x6 F)) - (text . "\tab{32} ") - (bcStrings (10 "2.4596" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.0" x7 F)) - (text . "\tab{32} ") - (bcStrings (10 "2.7183" y7 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01bafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01bafGen htPage == - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - lck := m + 4 - lwrk := 6*m+16 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - pre := STRCONC ('"e01baf(",STRINGIMAGE m,",[",realstring,"],[",imagstring) - post := STRCONC ('"],",STRINGIMAGE lck,",",STRINGIMAGE lwrk,",") - linkGen STRCONC (pre,post,STRINGIMAGE ifail,")") - -e01bef() == - htInitPage('"E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01bef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Brow[Cser operation page}{(|oPageFrom| '|e01bef| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines derivative estimates defining a monoticity preserving") - (text . " piecewise cubic Hermite interpolant to the set of points ") - (text . "(\htbitmap{xr}, \htbitmap{fr}), ") - (text . "for r = 1,2,...,m. The interpolant, its derivative, and its ") - (text . "integral can be evaluated by calls to E01BFF, E01BGF or E01BHF. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data points {\it n} \htbitmap{great=} 2:") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01befSolve) - htShowPage() - -e01befSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - error = 'zero => '0 - '-1 - n = '9 => e01befDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - post := ('"\tab{32} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{30} " - htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " - htSay '"\htbitmap{fr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01befGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01befDefaultSolve (htPage, ifail) == - n := '9 - page := htInitPage('"E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{30} ") - (text . "\menuitemstyle{}\tab{32} Values of \space{1} \htbitmap{fr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "7.99" x1 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.00000e+0" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.09" x2 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.27643e-4" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.19" x3 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.43750e-1" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.70" x4 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.16918" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.20" x5 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.46943" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.00" x6 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.94374" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.00" x7 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.99864" y7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.00" x8 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.99992" y8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.00" x9 F)) - (text . "\tab{32} ") - (bcStrings (10 "0.99999" y9 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01befGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01befGen htPage == - n := htpProperty(htPage,'n) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - lck := n + 4 - lwrk := 6*n+16 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - reallist := [left,:reallist] - imaglist := [right,:imaglist] - realstring := bcwords2liststring reallist - imagstring := bcwords2liststring imaglist - linkGen STRCONC ('"e01bef(",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],",STRINGIMAGE ifail,")") - - -e01bff() == - htInitPage('"E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01bff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bff| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the piecewise cubic Hermite interpolant computed ") - (text . "by E01BEF at the set of points \htbitmap{xiii}, ") - (text . "for i = 1,2,...,m. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data points {\em n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of evaluation points {\em m}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 11 m PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01bffSolve) - htShowPage() - -e01bffSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '9 and m = '11) => e01bffDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - pxwords := ('"\blankline \menuitemstyle{}\tab{2} Values of ") - pxwords := STRCONC(pxwords,'"array {\it Px}: \newline ") - pxwords := cons('text,pxwords) - pointList := - "append"/[g(j) for j in 1..m] where g(j) == - preamb := ('"\newline \tab{2} ") - pnam := INTERN STRCONC ('"px",STRINGIMAGE j) - [['text,:preamb],['bcStrings,[10, 0.0, pnam, 'F]]] - labelList := [:labelList,pxwords,:pointList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01bffGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01bffDefaultSolve (htPage, ifail) == - n := '9 - m := '11 - page := htInitPage('"E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{dr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "7.99" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00000e+0" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000e+0" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.09" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.27643e-4" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.52510e-4" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.19" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.43750e-1" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.33587" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.70" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.16918" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.34944" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.20" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.46943" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.59696" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.00" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.94374" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "6.03260e-2" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.00" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99864" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "8.98335e-4" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.00" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99992" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.93954e-5" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.00" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99999" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000" z9 F)) - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Values of array {\it Px}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "7.99" px1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.191" px2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.392" px3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "11.593" px4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.794" px5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "13.995" px6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.196" px7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "16.397" px8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.598" px9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "18.799" px10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.0" px11 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01bffGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01bffGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - lck := n + 4 - lwrk := 6*n+16 - y := alist - for i in 1..m repeat - px := STRCONC ((first y).1," ") - y := rest y - pxlist := [px,:pxlist] - pxstring := bcwords2liststring pxlist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - flist := [mid,:flist] - dlist := [right,:dlist] - xstring := bcwords2liststring xlist - fstring := bcwords2liststring flist - dstring := bcwords2liststring dlist - prefix := STRCONC('"e01bff(",STRINGIMAGE n,",[",xstring,"],[",fstring) - prefix := STRCONC(prefix,"],[",dstring,"],",STRINGIMAGE m,",[",pxstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e01bgf() == - htInitPage('"E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01bgf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bgf| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the piecewise cubic Hermite interpolant computed ") - (text . "by E01BEF and its 1st derivative at the set of points \space{1} ") - (text . "\htbitmap{xiii}, for i = 1,2,...,m. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data points {\em n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of evaluation points {\em m}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 11 m PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01bgfSolve) - htShowPage() - -e01bgfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '9 and m = '11) => e01bgfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - pxwords := ('"\blankline \menuitemstyle{}\tab{2} Values of ") - pxwords := STRCONC(pxwords,'"array {\it Px}: \newline ") - pxwords := cons('text,pxwords) - pointList := - "append"/[g(j) for j in 1..m] where g(j) == - preamb := ('"\newline \tab{2} ") - pnam := INTERN STRCONC ('"px",STRINGIMAGE j) - [['text,:preamb],['bcStrings,[10, 0.0, pnam, 'F]]] - labelList := [:labelList,pxwords,:pointList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01bgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01bgfDefaultSolve (htPage, ifail) == - n := '9 - m := '11 - page := htInitPage('"E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{dr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "7.99" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00000e+0" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000e+0" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.09" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.27643e-4" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.52510e-4" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.19" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.43750e-1" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.33587" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.70" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.16918" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.34944" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.20" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.46943" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.59696" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.00" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.94374" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "6.03260e-2" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.00" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99864" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "8.98335e-4" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.00" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99992" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.93954e-5" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.00" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99999" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000" z9 F)) - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Values of array {\it Px}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "7.99" px1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.191" px2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.392" px3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "11.593" px4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.794" px5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "13.995" px6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.196" px7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "16.397" px8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.598" px9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "18.799" px10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.0" px11 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01bgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01bgfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - lck := n + 4 - lwrk := 6*n+16 - y := alist - for i in 1..m repeat - px := STRCONC ((first y).1," ") - y := rest y - pxlist := [px,:pxlist] - pxstring := bcwords2liststring pxlist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - flist := [mid,:flist] - dlist := [right,:dlist] - xstring := bcwords2liststring xlist - fstring := bcwords2liststring flist - dstring := bcwords2liststring dlist - prefix := STRCONC('"e01bgf(",STRINGIMAGE n,",[",xstring,"],[",fstring) - prefix := STRCONC(prefix,"],[",dstring,"],",STRINGIMAGE m,",[",pxstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e01bhf() == - htInitPage('"E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01bhf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bhf| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the definite integral of the piecewise cubic Hermite ") - (text . "interpolant computed by E01BEF over the interval [a,b]. ") - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Enter the number of data points {\em n}: ") - (text . "\newline\tab{2} ") - (bcStrings (5 9 n PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline {\em Lower} bound {\it a}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\em Upper} bound {\it b}:") - (text . "\newline\tab{2} ") - (bcStrings (20 "7.99" a F)) - (text . "\tab{34} ") - (bcStrings (20 "20.0" b EM)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01bhfSolve) - htShowPage() - -e01bhfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - a := htpLabelInputString(htPage,'a) - b := htpLabelInputString(htPage,'b) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '9 => e01bhfDefaultSolve(htPage,a,b,ifail) - labelList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01bhfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01bhfDefaultSolve (htPage,a,b,ifail) == - n := '9 - page := htInitPage('"E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{dr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "7.99" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00000e+0" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000e+0" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.09" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.27643e-4" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.52510e-4" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.19" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.43750e-1" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.33587" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.70" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.16918" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.34944" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.20" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.46943" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.59696" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.00" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.94374" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "6.03260e-2" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.00" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99864" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "8.98335e-4" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.00" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99992" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.93954e-5" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.00" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.99999" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.00000" z9 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01bhfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'a,a) - htpSetProperty(page,'b,b) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01bhfGen htPage == - n := htpProperty(htPage,'n) - a := htpProperty(htPage,'a) - b := htpProperty(htPage,'b) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - lck := n + 4 - lwrk := 6*n+16 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - flist := [mid,:flist] - dlist := [right,:dlist] - xstring := bcwords2liststring xlist - fstring := bcwords2liststring flist - dstring := bcwords2liststring dlist - prefix := STRCONC('"e01bhf(",STRINGIMAGE n,",[",xstring,"],[",fstring,"],[") - prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE a,",",STRINGIMAGE b,",",STRINGIMAGE ifail,")") - linkGen prefix - - -e01daf() == - htInitPage('"E01DAF - Interpolating functions, fitting bicubic spline, data on a rectangular grid", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01daf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01daf| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a bicubic spline surface interpolating the set of ") - (text . "data values (\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}) ") - (text . "given on a rectangular grid. The grid is defined by ") - (text . "\space{1} \htbitmap{mx} points along the x-axis and ") - (text . "\space{1} \htbitmap{my} points along the y-axis. The ") - (text . "spline has \space{1} \htbitmap{px} knots ") - (text . "\htbitmap{lamdai} and \space{1}\htbitmap{py}") - (text . " knots \htbitmap{mui} in the x- and y-directions ") - (text . "respectively, and is given in the B-spline representation ") - (text . "\center{s(x,y) = \htbitmap{e01daf1}} ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "\newline The value \space{1} \htbitmap{mx}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "The value \space{1} \htbitmap{my}:") - (text . "\newline\tab{2} ") - (bcStrings (6 7 mx PI)) - (text . "\tab{34} ") - (bcStrings (6 6 my PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01dafSolve) - htShowPage() - -e01dafSolve htPage == - mx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) - objValUnwrap htpLabelSpadValue(htPage, 'mx) - my := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) - objValUnwrap htpLabelSpadValue(htPage, 'my) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (mx = '7 and my = '6) => e01dafDefaultSolve(htPage,ifail) - xList := - "append"/[f(i) for i in 1..mx] where f(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[6, 0.0, xnam, 'F]]] - prefix := ('"\newline \menuitemstyle{}\tab{2} Values of X(1) to X(MX): \newline ") - xList := [['text,:prefix],:xList] - yList := - "append"/[g(i) for i in 1..my] where g(i) == - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['bcStrings,[6, 0.0, ynam, 'F]]] - prefix := ('"\blankline\menuitemstyle{}\tab{2}Values of Y(1) to Y(MY): \newline ") - yList := [['text,:prefix],:yList] - fList := - "append"/[h(j,my) for j in 1..mx] where h(j,my) == - tempList := - "append"/[k(j,m) for m in 1..my] where k(j,m) == - fnam := INTERN STRCONC ('"f",STRINGIMAGE j, STRINGIMAGE m) - [['bcStrings,[6, 0.0, fnam, 'F]]] - prefix := ('"\newline ") - tempList := [['text,:prefix],:tempList] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of F(MX*MY) ") - prefix := STRCONC(prefix,'"(x down, y across): ") - fList := [['text,:prefix],:fList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :xList,:yList,:fList] - page := htInitPage("E01DAF - Interpolating functions, fitting bicubic spline, data on a rectanglar grid",htpPropertyList htPage) - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01dafGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01dafDefaultSolve (htPage,ifail) == - mx := '7 - my := '6 - page := htInitPage('"E01DAF - Interpolating functions, fitting bicubic spline, data on rectangular grid",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of X(1) to X(MX): ") - (text . "\newline ") - (bcStrings (6 "1.00" x1 F)) - (bcStrings (6 "1.10" x2 F)) - (bcStrings (6 "1.30" x3 F)) - (bcStrings (6 "1.50" x4 F)) - (bcStrings (6 "1.60" x5 F)) - (bcStrings (6 "1.80" x6 F)) - (bcStrings (6 "2.00" x7 F)) - (text . "\blankline ") - (text . "\newline ") - (text ."\menuitemstyle{} \tab{2} Values of Y(1) to Y(MY): ") - (text . "\newline ") - (bcStrings (6 "0.00" y1 F)) - (bcStrings (6 "0.10" y2 F)) - (bcStrings (6 "0.40" y3 F)) - (bcStrings (6 "0.70" y4 F)) - (bcStrings (6 "0.90" y5 F)) - (bcStrings (6 "1.00" y6 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} Values of F(MX*MY) (x down, y across): ") - (text . "\newline ") - (bcStrings (6 "1.00" z11 F)) - (bcStrings (6 "1.10" z21 F)) - (bcStrings (6 "1.40" z31 F)) - (bcStrings (6 "1.70" z41 F)) - (bcStrings (6 "1.90" z51 F)) - (bcStrings (6 "2.00" z61 F)) - (text . "\newline ") - (bcStrings (6 "1.21" z12 F)) - (bcStrings (6 "1.31" z22 F)) - (bcStrings (6 "1.61" z32 F)) - (bcStrings (6 "1.91" z42 F)) - (bcStrings (6 "2.11" z52 F)) - (bcStrings (6 "2.21" z62 F)) - (text . "\newline ") - (bcStrings (6 "1.69" z13 F)) - (bcStrings (6 "1.79" z23 F)) - (bcStrings (6 "2.09" z33 F)) - (bcStrings (6 "2.39" z43 F)) - (bcStrings (6 "2.59" z53 F)) - (bcStrings (6 "2.69" z63 F)) - (text . "\newline ") - (bcStrings (6 "2.25" z14 F)) - (bcStrings (6 "2.35" z24 F)) - (bcStrings (6 "2.65" z34 F)) - (bcStrings (6 "2.95" z44 F)) - (bcStrings (6 "3.15" z54 F)) - (bcStrings (6 "3.25" z64 F)) - (text . "\newline ") - (bcStrings (6 "2.56" z15 F)) - (bcStrings (6 "2.66" z25 F)) - (bcStrings (6 "2.96" z35 F)) - (bcStrings (6 "3.26" z45 F)) - (bcStrings (6 "3.46" z55 F)) - (bcStrings (6 "3.56" z65 F)) - (text . "\newline ") - (bcStrings (6 "3.24" z16 F)) - (bcStrings (6 "3.34" z26 F)) - (bcStrings (6 "3.64" z36 F)) - (bcStrings (6 "3.94" z46 F)) - (bcStrings (6 "4.14" z56 F)) - (bcStrings (6 "4.24" z66 F)) - (text . "\newline ") - (bcStrings (6 "4.00" z17 F)) - (bcStrings (6 "4.10" z27 F)) - (bcStrings (6 "4.40" z37 F)) - (bcStrings (6 "4.70" z47 F)) - (bcStrings (6 "4.90" z57 F)) - (bcStrings (6 "5.00" z67 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01dafGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01dafGen htPage == - mx := htpProperty(htPage,'mx) - my := htpProperty(htPage,'my) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1, " ") - y := rest y - xlist := [right,:xlist] - for i in 1..mx repeat - xmx := [:xmx,(first xlist)] - xlist := rest xlist - xstring := bcwords2liststring xmx - for i in 1..my repeat - ymy := [:ymy,(first xlist)] - xlist := rest xlist - ystring := bcwords2liststring ymy - fstring := bcwords2liststring xlist - prefix := STRCONC('"e01daf(",STRINGIMAGE mx,", ",STRINGIMAGE my,",[") - midd := STRCONC(xstring, "], [",ystring,"], [",fstring,"], ") - linkGen STRCONC(prefix,midd,STRINGIMAGE ifail,")") - -e01saf() == - htInitPage('"E01SAF - Interpolating functions, method of Renka and Cline, two variables", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01saf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01saf| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a \htbitmap{c1} piecewise polynomial ") - (text . "surface F(x,y) interpolating the set of scattered points ") - (text . "(\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}), ") - (text . "for r = 1,2,...,m, using a method of Renka and Cline. ") - (text . "The interpolant can be evaluated using E01SBF. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\em m} \htbitmap{great=} 3:") - (text . "\newline \tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01safSolve) - htShowPage() - -e01safSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - m = '30 => e01safDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01SAF - Interpolating functions, method of Renka and Cline,two variables",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01safGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01safDefaultSolve (htPage, ifail) == - m := '30 - page := htInitPage('"E01SAF - Interpolating functions, method of Renka and Cline, two variables",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{dr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "11.16" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.24" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "22.15" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.85" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.06" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "22.11" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "19.85" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.72" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "7.97" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "19.72" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.39" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "16.83" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.91" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.74" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "15.30" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "34.60" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.87" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.74" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.45" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.78" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "41.24" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "14.26" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "17.87" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "10.74" z9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.43" x10 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.46" y10 F)) - (text . "\tab{42} ") - (bcStrings (10 "18.60" z10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.80" x11 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.39" y11 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.47" z11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.58" x12 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.98" y12 F)) - (text . "\tab{42} ") - (bcStrings (10 "29.87" z12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "25.00" x13 F)) - (text . "\tab{22} ") - (bcStrings (10 "11.87" y13 F)) - (text . "\tab{42} ") - (bcStrings (10 "4.40" z13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x14 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" y14 F)) - (text . "\tab{42} ") - (bcStrings (10 "58.20" z14 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.66" x15 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y15 F)) - (text . "\tab{42} ") - (bcStrings (10 "4.73" z15 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.22" x16 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.66" y16 F)) - (text . "\tab{42} ") - (bcStrings (10 "40.36" z16 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.25" x17 F)) - (text . "\tab{22} ") - (bcStrings (10 "19.57" y17 F)) - (text . "\tab{42} ") - (bcStrings (10 "6.43" z17 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "25.00" x18 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.87" y18 F)) - (text . "\tab{42} ") - (bcStrings (10 "8.74" z18 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.13" x19 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.79" y19 F)) - (text . "\tab{42} ") - (bcStrings (10 "13.71" z19 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.23" x20 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.21" y20 F)) - (text . "\tab{42} ") - (bcStrings (10 "10.25" z20 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "11.52" x21 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.53" y21 F)) - (text . "\tab{42} ") - (bcStrings (10 "15.74" z21 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.20" x22 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.0" y22 F)) - (text . "\tab{42} ") - (bcStrings (10 "21.60" z22 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.54" x23 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.69" y23 F)) - (text . "\tab{42} ") - (bcStrings (10 "19.31" z23 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.32" x24 F)) - (text . "\tab{22} ") - (bcStrings (10 "13.78" y24 F)) - (text . "\tab{42} ") - (bcStrings (10 "12.11" z24 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.14" x25 F)) - (text . "\tab{22} ") - (bcStrings (10 "15.03" y25 F)) - (text . "\tab{42} ") - (bcStrings (10 "53.10" z25 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.51" x26 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.37" y26 F)) - (text . "\tab{42} ") - (bcStrings (10 "49.43" z26 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.69" x27 F)) - (text . "\tab{22} ") - (bcStrings (10 "19.63" y27 F)) - (text . "\tab{42} ") - (bcStrings (10 "3.25" z27 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.47" x28 F)) - (text . "\tab{22} ") - (bcStrings (10 "17.13" y28 F)) - (text . "\tab{42} ") - (bcStrings (10 "28.63" z28 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "21.67" x29 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.36" y29 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.52" z29 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.31" x30 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.33" y30 F)) - (text . "\tab{42} ") - (bcStrings (10 "44.08" z30 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01safGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01safGen htPage == - m := htpProperty(htPage,'m) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - flist := [mid,:flist] - dlist := [right,:dlist] - xstring := bcwords2liststring xlist - fstring := bcwords2liststring flist - dstring := bcwords2liststring dlist - prefix := STRCONC('"e01saf(",STRINGIMAGE m,",[",xstring,"],[",fstring,"],[") - prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE ifail,")") - linkGen prefix - -e01sef() == - htInitPage('"E01SEF - Interpolating functions, modified Shepard's method, two variables", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe01sef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01sef| '|NagInterpolationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a \htbitmap{c1} piecewise polynomial ") - (text . "surface F(x,y) interpolating the set of scattered points ") - (text . "(\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}), ") - (text . "for r = 1,2,...,m, using a modified Shepard method. ") - (text . "The interpolant can be evaluated using E01SFF. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\em m} \htbitmap{great=} 3:") - (text . "\newline \tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline ") - (text . "Note: RNW, RNQ, NW, NQ set to zero for default value. ") - (text . "On exit, they contain the value actually used. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline {\em RNW} weight locality radius: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "{\em RNQ} point locality radius:") - (text . "\newline\tab{2} ") - (bcStrings (6 "0.0" rnw F)) - (text . "\tab{34} ") - (bcStrings (6 "0.0" rnq F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} \newline") - (text . "{\em NW} average number of points within RNW of each point: ") - (text . "\newline \tab{2} ") - (bcStrings (6 0 nw I)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} \newline") - (text . "{\em NQ} average number of points within RNQ of each point: ") - (text . "\newline \tab{2} ") - (bcStrings (6 0 nq I)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e01sefSolve) - htShowPage() - -e01sefSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - nw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nw) - objValUnwrap htpLabelSpadValue(htPage, 'nw) - nq := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nq) - objValUnwrap htpLabelSpadValue(htPage, 'nq) - rnq := htpLabelInputString(htPage,'rnq) - rnw := htpLabelInputString(htPage,'rnw) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - m = '30 => e01sefDefaultSolve(htPage,rnq,rnw,nq,nw,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E01SEF - Interpolating functions, modified Shepard's method, two variables",htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e01sefGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'rnq,rnq) - htpSetProperty(page,'rnw,rnw) - htpSetProperty(page,'nq,nq) - htpSetProperty(page,'nw,nw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e01sefDefaultSolve (htPage,rnq,rnw,nq,nw,ifail) == - m := '30 - page := htInitPage('"E01SEF - Interpolating functions, modified Shepard's method, two variables",htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{dr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "11.16" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.24" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "22.15" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.85" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.06" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "22.11" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "19.85" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.72" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "7.97" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "19.72" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.39" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "16.83" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.91" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.74" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "15.30" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "34.60" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "20.87" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.74" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.45" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.78" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "41.24" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "14.26" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "17.87" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "10.74" z9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.43" x10 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.46" y10 F)) - (text . "\tab{42} ") - (bcStrings (10 "18.60" z10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.80" x11 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.39" y11 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.47" z11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.58" x12 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.98" y12 F)) - (text . "\tab{42} ") - (bcStrings (10 "29.87" z12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "25.00" x13 F)) - (text . "\tab{22} ") - (bcStrings (10 "11.87" y13 F)) - (text . "\tab{42} ") - (bcStrings (10 "4.40" z13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" x14 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" y14 F)) - (text . "\tab{42} ") - (bcStrings (10 "58.20" z14 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.66" x15 F)) - (text . "\tab{22} ") - (bcStrings (10 "20.00" y15 F)) - (text . "\tab{42} ") - (bcStrings (10 "4.73" z15 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.22" x16 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.66" y16 F)) - (text . "\tab{42} ") - (bcStrings (10 "40.36" z16 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.25" x17 F)) - (text . "\tab{22} ") - (bcStrings (10 "19.57" y17 F)) - (text . "\tab{42} ") - (bcStrings (10 "6.43" z17 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "25.00" x18 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.87" y18 F)) - (text . "\tab{42} ") - (bcStrings (10 "8.74" z18 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.13" x19 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.79" y19 F)) - (text . "\tab{42} ") - (bcStrings (10 "13.71" z19 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.23" x20 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.21" y20 F)) - (text . "\tab{42} ") - (bcStrings (10 "10.25" z20 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "11.52" x21 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.53" y21 F)) - (text . "\tab{42} ") - (bcStrings (10 "15.74" z21 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "15.20" x22 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.0" y22 F)) - (text . "\tab{42} ") - (bcStrings (10 "21.60" z22 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.54" x23 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.69" y23 F)) - (text . "\tab{42} ") - (bcStrings (10 "19.31" z23 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "17.32" x24 F)) - (text . "\tab{22} ") - (bcStrings (10 "13.78" y24 F)) - (text . "\tab{42} ") - (bcStrings (10 "12.11" z24 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.14" x25 F)) - (text . "\tab{22} ") - (bcStrings (10 "15.03" y25 F)) - (text . "\tab{42} ") - (bcStrings (10 "53.10" z25 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.51" x26 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.37" y26 F)) - (text . "\tab{42} ") - (bcStrings (10 "49.43" z26 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "22.69" x27 F)) - (text . "\tab{22} ") - (bcStrings (10 "19.63" y27 F)) - (text . "\tab{42} ") - (bcStrings (10 "3.25" z27 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.47" x28 F)) - (text . "\tab{22} ") - (bcStrings (10 "17.13" y28 F)) - (text . "\tab{42} ") - (bcStrings (10 "28.63" z28 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "21.67" x29 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.36" y29 F)) - (text . "\tab{42} ") - (bcStrings (10 "5.52" z29 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.31" x30 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.33" y30 F)) - (text . "\tab{42} ") - (bcStrings (10 "44.08" z30 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e01sefGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'rnq,rnq) - htpSetProperty(page,'rnw,rnw) - htpSetProperty(page,'nq,nq) - htpSetProperty(page,'nw,nw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e01sefGen htPage == - m := htpProperty(htPage,'m) - rnw := htpProperty(htPage,'rnw) - rnq := htpProperty(htPage,'rnq) - nw := htpProperty(htPage,'nw) - nq := htpProperty(htPage,'nq) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - flist := [mid,:flist] - dlist := [right,:dlist] - xstring := bcwords2liststring xlist - fstring := bcwords2liststring flist - dstring := bcwords2liststring dlist - prefix := STRCONC('"e01sef(",STRINGIMAGE m,",[",xstring,"],[",fstring,"],[") - prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE nw,", ",STRINGIMAGE nq) - prefix := STRCONC(prefix,", ",rnw,", ",rnq,", ",STRINGIMAGE ifail,")") - linkGen prefix diff --git a/src/interp/nag-e01.boot.pamphlet b/src/interp/nag-e01.boot.pamphlet new file mode 100644 index 00000000..227dabde --- /dev/null +++ b/src/interp/nag-e01.boot.pamphlet @@ -0,0 +1,1780 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-e01.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +e01baf() == + htInitPage('"E01BAF - Interpolating functions, cubic spline interpolant, one variable", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01baf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01baf| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a cubic B-spline interpolant ") + (text . "\center{s(x) = \htbitmap{e01baf}} to the points ") + (text . "(\htbitmap{xiii}, \htbitmap{yi}), for i = 1,2,...,m. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data points, {\it m}:") + (text . "\newline\tab{2} ") + (bcStrings (5 7 m PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01bafSolve) + htShowPage() + +e01bafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + m = '7 => e01bafDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{32} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01BAF - Interpolating functions, cubic spline interpolant, one variable",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of x: \tab{30} " + htSay '"\menuitemstyle{}\tab{32} Corresponding values of y: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01bafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01bafDefaultSolve (htPage, ifail) == + m := '7 + page := htInitPage('"E01BAF - Interpolating functions, cubic spline interpolant, one variable",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of x: \tab{30} ") + (text . "\menuitemstyle{}\tab{32} Corresponding values of y: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.0" x1 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.0000" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.2" x2 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.2214" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.4" x3 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.4918" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.6" x4 F)) + (text . "\tab{32} ") + (bcStrings (10 "1.8221" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.75" x5 F)) + (text . "\tab{32} ") + (bcStrings (10 "2.1170" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.9" x6 F)) + (text . "\tab{32} ") + (bcStrings (10 "2.4596" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.0" x7 F)) + (text . "\tab{32} ") + (bcStrings (10 "2.7183" y7 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01bafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01bafGen htPage == + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + lck := m + 4 + lwrk := 6*m+16 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + pre := STRCONC ('"e01baf(",STRINGIMAGE m,",[",realstring,"],[",imagstring) + post := STRCONC ('"],",STRINGIMAGE lck,",",STRINGIMAGE lwrk,",") + linkGen STRCONC (pre,post,STRINGIMAGE ifail,")") + +e01bef() == + htInitPage('"E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01bef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Brow[Cser operation page}{(|oPageFrom| '|e01bef| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines derivative estimates defining a monoticity preserving") + (text . " piecewise cubic Hermite interpolant to the set of points ") + (text . "(\htbitmap{xr}, \htbitmap{fr}), ") + (text . "for r = 1,2,...,m. The interpolant, its derivative, and its ") + (text . "integral can be evaluated by calls to E01BFF, E01BGF or E01BHF. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data points {\it n} \htbitmap{great=} 2:") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01befSolve) + htShowPage() + +e01befSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + error = 'zero => '0 + '-1 + n = '9 => e01befDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + post := ('"\tab{32} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, ynam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{30} " + htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " + htSay '"\htbitmap{fr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01befGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01befDefaultSolve (htPage, ifail) == + n := '9 + page := htInitPage('"E01BEF - Interpolating functions, monoticity preserving, piecewise cubic Hermite, one variable",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{30} ") + (text . "\menuitemstyle{}\tab{32} Values of \space{1} \htbitmap{fr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "7.99" x1 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.00000e+0" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.09" x2 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.27643e-4" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.19" x3 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.43750e-1" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.70" x4 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.16918" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.20" x5 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.46943" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.00" x6 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.94374" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.00" x7 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.99864" y7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.00" x8 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.99992" y8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.00" x9 F)) + (text . "\tab{32} ") + (bcStrings (10 "0.99999" y9 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01befGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01befGen htPage == + n := htpProperty(htPage,'n) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + lck := n + 4 + lwrk := 6*n+16 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + reallist := [left,:reallist] + imaglist := [right,:imaglist] + realstring := bcwords2liststring reallist + imagstring := bcwords2liststring imaglist + linkGen STRCONC ('"e01bef(",STRINGIMAGE n,",[",realstring,"],[",imagstring,"],",STRINGIMAGE ifail,")") + + +e01bff() == + htInitPage('"E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01bff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bff| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the piecewise cubic Hermite interpolant computed ") + (text . "by E01BEF at the set of points \htbitmap{xiii}, ") + (text . "for i = 1,2,...,m. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data points {\em n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of evaluation points {\em m}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 11 m PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01bffSolve) + htShowPage() + +e01bffSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '9 and m = '11) => e01bffDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + pxwords := ('"\blankline \menuitemstyle{}\tab{2} Values of ") + pxwords := STRCONC(pxwords,'"array {\it Px}: \newline ") + pxwords := cons('text,pxwords) + pointList := + "append"/[g(j) for j in 1..m] where g(j) == + preamb := ('"\newline \tab{2} ") + pnam := INTERN STRCONC ('"px",STRINGIMAGE j) + [['text,:preamb],['bcStrings,[10, 0.0, pnam, 'F]]] + labelList := [:labelList,pxwords,:pointList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01bffGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01bffDefaultSolve (htPage, ifail) == + n := '9 + m := '11 + page := htInitPage('"E01BFF - Interpolated values, interpolant computed by E01BEF, function only, one variable",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{dr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "7.99" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00000e+0" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000e+0" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.09" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.27643e-4" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.52510e-4" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.19" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.43750e-1" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.33587" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.70" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.16918" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.34944" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.20" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.46943" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.59696" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.00" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.94374" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "6.03260e-2" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.00" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99864" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "8.98335e-4" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.00" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99992" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.93954e-5" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.00" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99999" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000" z9 F)) + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Values of array {\it Px}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "7.99" px1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.191" px2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.392" px3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "11.593" px4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.794" px5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "13.995" px6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.196" px7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "16.397" px8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.598" px9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "18.799" px10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.0" px11 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01bffGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01bffGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + lck := n + 4 + lwrk := 6*n+16 + y := alist + for i in 1..m repeat + px := STRCONC ((first y).1," ") + y := rest y + pxlist := [px,:pxlist] + pxstring := bcwords2liststring pxlist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + flist := [mid,:flist] + dlist := [right,:dlist] + xstring := bcwords2liststring xlist + fstring := bcwords2liststring flist + dstring := bcwords2liststring dlist + prefix := STRCONC('"e01bff(",STRINGIMAGE n,",[",xstring,"],[",fstring) + prefix := STRCONC(prefix,"],[",dstring,"],",STRINGIMAGE m,",[",pxstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e01bgf() == + htInitPage('"E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01bgf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bgf| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the piecewise cubic Hermite interpolant computed ") + (text . "by E01BEF and its 1st derivative at the set of points \space{1} ") + (text . "\htbitmap{xiii}, for i = 1,2,...,m. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data points {\em n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of evaluation points {\em m}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 11 m PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01bgfSolve) + htShowPage() + +e01bgfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '9 and m = '11) => e01bgfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + pxwords := ('"\blankline \menuitemstyle{}\tab{2} Values of ") + pxwords := STRCONC(pxwords,'"array {\it Px}: \newline ") + pxwords := cons('text,pxwords) + pointList := + "append"/[g(j) for j in 1..m] where g(j) == + preamb := ('"\newline \tab{2} ") + pnam := INTERN STRCONC ('"px",STRINGIMAGE j) + [['text,:preamb],['bcStrings,[10, 0.0, pnam, 'F]]] + labelList := [:labelList,pxwords,:pointList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01bgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01bgfDefaultSolve (htPage, ifail) == + n := '9 + m := '11 + page := htInitPage('"E01BGF - Interpolated values, interpolant computed by E01BEF, function and 1st derivative, one variable",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{dr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "7.99" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00000e+0" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000e+0" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.09" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.27643e-4" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.52510e-4" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.19" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.43750e-1" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.33587" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.70" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.16918" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.34944" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.20" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.46943" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.59696" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.00" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.94374" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "6.03260e-2" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.00" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99864" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "8.98335e-4" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.00" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99992" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.93954e-5" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.00" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99999" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000" z9 F)) + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Values of array {\it Px}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "7.99" px1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.191" px2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.392" px3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "11.593" px4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.794" px5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "13.995" px6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.196" px7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "16.397" px8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.598" px9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "18.799" px10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.0" px11 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01bgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01bgfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + lck := n + 4 + lwrk := 6*n+16 + y := alist + for i in 1..m repeat + px := STRCONC ((first y).1," ") + y := rest y + pxlist := [px,:pxlist] + pxstring := bcwords2liststring pxlist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + flist := [mid,:flist] + dlist := [right,:dlist] + xstring := bcwords2liststring xlist + fstring := bcwords2liststring flist + dstring := bcwords2liststring dlist + prefix := STRCONC('"e01bgf(",STRINGIMAGE n,",[",xstring,"],[",fstring) + prefix := STRCONC(prefix,"],[",dstring,"],",STRINGIMAGE m,",[",pxstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e01bhf() == + htInitPage('"E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01bhf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01bhf| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the definite integral of the piecewise cubic Hermite ") + (text . "interpolant computed by E01BEF over the interval [a,b]. ") + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Enter the number of data points {\em n}: ") + (text . "\newline\tab{2} ") + (bcStrings (5 9 n PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline {\em Lower} bound {\it a}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\em Upper} bound {\it b}:") + (text . "\newline\tab{2} ") + (bcStrings (20 "7.99" a F)) + (text . "\tab{34} ") + (bcStrings (20 "20.0" b EM)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01bhfSolve) + htShowPage() + +e01bhfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + a := htpLabelInputString(htPage,'a) + b := htpLabelInputString(htPage,'b) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '9 => e01bhfDefaultSolve(htPage,a,b,ifail) + labelList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01bhfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01bhfDefaultSolve (htPage,a,b,ifail) == + n := '9 + page := htInitPage('"E01BHF - Interpolated values, interpolant computed by E01BEF, definite integral, one variable",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{dr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "7.99" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00000e+0" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000e+0" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.09" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.27643e-4" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.52510e-4" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.19" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.43750e-1" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.33587" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.70" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.16918" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.34944" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.20" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.46943" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.59696" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.00" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.94374" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "6.03260e-2" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.00" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99864" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "8.98335e-4" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.00" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99992" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.93954e-5" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.00" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.99999" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.00000" z9 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01bhfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'a,a) + htpSetProperty(page,'b,b) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01bhfGen htPage == + n := htpProperty(htPage,'n) + a := htpProperty(htPage,'a) + b := htpProperty(htPage,'b) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + lck := n + 4 + lwrk := 6*n+16 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + flist := [mid,:flist] + dlist := [right,:dlist] + xstring := bcwords2liststring xlist + fstring := bcwords2liststring flist + dstring := bcwords2liststring dlist + prefix := STRCONC('"e01bhf(",STRINGIMAGE n,",[",xstring,"],[",fstring,"],[") + prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE a,",",STRINGIMAGE b,",",STRINGIMAGE ifail,")") + linkGen prefix + + +e01daf() == + htInitPage('"E01DAF - Interpolating functions, fitting bicubic spline, data on a rectangular grid", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01daf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01daf| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a bicubic spline surface interpolating the set of ") + (text . "data values (\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}) ") + (text . "given on a rectangular grid. The grid is defined by ") + (text . "\space{1} \htbitmap{mx} points along the x-axis and ") + (text . "\space{1} \htbitmap{my} points along the y-axis. The ") + (text . "spline has \space{1} \htbitmap{px} knots ") + (text . "\htbitmap{lamdai} and \space{1}\htbitmap{py}") + (text . " knots \htbitmap{mui} in the x- and y-directions ") + (text . "respectively, and is given in the B-spline representation ") + (text . "\center{s(x,y) = \htbitmap{e01daf1}} ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "\newline The value \space{1} \htbitmap{mx}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "The value \space{1} \htbitmap{my}:") + (text . "\newline\tab{2} ") + (bcStrings (6 7 mx PI)) + (text . "\tab{34} ") + (bcStrings (6 6 my PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01dafSolve) + htShowPage() + +e01dafSolve htPage == + mx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) + objValUnwrap htpLabelSpadValue(htPage, 'mx) + my := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) + objValUnwrap htpLabelSpadValue(htPage, 'my) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (mx = '7 and my = '6) => e01dafDefaultSolve(htPage,ifail) + xList := + "append"/[f(i) for i in 1..mx] where f(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[6, 0.0, xnam, 'F]]] + prefix := ('"\newline \menuitemstyle{}\tab{2} Values of X(1) to X(MX): \newline ") + xList := [['text,:prefix],:xList] + yList := + "append"/[g(i) for i in 1..my] where g(i) == + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['bcStrings,[6, 0.0, ynam, 'F]]] + prefix := ('"\blankline\menuitemstyle{}\tab{2}Values of Y(1) to Y(MY): \newline ") + yList := [['text,:prefix],:yList] + fList := + "append"/[h(j,my) for j in 1..mx] where h(j,my) == + tempList := + "append"/[k(j,m) for m in 1..my] where k(j,m) == + fnam := INTERN STRCONC ('"f",STRINGIMAGE j, STRINGIMAGE m) + [['bcStrings,[6, 0.0, fnam, 'F]]] + prefix := ('"\newline ") + tempList := [['text,:prefix],:tempList] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of F(MX*MY) ") + prefix := STRCONC(prefix,'"(x down, y across): ") + fList := [['text,:prefix],:fList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :xList,:yList,:fList] + page := htInitPage("E01DAF - Interpolating functions, fitting bicubic spline, data on a rectanglar grid",htpPropertyList htPage) + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01dafGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01dafDefaultSolve (htPage,ifail) == + mx := '7 + my := '6 + page := htInitPage('"E01DAF - Interpolating functions, fitting bicubic spline, data on rectangular grid",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of X(1) to X(MX): ") + (text . "\newline ") + (bcStrings (6 "1.00" x1 F)) + (bcStrings (6 "1.10" x2 F)) + (bcStrings (6 "1.30" x3 F)) + (bcStrings (6 "1.50" x4 F)) + (bcStrings (6 "1.60" x5 F)) + (bcStrings (6 "1.80" x6 F)) + (bcStrings (6 "2.00" x7 F)) + (text . "\blankline ") + (text . "\newline ") + (text ."\menuitemstyle{} \tab{2} Values of Y(1) to Y(MY): ") + (text . "\newline ") + (bcStrings (6 "0.00" y1 F)) + (bcStrings (6 "0.10" y2 F)) + (bcStrings (6 "0.40" y3 F)) + (bcStrings (6 "0.70" y4 F)) + (bcStrings (6 "0.90" y5 F)) + (bcStrings (6 "1.00" y6 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} Values of F(MX*MY) (x down, y across): ") + (text . "\newline ") + (bcStrings (6 "1.00" z11 F)) + (bcStrings (6 "1.10" z21 F)) + (bcStrings (6 "1.40" z31 F)) + (bcStrings (6 "1.70" z41 F)) + (bcStrings (6 "1.90" z51 F)) + (bcStrings (6 "2.00" z61 F)) + (text . "\newline ") + (bcStrings (6 "1.21" z12 F)) + (bcStrings (6 "1.31" z22 F)) + (bcStrings (6 "1.61" z32 F)) + (bcStrings (6 "1.91" z42 F)) + (bcStrings (6 "2.11" z52 F)) + (bcStrings (6 "2.21" z62 F)) + (text . "\newline ") + (bcStrings (6 "1.69" z13 F)) + (bcStrings (6 "1.79" z23 F)) + (bcStrings (6 "2.09" z33 F)) + (bcStrings (6 "2.39" z43 F)) + (bcStrings (6 "2.59" z53 F)) + (bcStrings (6 "2.69" z63 F)) + (text . "\newline ") + (bcStrings (6 "2.25" z14 F)) + (bcStrings (6 "2.35" z24 F)) + (bcStrings (6 "2.65" z34 F)) + (bcStrings (6 "2.95" z44 F)) + (bcStrings (6 "3.15" z54 F)) + (bcStrings (6 "3.25" z64 F)) + (text . "\newline ") + (bcStrings (6 "2.56" z15 F)) + (bcStrings (6 "2.66" z25 F)) + (bcStrings (6 "2.96" z35 F)) + (bcStrings (6 "3.26" z45 F)) + (bcStrings (6 "3.46" z55 F)) + (bcStrings (6 "3.56" z65 F)) + (text . "\newline ") + (bcStrings (6 "3.24" z16 F)) + (bcStrings (6 "3.34" z26 F)) + (bcStrings (6 "3.64" z36 F)) + (bcStrings (6 "3.94" z46 F)) + (bcStrings (6 "4.14" z56 F)) + (bcStrings (6 "4.24" z66 F)) + (text . "\newline ") + (bcStrings (6 "4.00" z17 F)) + (bcStrings (6 "4.10" z27 F)) + (bcStrings (6 "4.40" z37 F)) + (bcStrings (6 "4.70" z47 F)) + (bcStrings (6 "4.90" z57 F)) + (bcStrings (6 "5.00" z67 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01dafGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01dafGen htPage == + mx := htpProperty(htPage,'mx) + my := htpProperty(htPage,'my) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1, " ") + y := rest y + xlist := [right,:xlist] + for i in 1..mx repeat + xmx := [:xmx,(first xlist)] + xlist := rest xlist + xstring := bcwords2liststring xmx + for i in 1..my repeat + ymy := [:ymy,(first xlist)] + xlist := rest xlist + ystring := bcwords2liststring ymy + fstring := bcwords2liststring xlist + prefix := STRCONC('"e01daf(",STRINGIMAGE mx,", ",STRINGIMAGE my,",[") + midd := STRCONC(xstring, "], [",ystring,"], [",fstring,"], ") + linkGen STRCONC(prefix,midd,STRINGIMAGE ifail,")") + +e01saf() == + htInitPage('"E01SAF - Interpolating functions, method of Renka and Cline, two variables", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01saf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01saf| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a \htbitmap{c1} piecewise polynomial ") + (text . "surface F(x,y) interpolating the set of scattered points ") + (text . "(\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}), ") + (text . "for r = 1,2,...,m, using a method of Renka and Cline. ") + (text . "The interpolant can be evaluated using E01SBF. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\em m} \htbitmap{great=} 3:") + (text . "\newline \tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01safSolve) + htShowPage() + +e01safSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + m = '30 => e01safDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01SAF - Interpolating functions, method of Renka and Cline,two variables",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01safGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01safDefaultSolve (htPage, ifail) == + m := '30 + page := htInitPage('"E01SAF - Interpolating functions, method of Renka and Cline, two variables",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{dr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "11.16" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.24" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "22.15" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.85" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.06" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "22.11" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "19.85" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.72" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "7.97" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "19.72" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.39" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "16.83" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.91" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.74" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "15.30" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "34.60" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.87" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.74" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.45" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.78" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "41.24" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "14.26" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "17.87" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "10.74" z9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.43" x10 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.46" y10 F)) + (text . "\tab{42} ") + (bcStrings (10 "18.60" z10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.80" x11 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.39" y11 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.47" z11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.58" x12 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.98" y12 F)) + (text . "\tab{42} ") + (bcStrings (10 "29.87" z12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "25.00" x13 F)) + (text . "\tab{22} ") + (bcStrings (10 "11.87" y13 F)) + (text . "\tab{42} ") + (bcStrings (10 "4.40" z13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x14 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" y14 F)) + (text . "\tab{42} ") + (bcStrings (10 "58.20" z14 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.66" x15 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y15 F)) + (text . "\tab{42} ") + (bcStrings (10 "4.73" z15 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.22" x16 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.66" y16 F)) + (text . "\tab{42} ") + (bcStrings (10 "40.36" z16 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.25" x17 F)) + (text . "\tab{22} ") + (bcStrings (10 "19.57" y17 F)) + (text . "\tab{42} ") + (bcStrings (10 "6.43" z17 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "25.00" x18 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.87" y18 F)) + (text . "\tab{42} ") + (bcStrings (10 "8.74" z18 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.13" x19 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.79" y19 F)) + (text . "\tab{42} ") + (bcStrings (10 "13.71" z19 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.23" x20 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.21" y20 F)) + (text . "\tab{42} ") + (bcStrings (10 "10.25" z20 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "11.52" x21 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.53" y21 F)) + (text . "\tab{42} ") + (bcStrings (10 "15.74" z21 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.20" x22 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.0" y22 F)) + (text . "\tab{42} ") + (bcStrings (10 "21.60" z22 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.54" x23 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.69" y23 F)) + (text . "\tab{42} ") + (bcStrings (10 "19.31" z23 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.32" x24 F)) + (text . "\tab{22} ") + (bcStrings (10 "13.78" y24 F)) + (text . "\tab{42} ") + (bcStrings (10 "12.11" z24 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.14" x25 F)) + (text . "\tab{22} ") + (bcStrings (10 "15.03" y25 F)) + (text . "\tab{42} ") + (bcStrings (10 "53.10" z25 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.51" x26 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.37" y26 F)) + (text . "\tab{42} ") + (bcStrings (10 "49.43" z26 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.69" x27 F)) + (text . "\tab{22} ") + (bcStrings (10 "19.63" y27 F)) + (text . "\tab{42} ") + (bcStrings (10 "3.25" z27 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.47" x28 F)) + (text . "\tab{22} ") + (bcStrings (10 "17.13" y28 F)) + (text . "\tab{42} ") + (bcStrings (10 "28.63" z28 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "21.67" x29 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.36" y29 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.52" z29 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.31" x30 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.33" y30 F)) + (text . "\tab{42} ") + (bcStrings (10 "44.08" z30 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01safGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01safGen htPage == + m := htpProperty(htPage,'m) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + flist := [mid,:flist] + dlist := [right,:dlist] + xstring := bcwords2liststring xlist + fstring := bcwords2liststring flist + dstring := bcwords2liststring dlist + prefix := STRCONC('"e01saf(",STRINGIMAGE m,",[",xstring,"],[",fstring,"],[") + prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE ifail,")") + linkGen prefix + +e01sef() == + htInitPage('"E01SEF - Interpolating functions, modified Shepard's method, two variables", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe01sef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e01sef| '|NagInterpolationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a \htbitmap{c1} piecewise polynomial ") + (text . "surface F(x,y) interpolating the set of scattered points ") + (text . "(\htbitmap{xr}, \htbitmap{yr}, \htbitmap{fqr}), ") + (text . "for r = 1,2,...,m, using a modified Shepard method. ") + (text . "The interpolant can be evaluated using E01SFF. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\em m} \htbitmap{great=} 3:") + (text . "\newline \tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline ") + (text . "Note: RNW, RNQ, NW, NQ set to zero for default value. ") + (text . "On exit, they contain the value actually used. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline {\em RNW} weight locality radius: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "{\em RNQ} point locality radius:") + (text . "\newline\tab{2} ") + (bcStrings (6 "0.0" rnw F)) + (text . "\tab{34} ") + (bcStrings (6 "0.0" rnq F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} \newline") + (text . "{\em NW} average number of points within RNW of each point: ") + (text . "\newline \tab{2} ") + (bcStrings (6 0 nw I)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} \newline") + (text . "{\em NQ} average number of points within RNQ of each point: ") + (text . "\newline \tab{2} ") + (bcStrings (6 0 nq I)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e01sefSolve) + htShowPage() + +e01sefSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + nw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nw) + objValUnwrap htpLabelSpadValue(htPage, 'nw) + nq := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nq) + objValUnwrap htpLabelSpadValue(htPage, 'nq) + rnq := htpLabelInputString(htPage,'rnq) + rnw := htpLabelInputString(htPage,'rnw) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + m = '30 => e01sefDefaultSolve(htPage,rnq,rnw,nq,nw,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E01SEF - Interpolating functions, modified Shepard's method, two variables",htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e01sefGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'rnq,rnq) + htpSetProperty(page,'rnw,rnw) + htpSetProperty(page,'nq,nq) + htpSetProperty(page,'nw,nw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e01sefDefaultSolve (htPage,rnq,rnw,nq,nw,ifail) == + m := '30 + page := htInitPage('"E01SEF - Interpolating functions, modified Shepard's method, two variables",htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{fr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{dr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "11.16" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.24" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "22.15" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.85" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.06" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "22.11" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "19.85" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.72" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "7.97" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "19.72" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.39" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "16.83" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.91" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.74" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "15.30" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "34.60" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "20.87" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.74" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.45" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.78" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "41.24" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "14.26" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "17.87" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "10.74" z9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.43" x10 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.46" y10 F)) + (text . "\tab{42} ") + (bcStrings (10 "18.60" z10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.80" x11 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.39" y11 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.47" z11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.58" x12 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.98" y12 F)) + (text . "\tab{42} ") + (bcStrings (10 "29.87" z12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "25.00" x13 F)) + (text . "\tab{22} ") + (bcStrings (10 "11.87" y13 F)) + (text . "\tab{42} ") + (bcStrings (10 "4.40" z13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" x14 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" y14 F)) + (text . "\tab{42} ") + (bcStrings (10 "58.20" z14 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.66" x15 F)) + (text . "\tab{22} ") + (bcStrings (10 "20.00" y15 F)) + (text . "\tab{42} ") + (bcStrings (10 "4.73" z15 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.22" x16 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.66" y16 F)) + (text . "\tab{42} ") + (bcStrings (10 "40.36" z16 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.25" x17 F)) + (text . "\tab{22} ") + (bcStrings (10 "19.57" y17 F)) + (text . "\tab{42} ") + (bcStrings (10 "6.43" z17 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "25.00" x18 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.87" y18 F)) + (text . "\tab{42} ") + (bcStrings (10 "8.74" z18 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.13" x19 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.79" y19 F)) + (text . "\tab{42} ") + (bcStrings (10 "13.71" z19 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.23" x20 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.21" y20 F)) + (text . "\tab{42} ") + (bcStrings (10 "10.25" z20 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "11.52" x21 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.53" y21 F)) + (text . "\tab{42} ") + (bcStrings (10 "15.74" z21 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "15.20" x22 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.0" y22 F)) + (text . "\tab{42} ") + (bcStrings (10 "21.60" z22 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.54" x23 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.69" y23 F)) + (text . "\tab{42} ") + (bcStrings (10 "19.31" z23 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "17.32" x24 F)) + (text . "\tab{22} ") + (bcStrings (10 "13.78" y24 F)) + (text . "\tab{42} ") + (bcStrings (10 "12.11" z24 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.14" x25 F)) + (text . "\tab{22} ") + (bcStrings (10 "15.03" y25 F)) + (text . "\tab{42} ") + (bcStrings (10 "53.10" z25 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.51" x26 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.37" y26 F)) + (text . "\tab{42} ") + (bcStrings (10 "49.43" z26 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "22.69" x27 F)) + (text . "\tab{22} ") + (bcStrings (10 "19.63" y27 F)) + (text . "\tab{42} ") + (bcStrings (10 "3.25" z27 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.47" x28 F)) + (text . "\tab{22} ") + (bcStrings (10 "17.13" y28 F)) + (text . "\tab{42} ") + (bcStrings (10 "28.63" z28 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "21.67" x29 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.36" y29 F)) + (text . "\tab{42} ") + (bcStrings (10 "5.52" z29 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.31" x30 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.33" y30 F)) + (text . "\tab{42} ") + (bcStrings (10 "44.08" z30 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e01sefGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'rnq,rnq) + htpSetProperty(page,'rnw,rnw) + htpSetProperty(page,'nq,nq) + htpSetProperty(page,'nw,nw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e01sefGen htPage == + m := htpProperty(htPage,'m) + rnw := htpProperty(htPage,'rnw) + rnq := htpProperty(htPage,'rnq) + nw := htpProperty(htPage,'nw) + nq := htpProperty(htPage,'nq) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + flist := [mid,:flist] + dlist := [right,:dlist] + xstring := bcwords2liststring xlist + fstring := bcwords2liststring flist + dstring := bcwords2liststring dlist + prefix := STRCONC('"e01sef(",STRINGIMAGE m,",[",xstring,"],[",fstring,"],[") + prefix := STRCONC(prefix,dstring,"],",STRINGIMAGE nw,", ",STRINGIMAGE nq) + prefix := STRCONC(prefix,", ",rnw,", ",rnq,", ",STRINGIMAGE ifail,")") + linkGen prefix +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-e02.boot b/src/interp/nag-e02.boot deleted file mode 100644 index 8c661a60..00000000 --- a/src/interp/nag-e02.boot +++ /dev/null @@ -1,4671 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -e02adf() == - htInitPage('"E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02adf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines weighted least-squares polynomial approximations of ") - (text . "degrees 0,1,...,k to the set of points {\it (} ") - (text . "\htbitmap{xr}, \htbitmap{yr}{\it )} ") - (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") - (text . "The polynomials are in the Chebyshev series form, the ") - (text . "approximation of degree {\it i} being represented as ") - (text . "\newline \center{\htbitmap{e02adf}} , where ") - (text . "\htbitmap{xbar} is the normalised argument, which is ") - (text . "related to the original variable {\it x} by the transformation ") - (text . "\blankline \center{\htbitmap{e02adf1}} ") - (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") - (text . "the values of \htbitmap{xr} respectively ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}:") - (text . "\newline \tab{2} ") - (bcStrings (6 11 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Maximum degree required {\it k}:") - (text . "\newline \tab{2} ") - (bcStrings (6 3 k PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "First dimension of A, {\it nrows} \htbitmap{great=} {\it k+1}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 50 nrows I)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02adfSolve) - htShowPage() - -e02adfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - k := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) - objValUnwrap htpLabelSpadValue(htPage, 'k) - nrows := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrows) - objValUnwrap htpLabelSpadValue(htPage, 'nrows) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '11 and k ='3) => e02adfDefaultSolve(htPage,k,nrows,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", htpPropertyList htPage) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02adfGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'k,k) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02adfDefaultSolve (htPage,k,nrows,ifail) == - m := '11 - page := htInitPage('"E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{wr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "1.00" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.40" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.10" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.90" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.10" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.70" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.90" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.50" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.90" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.20" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.80" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.20" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.80" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.50" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "5.10" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.80" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.10" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "9.20" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.70" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.80" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "16.10" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.50" z9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.40" x10 F)) - (text . "\tab{22} ") - (bcStrings (10 "24.50" y10 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.30" z10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.00" x11 F)) - (text . "\tab{22} ") - (bcStrings (10 "35.30" y11 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.20" z11 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02adfGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'k,k) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02adfGen htPage == - m := htpProperty(htPage,'m) - k := htpProperty(htPage,'k) - nrows := htpProperty(htPage,'nrows) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - kplus1 := k + 1 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - wlist := [right,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - wstring := bcwords2liststring wlist - prefix := STRCONC('"e02adf(",STRINGIMAGE m,", ",STRINGIMAGE kplus1,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrows,", [",xstring,"],[",ystring,"],[") - prefix := STRCONC(prefix,wstring,"],",STRINGIMAGE ifail,")") - linkGen prefix - -e02aef() == - htInitPage('"E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series form", nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02aef| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates a polynomial in Chabyshev series representation ") - (text . "\newline \center{\htbitmap{e02aef}} ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of terms in the series {\it n}:") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\htbitmap{xbar}: ") - (text . " \newline \tab{2} ") - (bcStrings (6 "-1.0" xcap F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02aefSolve) - htShowPage() - -e02aefSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - xcap := htpLabelInputString(htPage,'xcap) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => e02aefDefaultSolve(htPage,xcap,ifail) - labelList := - "append"/[f(i) for i in 1..(n+1)] where f(i) == - prefix := ('"\newline \tab{15} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, anam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series from", nil) - htSay '"\menuitemstyle{}\tab{2} Enter the coefficients of {\it a(n+1)}:" - htSay '"\blankline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02aefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'xcap,xcap) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02aefDefaultSolve (htPage,xcap,ifail) == - n := '4 - page := htInitPage('"E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series form", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the coeffients of {\it a(n+1)}: ") - (text . "\blankline ") - (text . "\newline \tab{15} ") - (bcStrings (10 "2.0000" a1 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.5000" a2 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.2500" a3 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.1250" a4 F)) - (text . "\newline \tab{15} ") - (bcStrings (10 "0.0625" a5 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'e02aefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'xcap,xcap) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02aefGen htPage == - n := htpProperty(htPage,'n) - xcap := htpProperty(htPage,'xcap) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - nplus1 := n + 1 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - arrayList := [right,:arrayList] - astring := bcwords2liststring arrayList - prefix := STRCONC('"e02aef(",STRINGIMAGE nplus1,", [",astring ,"], ") - prefix := STRCONC(prefix,STRINGIMAGE xcap,", ",STRINGIMAGE ifail,")") - linkGen prefix - -e02agf() == - htInitPage('"E02AGF - Least-squares polynomial fit, values and derivatives may be constrained, arbitrary data values",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02agf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02agf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines constrained least-squares polynomial approximations ") - (text . "to the set of points {\it (\htbitmap{xr},\htbitmap{yr})} with ") - (text . "weights \htbitmap{wr}, for r = 1,2,...,m. The values of the ") - (text . "approximations and any number of their derivatives must be ") - (text . "specified at a further set of points \htbitmap{xii}, ") - (text . "for i = 1,2,...,{\it mf}. The total number of interpolating ") - (text . "conditions is given by \center{\htbitmap{e02agf}} where ") - (text . "\htbitmap{pi} is the highest order derivative ") - (text . "specified at point \htbitmap{xii}. The values ") - (text . "\htbitmap{xr} and \htbitmap{xii} all lie ") - (text . "in the interval [\htbitmap{xmin},") - (text . "\htbitmap{xmax}]. The polynomials are given in ") - (text . "Chebyshev series form, the approximation of degree {\it i} being") - (text . " represented as\blankline \center{\htbitmap{e02agf1}}") - (text . "\newline, where \htbitmap{xbar} is the normalised ") - (text . "argument, related to the original variable {\it x} by the ") - (text . "transformation \newline \center{\htbitmap{e02adf1}} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Number of data points {\it m}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Maximum degree required {\it k}:") - (text . "\newline\tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 4 k PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "First dimension of A, {\it nrows \htbitmap{great=} k+1}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 6 nrows I)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline \htbitmap{xmin}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\htbitmap{xmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "0.0" xmin F)) - (text . "\tab{34} ") - (bcStrings (6 "4.0" xmax F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Dimension of {\it xf} & {\it ip}, {\it mf}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Dimension of {\it yf}, {\it lyf}:") - (text . "\newline\tab{2} ") - (bcStrings (6 2 mf PI)) - (text . "\tab{34} ") - (bcStrings (6 15 lyf PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02agfSolve) - htShowPage() - -e02agfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - k := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) - objValUnwrap htpLabelSpadValue(htPage, 'kplus1) - nrows := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrows) - objValUnwrap htpLabelSpadValue(htPage, 'nrows) - xmin := htpLabelInputString(htPage,'xmin) - xmax := htpLabelInputString(htPage,'xmax) - mf := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mf) - objValUnwrap htpLabelSpadValue(htPage, 'mf) - lyf := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lyf) - objValUnwrap htpLabelSpadValue(htPage, 'lyf) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '5 and k ='4 and mf = '2 and lyf = '15) => e02agfDefaultSolve(htPage,nrows,xmin,xmax,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - xfList := - "append"/[g(j) for j in 1..mf] where g(j) == - xfnam := INTERN STRCONC ('"xf",STRINGIMAGE j) - [['bcStrings,[6, 0.0, xfnam, 'F]]] - prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") - prefix := STRCONC(prefix,"{\it xf}: \newline \tab{2} ") - xfList := [['text,:prefix],:xfList] - ipList := - "append"/[h(k) for k in 1..mf] where h(k) == - ipnam := INTERN STRCONC ('"ip",STRINGIMAGE k) - [['bcStrings,[6, 0, ipnam, 'PI]]] - prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") - prefix := STRCONC(prefix,"{\it ip}: \newline \tab{2} ") - ipList := [['text,:prefix],:ipList] - yfList := - "append"/[i(l) for l in 1..lyf] where i(l) == - prefix := ('"\newline \tab{2} ") - yfnam := INTERN STRCONC ('"lyf",STRINGIMAGE l) - [['text,:prefix],['bcStrings,[10, 0.0, yfnam, 'F]]] - prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") - prefix := STRCONC(prefix,"{\it yf}: \newline \tab{2} ") - yfList := [['text,:prefix],:yfList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:xfList,:ipList,:yfList] - page := htInitPage("E02AGF - Least-squares polynomial fit, values and derivatives may be constrained, arbitrary data values",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{wr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02agfGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'k,k) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'mf,mf) - htpSetProperty(page,'lyf,lyf) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02agfDefaultSolve (htPage,nrows,xmin,xmax,ifail) == - m := '5 - k := '4 - mf := '2 - lyf := '15 - page := htInitPage('"E02AGF - Least-squares polynomial fit, values and derivativesby polynomials, arbitrary data points", htpPropertyList htPage) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{wr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.5" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.03" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.0" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.0" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "-0.75" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.0" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.0" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "-1.0" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.0" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.5" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "-0.1" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.0" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.0" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.75" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.0" z5 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it xf}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" xf1 F)) - (bcStrings (6 "4.0" xf2 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it ip}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 ip1 PI)) - (bcStrings (6 0 ip2 PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it yf}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "1.0" lyf1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "-2.0" lyf2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.0" lyf3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf14 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" lyf15 F))) - htMakeDoneButton('"Continue",'e02agfGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'k,k) - htpSetProperty(page,'nrows,nrows) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'mf,mf) - htpSetProperty(page,'lyf,lyf) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02agfGen htPage == - m := htpProperty(htPage,'m) - k := htpProperty(htPage,'k) - nrows := htpProperty(htPage,'nrows) - xmin := htpProperty(htPage,'xmin) - xmax := htpProperty(htPage,'xmax) - mf := htpProperty(htPage,'mf) - lyf := htpProperty(htPage,'lyf) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - kplus1 := k + 1 - ipsum := 0 - y := alist - for i in 1..lyf repeat - yf := STRCONC((first y).1," ") - yfList := [yf,:yfList] - y := rest y - yfstring := bcwords2liststring yfList - for i in 1..mf repeat - iptest := (first y).1 - iptestval := READ_-FROM_-STRING(iptest) - ipsum := ipsum + iptestval - ip := STRCONC(iptest," ") - iptestList := [iptestval,:iptestList] - ipList := [ip,:ipList] - y := rest y - ipstring := bcwords2liststring ipList - ipmax := APPLY ('MAX, iptestList) - n := mf + ipsum - for i in 1..mf repeat - xf := STRCONC((first y).1," ") - xfList := [xf,:xfList] - y := rest y - xfstring := bcwords2liststring xfList - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - wlist := [right,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - wstring := bcwords2liststring wlist - wrktest1 := 4*m + 3*kplus1 - wrktest2 := 8*n + 5*ipmax + mf +10 - wrktestlist := [wrktest1,wrktest2] - wrkmax := APPLY ('MAX, wrktestlist) - lwrk := wrkmax + 2*n + 2 - liwrk := 2*mf + 2 - prefix := STRCONC('"e02agf(",STRINGIMAGE m,", ",STRINGIMAGE kplus1,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrows,", ",xmin,", ",xmax,", [",xstring) - prefix := STRCONC(prefix,"],[",ystring,"],[",wstring,"],",STRINGIMAGE mf) - prefix := STRCONC(prefix,", [",xfstring,"],[",yfstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE lyf,", [",ipstring,"]::Matrix Integer,") - prefix := STRCONC(prefix,STRINGIMAGE lwrk,", ",STRINGIMAGE liwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e02ahf() == - htInitPage('"E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02ahf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ahf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines the indefinite integral of the Chebyshev series ") - (text . "representation \newline \center{\htbitmap{e02ahf1}} ") - (text . "of a polynomial, where \htbitmap{xbar} is the ") - (text . "normalised argument, related to the original variable x by the ") - (text . "transformation \blankline \center{\htbitmap{e02adf1}}") - (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") - (text . "minimum and maximum values of {\it x} respectively. The integral") - (text . " polynomial has the form ") - (text . "\blankline \center{\htbitmap{e02ahf}}") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Degree of the polynomial {\it n}:") - (text . "\newline \tab{2} ") - (bcStrings (6 6 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline \htbitmap{xmin}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\htbitmap{xmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "-0.5" xmin F)) - (text . "\tab{34} ") - (bcStrings (6 "2.5" xmax F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Dimension of array {\it a}, {\it la}: ") --- (text . "\tab{32} \menuitemstyle{}\tab{34}") --- (text . "Dimension of {\it adif}, {\it ladif}: ") --- (text . "\newline\tab{2} ") --- (bcStrings (6 7 la PI)) --- (text . "\tab{34} ") --- (bcStrings (6 7 ladif PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Increment of array {\it a}, {\it ia1}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\newline Increment of array {\it adif}, {\it ladif1}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 1 iaone PI)) - (text . "\tab{34} ") - (bcStrings (6 1 ladifone PI)) - (text . "\blankline") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02ahfSolve) - htShowPage() - -e02ahfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - xmin := htpLabelInputString(htPage,'xmin) - xmax := htpLabelInputString(htPage,'xmax) - iaone := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) - objValUnwrap htpLabelSpadValue(htPage, 'iaone) - ladifone := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ladifone) - objValUnwrap htpLabelSpadValue(htPage, 'ladifone) - la := 1+n*iaone --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) --- objValUnwrap htpLabelSpadValue(htPage, 'la) - ladif :=1+n*ladifone --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ladif) --- objValUnwrap htpLabelSpadValue(htPage, 'ladif) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and (la ='7 and ladif = '7)) => - e02ahfDefaultSolve(htPage,xmin,xmax,iaone,ladifone,ifail) - labelList := - "append"/[f(i) for i in 1..la] where f(i) == - prefix := ('"\newline \tab{15} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) - htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ahfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'ladif,ladif) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'ladifone,ladifone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02ahfDefaultSolve (htPage,xmin,xmax,iaone,ladifone,ifail) == - n := '6 - la := '7 - ladif := '7 - page := htInitPage('"E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} ") - (text . "Coefficients of {\it a(la)}: ") - (text . "\newline \tab{15}") - (bcStrings (10 "2.53213" a1 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "1.13032" a2 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.27150" a3 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.04434" a4 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00547" a5 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00054" a6 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00004" a7 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02ahfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'ladif,ladif) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'ladifone,ladifone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02ahfGen htPage == - n := htpProperty(htPage,'n) - la := htpProperty(htPage,'la) - ladif := htpProperty(htPage,'ladif) - xmin := htpProperty(htPage,'xmin) - xmax := htpProperty(htPage,'xmax) - iaone := htpProperty(htPage,'iaone) - ladifone := htpProperty(htPage,'ladifone) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - np1 := n + 1 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - arrayList := [right,:arrayList] - astring := bcwords2liststring arrayList - prefix := STRCONC('"e02ahf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") - prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") - prefix := STRCONC(prefix,STRINGIMAGE la,", ",STRINGIMAGE ladifone,", ") - prefix := STRCONC(prefix,STRINGIMAGE ladif,", ",STRINGIMAGE ifail,")") - linkGen prefix - -e02ajf() == - htInitPage('"E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02ajf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ajf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines the indefinite integral of the Chebyshev series ") - (text . "representation \newline \center{\htbitmap{e02ahf1}} ") - (text . "of a polynomial, where \htbitmap{xbar} is the normalis") - (text . "ed argument, related to the original variable {\it x} by the ") - (text . "transformation \blankline \center{\htbitmap{e02adf1}}") - (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") - (text . "minimum and maximum values of {\it x} respectively. The integral") - (text . " polynomial has the form ") - (text . "\blankline \center{\htbitmap{e02ajf}}") - (text . "and the integration is with respect to the original variable ") - (text . "{\it x} \blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Degree of the polynomial {\it n}:") - (text . "\newline \tab{2} ") - (bcStrings (6 6 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline \htbitmap{xmin}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\htbitmap{xmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "-0.5" xmin F)) - (text . "\tab{34} ") - (bcStrings (6 "2.5" xmax F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Dimension of array {\it a}, {\it la}: ") --- (text . "\tab{32} \menuitemstyle{}\tab{34}") --- (text . "Dimension of {\it aint}, {\it laint}: ") --- (text . "\newline\tab{2} ") --- (bcStrings (6 7 la PI)) --- (text . "\tab{34} ") --- (bcStrings (6 8 laint PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Index increment of {\it a}, {\it ia1}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Increment of {\it aint}, {\it iaint1}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 iaone PI)) - (text . "\tab{34} ") - (bcStrings (6 1 iaintone PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Constant of integration {\it qatm1}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" qatmone F)) - (text . "\blankline") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02ajfSolve) - htShowPage() - -e02ajfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - xmin := htpLabelInputString(htPage,'xmin) - xmax := htpLabelInputString(htPage,'xmax) - iaone := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) - objValUnwrap htpLabelSpadValue(htPage, 'iaone) - iaintone := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaintone) - objValUnwrap htpLabelSpadValue(htPage, 'iaintone) - la := 1+n*iaone --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) --- objValUnwrap htpLabelSpadValue(htPage, 'la) - laint := n*iaintone + 1 - qatmone := htpLabelInputString(htPage,'qatmone) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and (la ='7 and laint = '7)) => - e02ajfDefaultSolve(htPage,xmin,xmax,iaone,iaintone,qatmone,ifail) - labelList := - "append"/[f(i) for i in 1..la] where f(i) == - prefix := ('"\newline \tab{15} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) - htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ajfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'laint,laint) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'iaintone,iaintone) - htpSetProperty(page,'qatmone,qatmone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02ajfDefaultSolve (htPage,xmin,xmax,iaone,iaintone,qatmone,ifail) == - n := '6 - la := '7 - laint := '8 - page := htInitPage('"E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} ") - (text . "Coefficients of {\it a(la)}: ") - (text . "\newline \tab{15}") - (bcStrings (10 "2.53213" a1 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "1.13032" a2 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.27150" a3 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.04434" a4 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00547" a5 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00054" a6 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00004" a7 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02ajfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'laint,laint) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'iaintone,iaintone) - htpSetProperty(page,'qatmone,qatmone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02ajfGen htPage == - n := htpProperty(htPage,'n) - la := htpProperty(htPage,'la) - laint := htpProperty(htPage,'laint) - xmin := htpProperty(htPage,'xmin) - xmax := htpProperty(htPage,'xmax) - iaone := htpProperty(htPage,'iaone) - iaintone := htpProperty(htPage,'iaintone) - qatmone := htpProperty(htPage,'qatmone) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - np1 := n + 1 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - arrayList := [right,:arrayList] - astring := bcwords2liststring arrayList - prefix := STRCONC('"e02ajf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") - prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") - prefix := STRCONC(prefix,STRINGIMAGE la,", ",qatmone,", ") - prefix := STRCONC(prefix,STRINGIMAGE iaintone) - prefix := STRCONC(prefix,", ",STRINGIMAGE laint,", ",STRINGIMAGE ifail,")") - linkGen prefix - -e02akf() == - htInitPage('"E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02akf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02akf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates at the point x the Chebyshev series representation ") - (text . "representation \newline \center{\htbitmap{e02ahf1}} ") - (text . "of a polynomial, where \htbitmap{xbar} is the normalis") - (text . "ed argument, related to the original variable {\it x} by the ") - (text . "transformation \blankline \center{\htbitmap{e02adf1}}") - (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") - (text . "minimum and maximum values of {\it x} respectively. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Degree of the polynomial {\it n}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Evaluation point {\it x}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 6 n PI)) - (text . "\tab{34} ") - (bcStrings (6 "-0.5" x F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline \htbitmap{xmin}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "\htbitmap{xmax}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "-0.5" xmin F)) - (text . "\tab{34} ") - (bcStrings (6 "2.5" xmax F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Dimension of array {\it a}, {\it la} : ") --- (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Index increment of {\it a}, {\it ia1}: ") - (text . "\newline\tab{2} ") --- (bcStrings (6 7 la PI)) --- (text . "\tab{34} ") - (bcStrings (6 1 iaone PI)) - (text . "\blankline") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02akfSolve) - htShowPage() - -e02akfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - x := htpLabelInputString(htPage,'x) - xmin := htpLabelInputString(htPage,'xmin) - xmax := htpLabelInputString(htPage,'xmax) - iaone := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) - objValUnwrap htpLabelSpadValue(htPage, 'iaone) - la := 1+n*iaone --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) --- objValUnwrap htpLabelSpadValue(htPage, 'la) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and la ='7) => e02akfDefaultSolve(htPage,xmin,xmax,x,iaone,ifail) - labelList := - "append"/[f(i) for i in 1..la] where f(i) == - prefix := ('"\newline \tab{15} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) - htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02akfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'x,x) - htpSetProperty(page,'la,la) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02akfDefaultSolve (htPage,xmin,xmax,x,iaone,ifail) == - n := '6 - la := '7 - page := htInitPage('"E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} ") - (text . "Coefficients of {\it a(la)}: ") - (text . "\newline \tab{15}") - (bcStrings (10 "2.53213" a1 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "1.13032" a2 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.27150" a3 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.04434" a4 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00547" a5 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00054" a6 F)) - (text . "\newline \tab{15}") - (bcStrings (10 "0.00004" a7 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02akfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'x,x) - htpSetProperty(page,'xmin,xmin) - htpSetProperty(page,'xmax,xmax) - htpSetProperty(page,'iaone,iaone) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02akfGen htPage == - n := htpProperty(htPage,'n) - x := htpProperty(htPage,'x) - la := htpProperty(htPage,'la) - xmin := htpProperty(htPage,'xmin) - xmax := htpProperty(htPage,'xmax) - iaone := htpProperty(htPage,'iaone) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - np1 := n + 1 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - arrayList := [right,:arrayList] - astring := bcwords2liststring arrayList - prefix := STRCONC('"e02akf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") - prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") - prefix := STRCONC(prefix,STRINGIMAGE la,", ",x,", ",STRINGIMAGE ifail,")") - linkGen prefix - - -e02baf() == - htInitPage('"E02BAF - Least-squares curve cubic spine fit",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02baf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02baf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a least-squares cubic spline approximation to the ") - (text . "set of points {\it (}\htbitmap{xr},") - (text . "\htbitmap{yr}{\it )} with weights ") - (text . "\htbitmap{wr}, for r = 1,2,...,m. ") - (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") - (text . "\htbitmap{ncap}+7, are prescribed by the user. The ") - (text . "spline is given by the B-spline representation \blankline ") - (text . "\center{\htbitmap{e02baf}} where ") - (text . "\htbitmap{ncap} is the number of intervals of the ") - (text . "spline. \blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}:") - (text . "\newline \tab{2} ") - (bcStrings (6 14 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of intervals in the spline \htbitmap{ncap}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 5 ncap PI)) - (text . "\blankline") - (text . "\newline") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02bafSolve) - htShowPage() - -e02bafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - ncap := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) - objValUnwrap htpLabelSpadValue(htPage, 'ncap) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '14 and ncap ='5) => e02bafDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - lamdaList := - "append"/[g(j) for j in 5..(ncap+3)] where g(j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE j) - [['bcStrings,[6, 0.0, anam, 'F]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} Interior knots ") - prefix := STRCONC(prefix,"\htbitmap{lamdai}, for i = 5,6,...,") - prefix := STRCONC(prefix,"\htbitmap{ncap} + 3: \newline \tab{2}" ) - lamdaList := [['text,:prefix],:lamdaList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamdaList] - page := htInitPage("E02BAF - Least-squares curve cubic spline fit",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{dr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02bafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02bafDefaultSolve (htPage,ifail) == - m := '14 - ncap := '5 - page := htInitPage('"E02BAF - Least-squares curve cubic spline fit",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{wr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.20" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.20" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.47" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.00" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.20" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.74" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.00" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.30" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.09" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.00" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.70" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.60" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.00" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.90" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.90" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.62" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.60" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "9.10" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.10" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.90" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "8.15" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.80" z9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.15" x10 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.00" y10 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.50" z10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.17" x11 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.00" y11 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.70" z11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.00" x12 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.54" y12 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "10.00" x13 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.39" y13 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "12.00" x14 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.56" y14 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "Interior knots \htbitmap{lamdai}, for i = 5,6,...") - (text . "\htbitmap{ncap} + 3: \newline \tab{2}") - (bcStrings (6 "1.50" l1 F)) - (bcStrings (6 "2.60" l2 F)) - (bcStrings (6 "4.00" l3 F)) - (bcStrings (6 "8.00" l4 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02bafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02bafGen htPage == - m := htpProperty(htPage,'m) - ncap := htpProperty(htPage,'ncap) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - ncap7 := ncap + 7 - y := alist - for i in (ncap+4)..(ncap+7) repeat - lambda := STRCONC( "0.0"," ") - lambdaList := [lambda,:lambdaList] - for i in 5..(ncap+3) repeat - lambda := STRCONC ((first y).1," ") - y := rest y - lambdaList := [lambda,:lambdaList] - for i in 1..4 repeat - lambda := STRCONC( "0.0"," ") - lambdaList := [lambda,:lambdaList] - lambdaString := bcwords2liststring lambdaList - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - wlist := [right,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - wstring := bcwords2liststring wlist - prefix := STRCONC('"e02baf(",STRINGIMAGE m,", ",STRINGIMAGE ncap7,", [") - prefix := STRCONC(prefix,xstring,"],[",ystring,"],[",wstring,"], [") - prefix := STRCONC(prefix,lambdaString,"], ",STRINGIMAGE ifail,")") - linkGen prefix - - -e02bbf() == - htInitPage('"E02BBF - Evaluation of fitted cubic spline, function only",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02bbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bbf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates at the point {\it x} a cubic spline from its B-spline ") - (text . "B-spline representation ") - (text . "\center{\htbitmap{e02baf}} where ") - (text . "\htbitmap{ncap} is the number of intervals of the ") - (text . "spline. The spline has knots \htbitmap{lamdai}, for ") - (text . "i = 1,2,...,\htbitmap{ncap} + 7. \blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of intervals in the spline \htbitmap{ncap}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 4 ncap PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Evaluation point {\it x}:") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" x F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02bbfSolve) - htShowPage() - -e02bbfSolve htPage == - ncap := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) - objValUnwrap htpLabelSpadValue(htPage, 'ncap) - x := htpLabelInputString(htPage,'x) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ncap = '4 => e02bbfDefaultSolve(htPage,x,ifail) - labelList := - "append"/[f(i) for i in 1..(ncap+7)] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02BBF - Evaluation of fitted cubic spline, function only",nil) - htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " - htSay '"\tab{20} \menuitemstyle{}\tab{22} " - htSay '"Coefficients \space{1} \htbitmap{ci}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02bbfGen) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'x,x) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02bbfDefaultSolve (htPage,x,ifail) == - ncap := '4 - page := htInitPage('"E02BBF - Evaluation of fitted cubic spline, function only",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Knots \space{1}") - (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Coefficients \space{1} \htbitmap{ci}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "1.00" l1 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.00" c1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" l2 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.00" c2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" l3 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.00" c3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" l4 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.00" c4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l5 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.00" c5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l6 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.00" c6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.00" l7 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.00" c7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.00" l8 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.00" l9 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.00" l10 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "9.00" l11 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c11 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02bbfGen) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'x,x) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02bbfGen htPage == - ncap := htpProperty(htPage,'ncap) - x := htpProperty(htPage,'x) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - ncap7 := ncap + 7 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - lamlist := [left,:lamlist] - clist := [right,:clist] - lamstring := bcwords2liststring lamlist - cstring := bcwords2liststring clist - prefix := STRCONC('"e02bbf(",STRINGIMAGE ncap7,", [",lamstring,"],[") - prefix := STRCONC(prefix,cstring,"], ",x,", ",STRINGIMAGE ifail,")") - linkGen prefix - - -e02bcf() == - htInitPage('"E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02bcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bcf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates at the point {\it x} a cubic spline and its first ") - (text . "three derivatives from its B-spline representation ") - (text . "\center{\htbitmap{e02baf}} where ") - (text . "\htbitmap{ncap} is the number of intervals of the ") - (text . "spline. The spline has knots \htbitmap{lamdai}, for ") - (text . "i = 1,2,...,\htbitmap{ncap} + 7. \blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of intervals in the spline \htbitmap{ncap}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 ncap PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Evaluation point {\it x}:") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" x F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "{\it LEFT} specifies whether LH or RH derivatives are required: ") - (radioButtons deriv - ("" " Left-hand derivative" left) - ("" " Right-hand derivative" right)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02bcfSolve) - htShowPage() - -e02bcfSolve htPage == - ncap := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) - objValUnwrap htpLabelSpadValue(htPage, 'ncap) - x := htpLabelInputString(htPage,'x) - temp := htpButtonValue(htPage,'deriv) - deriv := - temp = 'left => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ncap = '7 => e02bcfDefaultSolve(htPage,x,deriv,ifail) - labelList := - "append"/[f(i) for i in 1..(ncap+7)] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) - htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " - htSay '"\tab{20} \menuitemstyle{}\tab{22} " - htSay '"Coefficients \space{1} \htbitmap{ci}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02bcfGen) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'x,x) - htpSetProperty(page,'deriv,deriv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02bcfDefaultSolve (htPage,x,deriv,ifail) == - ncap := '7 - page := htInitPage('"E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\menuitemstyle{}\tab{2} Knots \space{1}") - (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Coefficients \space{1} \htbitmap{ci}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.0" l1 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.00" c1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l2 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.00" c2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l3 F)) - (text . "\tab{22} ") - (bcStrings (10 "13.00" c3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l4 F)) - (text . "\tab{22} ") - (bcStrings (10 "15.00" c4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" l5 F)) - (text . "\tab{22} ") - (bcStrings (10 "22.00" c5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l6 F)) - (text . "\tab{22} ") - (bcStrings (10 "26.00" c6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l7 F)) - (text . "\tab{22} ") - (bcStrings (10 "24.00" c7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l8 F)) - (text . "\tab{22} ") - (bcStrings (10 "18.00" c8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" l9 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.00" c9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" l10 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.00" c10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l11 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l12 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l13 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l14 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c14 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02bcfGen) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'x,x) - htpSetProperty(page,'deriv,deriv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02bcfGen htPage == - ncap := htpProperty(htPage,'ncap) - x := htpProperty(htPage,'x) - deriv := htpProperty(htPage,'deriv) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - ncap7 := ncap + 7 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - lamlist := [left,:lamlist] - clist := [right,:clist] - lamstring := bcwords2liststring lamlist - cstring := bcwords2liststring clist - prefix := STRCONC('"e02bcf(",STRINGIMAGE ncap7,", [",lamstring,"],[") - prefix := STRCONC(prefix,cstring,"], ",x,", ",STRINGIMAGE deriv) - prefix := STRCONC(prefix,", ",STRINGIMAGE ifail,")") - linkGen prefix - - - -e02bdf() == - htInitPage('"E02BDF - Evaluation of fitted cubic spline, definite integral",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02bdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bdf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates the definite integral of a cubic spline from its ") - (text . "B-spline representation \center{\htbitmap{e02baf}} ") - (text . "where \htbitmap{ncap} is the number of intervals of ") - (text . "the spline. The spline has knots \htbitmap{lamdai}, ") - (text . "for i = 1,2,...,\htbitmap{ncap} + 7, and the integral ") - (text . "is evaluated over the range \htbitmap{e02bdf} ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of intervals in the spline \htbitmap{ncap}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 ncap PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02bdfSolve) - htShowPage() - -e02bdfSolve htPage == - ncap := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) - objValUnwrap htpLabelSpadValue(htPage, 'ncap) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ncap = '7 => e02bdfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..(ncap+7)] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage("E02BDF - Evaluation of fitted cubic spline, definite integral",nil) - htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " - htSay '"\tab{20} \menuitemstyle{}\tab{22} " - htSay '"Coefficients \space{1} \htbitmap{ci}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02bdfGen) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02bdfDefaultSolve(htPage,ifail) == - ncap := '7 - page := htInitPage('"E02BDF - Evaluation of fitted cubic spline, definite integral",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Knots \space{1}") - (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Coefficients \space{1} \htbitmap{ci}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.0" l1 F)) - (text . "\tab{22} ") - (bcStrings (10 "10.00" c1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l2 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.00" c2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l3 F)) - (text . "\tab{22} ") - (bcStrings (10 "13.00" c3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00" l4 F)) - (text . "\tab{22} ") - (bcStrings (10 "15.00" c4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" l5 F)) - (text . "\tab{22} ") - (bcStrings (10 "22.00" c5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l6 F)) - (text . "\tab{22} ") - (bcStrings (10 "26.00" c6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l7 F)) - (text . "\tab{22} ") - (bcStrings (10 "24.00" c7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" l8 F)) - (text . "\tab{22} ") - (bcStrings (10 "18.00" c8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" l9 F)) - (text . "\tab{22} ") - (bcStrings (10 "14.00" c9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" l10 F)) - (text . "\tab{22} ") - (bcStrings (10 "12.00" c10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l11 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l12 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l13 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" l14 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.00" c14 F))) - htpSetProperty(page,'ncap,ncap) - htpSetProperty(page,'ifail,ifail) - htMakeDoneButton('"Continue",'e02bdfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02bdfGen htPage == - ncap := htpProperty(htPage,'ncap) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - ncap7 := ncap + 7 - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - lamlist := [left,:lamlist] - clist := [right,:clist] - lamstring := bcwords2liststring lamlist - cstring := bcwords2liststring clist - prefix := STRCONC('"e02bdf(",STRINGIMAGE ncap7,", [",lamstring,"],[") - prefix := STRCONC(prefix,cstring,"], ",STRINGIMAGE ifail,")") - linkGen prefix - - - -e02bef() == - htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02bef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bef| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Determines a cubic spline approximation to the set of points ") - (text . "{\it ( \htbitmap{xr},\htbitmap{yr}) } ") - (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") - (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,n, ") - (text . "are chosen by the routine, but a single parameter S must be ") - (text . "specified to control the trade-off between closeness of fit and ") - (text . "smoothness of fit. This affects the number of knots required ") - (text . "by the spline, which is given in the B-spline representation ") - (text . "\center{\htbitmap{e02bef}}, where n-1 is the number of") - (text . " intervals of the spline. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 15 m PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Smoothing factor {\it s}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "1.0" s F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of number n of knots {\it nest}:\newline\tab{2} ") - (bcStrings (6 54 nest PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Start value: ") - (radioButtons start - ("" " Cold Start - no values needed for {\it n,lamda,wrk} or {\it iwrk}" cold) - ("" " Warm Start - uses knots found in a previous call" warm)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02befSolve) - htShowPage() - -e02befSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - nest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nest) - objValUnwrap htpLabelSpadValue(htPage, 'nest) - lwrk := 4*m +16*nest + 41 - s := htpLabelInputString(htPage,'s) - initial := htpButtonValue(htPage,'start) - start := - initial = 'cold => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = 15 and start = 1) => e02befDefaultSolve (htPage,nest,lwrk,s,ifail) - start = 1 => e02befColdSolve (htPage,m,nest,lwrk,s,ifail) - -- warm start not really possible from hyperdoc - -- as inputing a workspace array of dimension 1105 is asking too much - -- user should use the command line, using the previous calculated - -- parameters - htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\blankline ") - (text . "{\center{\it Hyperdoc interface not available for warm starts.}}") - (text . "\newline ") - (text . "{\center{\it Please use the command line.}}")) - htMakeDoneButton('"Continue",'e02bef) - htShowPage() - - - -e02befColdSolve(htPage,m,nest,lwrk,s,ifail) == - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - post := ('" \tab{42} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) - [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], - ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{40}" - htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " - htSay '"\htbitmap{wr}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02befColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nest,nest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02befDefaultSolve (htPage,nest,lwrk,s,ifail) == - m := 15 - page := htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") - (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") - (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") - (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") - (text . "\htbitmap{wr}: ") - (text . "\newline \tab{2}") - (bcStrings (10 "0.00" x1 F)) - (text . "\tab{22} ") - (bcStrings (10 "-1.1" y1 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "0.50" x2 F)) - (text . "\tab{22} ") - (bcStrings (10 "-0.372" y2 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.00" z2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.00" x3 F)) - (text . "\tab{22} ") - (bcStrings (10 "0.431" y3 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.50" z3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "1.50" x4 F)) - (text . "\tab{22} ") - (bcStrings (10 "1.69" y4 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.00" x5 F)) - (text . "\tab{22} ") - (bcStrings (10 "2.11" y5 F)) - (text . "\tab{42} ") - (bcStrings (10 "3.00" z5 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "2.50" x6 F)) - (text . "\tab{22} ") - (bcStrings (10 "3.10" y6 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z6 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "3.00" x7 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.23" y7 F)) - (text . "\tab{42} ") - (bcStrings (10 "0.50" z7 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.00" x8 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.35" y8 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z8 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "4.50" x9 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.81" y9 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.00" z9 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.00" x10 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.61" y10 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.50" z10 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "5.50" x11 F)) - (text . "\tab{22} ") - (bcStrings (10 "4.79" y11 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z11 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "6.00" x12 F)) - (text . "\tab{22} ") - (bcStrings (10 "5.23" y12 F)) - (text . "\tab{42} ") - (bcStrings (10 "3.00" z12 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.00" x13 F)) - (text . "\tab{22} ") - (bcStrings (10 "6.35" y13 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z13 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "7.50" x14 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.19" y14 F)) - (text . "\tab{42} ") - (bcStrings (10 "2.00" z14 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "8.00" x15 F)) - (text . "\tab{22} ") - (bcStrings (10 "7.97" y15 F)) - (text . "\tab{42} ") - (bcStrings (10 "1.00" z15 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02befColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nest,nest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02befColdGen htPage == - m := htpProperty(htPage,'m) - nest := htpProperty(htPage,'nest) - lwrk := htpProperty(htPage,'lwrk) - s := htpProperty(htPage,'s) - cold := '"c" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - wlist := [right,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - wstring := bcwords2liststring wlist - -- additional entries needed to get it running - -- but as Start = c they are not used - -- mmax := 50 - -- nest := mmax + 4 (54) - -- lwrk := 4*mmax + 16*nest+41 (1105) - prefix := STRCONC('"e02bef(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") - prefix := STRCONC(prefix,ystring,"],[",wstring,"], ",STRINGIMAGE s,", ") - prefix := STRCONC(prefix,STRINGIMAGE nest,", ",STRINGIMAGE lwrk) --- prefix := STRCONC(prefix,",0, [[0.0 for i in 1..",STRINGIMAGE nest,"]],") --- prefix := STRCONC(prefix,STRINGIMAGE ifail,", [[0.0 for i in 1..") --- prefix := STRCONC(prefix,STRINGIMAGE lwrk,"]], [[0 for i in 1..") --- prefix := STRCONC(prefix,STRINGIMAGE nest,"]] :: Matrix Integer)") - prefix := STRCONC(prefix,",0, new(1,",STRINGIMAGE nest,",0.0)$Matrix DoubleFloat,") - prefix := STRCONC(prefix,STRINGIMAGE ifail,", new(1,",STRINGIMAGE lwrk,",0.0)$Matrix DoubleFloat, ") - prefix := STRCONC(prefix," new(1,",STRINGIMAGE nest,",0)$Matrix Integer)") - linkGen prefix - -e02def() == - htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02def} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02def| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates a bicubic spline at the (\htbitmap{xr},") - (text . "\htbitmap{yr}), for r = 1,2,...,m, from its B-spline ") - (text . "representation \htbitmap{e02daf} ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of evaluation points, {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 m PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of (interior & exterior) knots ") - (text . "\lambda, \htbitmap{px} \htbitmap{great=} 8: \newline\tab{2} ") - (bcStrings (6 11 px PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of (interior & exterior) knots ") - (text . "\mu, \htbitmap{py} \htbitmap{great=} 8: \newline\tab{2} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02defSolve) - htShowPage() - -e02defSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '7 and px = '11) and py = '10) => e02defDefaultSolve(htPage,ifail) - labelList := - "append"/[fxy(i) for i in 1..m] where fxy(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{22} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]]] - lamList := - "append"/[flam(i) for i in 1..px] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(nxest)}: \newline") - lamList := [['text,:prefix],:lamList] - muList := - "append"/[fmu(i) for i in 1..(py)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(nyest)}:") - prefix := STRCONC(prefix,"\newline ") - muList := [['text,:prefix],:muList] - cList := - "append"/[fp(i) for i in 1..((px-4)*(py-4))] where fp(i) == - pnam := INTERN STRCONC ('"p",STRINGIMAGE i) - [['bcStrings,[8, 0.0, pnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2}Enter values of ") - prefix := STRCONC(prefix,"{\it c((nxest*4)-(nyest*4))}: \newline ") - cList := [['text,:prefix],:cList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamList,:muList,:cList] - page := htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " - htSay '"\tab{20} \menuitemstyle{}\tab{22} Values of \htbitmap{yr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02defGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02defDefaultSolve (htPage,ifail) == - m := '7 - px := '11 - py := '10 - page := htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") - (text . "\tab{20} \menuitemstyle{} \tab{22} Values of ") - (text . "\htbitmap{yr}: ") - (text . "\newline \tab{2} ") - (bcStrings (8 "1" x1 F)) - (text . "\tab{22}") - (bcStrings (8 "0" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.1" x2 F)) - (text . "\tab{22}") - (bcStrings (8 "0.1" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.5" x3 F)) - (text . "\tab{22}") - (bcStrings (8 "0.7" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.6" x4 F)) - (text . "\tab{22}") - (bcStrings (8 "0.4" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.9" x5 F)) - (text . "\tab{22}") - (bcStrings (8 "0.3" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.9" x6 F)) - (text . "\tab{22}") - (bcStrings (8 "0.8" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "2" x7 F)) - (text . "\tab{22}") - (bcStrings (8 "1" y7 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \lambda(nxest)}:") - (text . "\newline ") - (bcStrings (8 "1.0" l1 F)) - (bcStrings (8 "1.0" l2 F)) - (bcStrings (8 "1.0" l3 F)) - (bcStrings (8 "1.0" l4 F)) - (bcStrings (8 "1.3" l5 F)) - (bcStrings (8 "1.5" l6 F)) - (bcStrings (8 "1.6" l7 F)) - (bcStrings (8 "2" l8 F)) - (bcStrings (8 "2" l9 F)) - (bcStrings (8 "2" l10 F)) - (bcStrings (8 "2" l11 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \mu(nyest)}:") - (text . "\newline ") - (bcStrings (8 "0" mu1 F)) - (bcStrings (8 "0" mu2 F)) - (bcStrings (8 "0" mu3 F)) - (bcStrings (8 "0" mu4 F)) - (bcStrings (8 "0.4" mu5 F)) - (bcStrings (8 "0.7" mu6 F)) - (bcStrings (8 "1" mu7 F)) - (bcStrings (8 "1" mu8 F)) - (bcStrings (8 "1" mu9 F)) - (bcStrings (8 "1" mu10 F)) - (text . "\blankline \menuitemstyle{}\tab{2} ") - (text . "Enter values for {\it c((nxest-4)*(nyest-4))}:") - (text . "\newline ") - (bcStrings (8 "1" c1 F)) - (bcStrings (8 "1.1333" c2 F)) - (bcStrings (8 "1.3667" c3 F)) - (bcStrings (8 "1.7" c4 F)) - (bcStrings (8 "1.9" c5 F)) - (bcStrings (8 "2" c6 F)) - (bcStrings (8 "1.2" c7 F)) - (bcStrings (8 "1.3333" c8 F)) - (bcStrings (8 "1.5667" c9 F)) - (bcStrings (8 "1.9" c10 F)) - (bcStrings (8 "2.1" c11 F)) - (bcStrings (8 "2.2" c12 F)) - (bcStrings (8 "1.5833" c13 F)) - (bcStrings (8 "1.7167" c14 F)) - (bcStrings (8 "1.95" c15 F)) - (bcStrings (8 "2.2833" c16 F)) - (bcStrings (8 "2.4833" c17 F)) - (bcStrings (8 "2.5833" c18 F)) - (bcStrings (8 "2.1433" c19 F)) - (bcStrings (8 "2.2767" c20 F)) - (bcStrings (8 "2.51" c21 F)) - (bcStrings (8 "2.8433" c22 F)) - (bcStrings (8 "3.0433" c23 F)) - (bcStrings (8 "3.1433" c24 F)) - (bcStrings (8 "2.8667" c25 F)) - (bcStrings (8 "3" c26 F)) - (bcStrings (8 "3.2333" c27 F)) - (bcStrings (8 "3.5667" c28 F)) - (bcStrings (8 "3.7667" c29 F)) - (bcStrings (8 "3.8667" c30 F)) - (bcStrings (8 "3.4667" c31 F)) - (bcStrings (8 "3.6" c32 F)) - (bcStrings (8 "3.8333" c33 F)) - (bcStrings (8 "4.1667" c34 F)) - (bcStrings (8 "4.3667" c35 F)) - (bcStrings (8 "4.4667" c36 F)) - (bcStrings (8 "4" c37 F)) - (bcStrings (8 "4.1333" c38 F)) - (bcStrings (8 "4.3667" c39 F)) - (bcStrings (8 "4.7" c40 F)) - (bcStrings (8 "4.9" c41 F)) - (bcStrings (8 "5" c42 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'e02defGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02defGen htPage == - m := htpProperty(htPage,'m) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - -- c - for i in 1..((px-4)*(py-4)) repeat - right := STRCONC ((first y).1," ") - y := rest y - cList := [right,:cList] - cstring := bcwords2liststring cList - -- mu - for i in 1..py repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..px repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - lamstring := bcwords2liststring lamList - -- x & y - while y repeat - one := STRCONC((first y).1," ") - y := rest y - two := STRCONC((first y).1," ") - y := rest y - xlist := [two,:xlist] - ylist := [one,:ylist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - prefix := STRCONC('"e02def(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") - prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") - prefix := STRCONC(prefix,lamstring,"],[",mustring,"],[",cstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - - -e02dff() == - htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02dff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dff| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Evaluates a bicubic spline at all the points on a rectangular ") - (text . "grid defined by \htbitmap{mx} points ") - (text . "\htbitmap{xq}on the x-axis and \htbitmap{my}") - (text . "points \htbitmap{yr} on the y-axis, from its B-spline ") - (text . "representation \center{\htbitmap{e02daf}} \newline with knot sets ") - (text . "\{\lambda\} and \{\mu\}. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Grid points on x-axis \htbitmap{mx}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Grid points on y-axis \htbitmap{my}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 mx PI)) - (text . "\tab{34} ") - (bcStrings (6 6 my PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Number of (interior & exterior) knots \lambda, ") - (text . "\htbitmap{px} \htbitmap{great=} 8: \newline\tab{2} ") - (bcStrings (6 11 px PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Number of (interior & exterior) knots \mu, ") - (text . "\htbitmap{py} \htbitmap{great=} 8: \newline\tab{2} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02dffSolve) - htShowPage() - -e02dffSolve htPage == - mx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) - objValUnwrap htpLabelSpadValue(htPage, 'mx) - my := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) - objValUnwrap htpLabelSpadValue(htPage, 'my) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - nwrk1 := 4*mx + px - nwrk2 := 4*my + py - nwrklist := [nwrk1,nwrk2] - nwrkmin := APPLY ('MIN, nwrklist) - lwrk := nwrkmin - liwrk := - nwrkmin = nwrk2 => my + py -4 - mx + px -4 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((mx = '7 and my = '6) and (px = '11 and py = '10)) => - e02dffDefaultSolve(htPage,lwrk,liwrk,ifail) - xList := - "append"/[fx(i) for i in 1..mx] where fx(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, 0.0, xnam, 'F]]] - yList := - "append"/[fy(i) for i in 1..my] where fy(i) == - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['bcStrings,[8, 0.0, ynam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of ") - prefix := STRCONC(prefix,"\htbitmap{yr} : \newline") - yList := [['text,:prefix],:yList] - lamList := - "append"/[flam(i) for i in 1..px] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it \lambda(nxest)}:\newline") - lamList := [['text,:prefix],:lamList] - muList := - "append"/[fmu(i) for i in 1..(py)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it mu(nyest)}:") - prefix := STRCONC(prefix,"\newline ") - muList := [['text,:prefix],:muList] - cList := - "append"/[fp(i) for i in 1..((px-4)*(py-4))] where fp(i) == - pnam := INTERN STRCONC ('"p",STRINGIMAGE i) - [['bcStrings,[8, 0.0, pnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} Enter values of ") - prefix := STRCONC(prefix,"{\it c((px-4)*(py-4))}: \newline") - cList := [['text,:prefix],:cList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :xList,:yList,:lamList,:muList,:cList] - page := htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:\newline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02dffGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02dffDefaultSolve (htPage,lwrk,liwrk,ifail) == - mx := '7 - my := '6 - px := '11 - py := '10 - page := htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \htbitmap{xr}:") - (text . "\newline ") - (bcStrings (8 "1" x1 F)) - (bcStrings (8 "1.1" x2 F)) - (bcStrings (8 "1.3" x3 F)) - (bcStrings (8 "1.4" x4 F)) - (bcStrings (8 "1.5" x5 F)) - (bcStrings (8 "1.7" x6 F)) - (bcStrings (8 "2" x7 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \htbitmap{yr}:") - (text . "\newline ") - (bcStrings (8 "0" y1 F)) - (bcStrings (8 "0.2" y2 F)) - (bcStrings (8 "0.4" y3 F)) - (bcStrings (8 "0.6" y4 F)) - (bcStrings (8 "0.8" y5 F)) - (bcStrings (8 "1" y6 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it \lambda(nxest)}:") - (text . "\newline ") - (bcStrings (8 "1" l1 F)) - (bcStrings (8 "1" l2 F)) - (bcStrings (8 "1" l3 F)) - (bcStrings (8 "1" l4 F)) - (bcStrings (8 "1.3" l5 F)) - (bcStrings (8 "1.5" l6 F)) - (bcStrings (8 "1.6" l7 F)) - (bcStrings (8 "2" l8 F)) - (bcStrings (8 "2" l9 F)) - (bcStrings (8 "2" l10 F)) - (bcStrings (8 "2" l11 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it \mu(nyest)}:") - (text . "\newline ") - (bcStrings (8 "0" mu1 F)) - (bcStrings (8 "0" mu2 F)) - (bcStrings (8 "0" mu3 F)) - (bcStrings (8 "0" mu4 F)) - (bcStrings (8 "0.4" mu5 F)) - (bcStrings (8 "0.7" mu6 F)) - (bcStrings (8 "1" mu7 F)) - (bcStrings (8 "1" mu8 F)) - (bcStrings (8 "1" mu9 F)) - (bcStrings (8 "1" mu10 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it c((px-4)*(py-4))}:") - (text . "\newline ") - (bcStrings (8 "1" c1 F)) - (bcStrings (8 "1.1333" c2 F)) - (bcStrings (8 "1.3667" c3 F)) - (bcStrings (8 "1.7" c4 F)) - (bcStrings (8 "1.9" c5 F)) - (bcStrings (8 "2" c6 F)) - (bcStrings (8 "1.2" c7 F)) - (bcStrings (8 "1.3333" c8 F)) - (bcStrings (8 "1.5667" c9 F)) - (bcStrings (8 "1.9" c10 F)) - (bcStrings (8 "2.1" c11 F)) - (bcStrings (8 "2.2" c12 F)) - (bcStrings (8 "1.5833" c13 F)) - (bcStrings (8 "1.7167" c14 F)) - (bcStrings (8 "1.95" c15 F)) - (bcStrings (8 "2.2833" c16 F)) - (bcStrings (8 "2.4833" c17 F)) - (bcStrings (8 "2.5833" c18 F)) - (bcStrings (8 "2.1433" c19 F)) - (bcStrings (8 "2.2767" c20 F)) - (bcStrings (8 "2.51" c21 F)) - (bcStrings (8 "2.8433" c22 F)) - (bcStrings (8 "3.0433" c23 F)) - (bcStrings (8 "3.1433" c24 F)) - (bcStrings (8 "2.8667" c25 F)) - (bcStrings (8 "3" c26 F)) - (bcStrings (8 "3.2333" c27 F)) - (bcStrings (8 "3.5667" c28 F)) - (bcStrings (8 "3.7667" c29 F)) - (bcStrings (8 "3.8667" c30 F)) - (bcStrings (8 "3.4667" c31 F)) - (bcStrings (8 "3.6" c32 F)) - (bcStrings (8 "3.8333" c33 F)) - (bcStrings (8 "4.1667" c34 F)) - (bcStrings (8 "4.3667" c35 F)) - (bcStrings (8 "4.4667" c36 F)) - (bcStrings (8 "4" c37 F)) - (bcStrings (8 "4.1333" c38 F)) - (bcStrings (8 "4.3667" c39 F)) - (bcStrings (8 "4.7" c40 F)) - (bcStrings (8 "4.9" c41 F)) - (bcStrings (8 "5" c42 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02dffGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02dffGen htPage == - mx := htpProperty(htPage,'mx) - my := htpProperty(htPage,'my) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - -- c - for i in 1..((px-4)*(py-4)) repeat - right := STRCONC ((first y).1," ") - y := rest y - cList := [right,:cList] - cstring := bcwords2liststring cList - -- mu - for i in 1..py repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..px repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - lamstring := bcwords2liststring lamList - -- y - for i in 1..my repeat - right := STRCONC ((first y).1," ") - y := rest y - yList := [right,:yList] - ystring := bcwords2liststring yList - -- x - for i in 1..mx repeat - right := STRCONC ((first y).1," ") - y := rest y - xList := [right,:xList] - xstring := bcwords2liststring xList - prefix := STRCONC('"e02dff(",STRINGIMAGE mx,", ",STRINGIMAGE my,", ") - prefix := STRCONC(prefix,STRINGIMAGE px,", ",STRINGIMAGE py,",[") - prefix := STRCONC(prefix,xstring,"],[",ystring,"],[",lamstring,"],[") - prefix := STRCONC(prefix,mustring,"],[",cstring,"],",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",STRINGIMAGE ifail,")") - linkGen prefix - -e02gaf() == - htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02gaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02gaf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Calculates an \htbitmap{l1} solution to the over determined system") - (text . " of linear equations {\it Ax = b}, where A is an {\it m} by {\it n") - (text . "} matrix, {\it x} is an {\it n} element vector, and {\it b} is an ") - (text . "{\it m} element vector. The matrix {\it A} need not be of full ") - (text . "rank. \blankline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "Number of rows of {\it A}, {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "Number of columns of {\it A}, {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2} \newline ") --- (text . "First dimension of {\it A(la,n+2)}, {\it la}\htbitmap{great=}") --- (text . " {\it m + 2}: \newline\tab{2} ") --- (bcStrings (6 7 la PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} \newline ") - (text . "Tolerance (default is zero), {\it toler}: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.0" toler F)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02gafSolve) - htShowPage() - -e02gafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - la := m+2 --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) --- objValUnwrap htpLabelSpadValue(htPage, 'la) - toler := htpLabelInputString(htPage,'toler) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = 5 and n = 3) and la = 7) => e02gafDefaultSolve (htPage,toler,ifail) - labelList := - "append"/[fc(i,n) for i in 1..la] where fc(i,n) == - tempList := - "append"/[fr(i,j) for j in 1..(n+2)] where fr(i,j) == - fnam := INTERN STRCONC ('"f",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[9, 0.0, fnam, 'F]]] - prefix := ('"\newline ") - tempList := [['text,:prefix],:tempList] - bList := - "append"/[fb(i) for i in 1..m] where fb(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[9, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of {\it B(m)}: \newline") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:bList] - page := htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) - htSay '"\menuitemstyle{}\tab{2} Values of {\it A(la,n+2)}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02gafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'n,n) - htpSetProperty(page,'la,la) - htpSetProperty(page,'toler,toler) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02gafDefaultSolve (htPage,toler,ifail) == - m := '5 - n := '3 - la := '7 - page := htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it A(la,n+2)}:") - (text . "\newline ") - (bcStrings (9 "1.0" a11 F)) - (bcStrings (9 "1.0" a12 F)) - (bcStrings (9 "1.0" a13 F)) - (bcStrings (9 "0.0" a14 F)) - (bcStrings (9 "0.0" a15 F)) - (text . "\newline ") - (bcStrings (9 "exp(0.2)" a21 F)) - (bcStrings (9 "exp(-0.2)" a22 F)) - (bcStrings (9 "1.0" a23 F)) - (bcStrings (9 "0.0" a24 F)) - (bcStrings (9 "0.0" a25 F)) - (text . "\newline ") - (bcStrings (9 "exp(0.4)" a31 F)) - (bcStrings (9 "exp(-0.4)" a32 F)) - (bcStrings (9 "1.0" a33 F)) - (bcStrings (9 "0.0" a34 F)) - (bcStrings (9 "0.0" a35 F)) - (text . "\newline ") - (bcStrings (9 "exp(0.6)" a41 F)) - (bcStrings (9 "exp(-0.6)" a42 F)) - (bcStrings (9 "1.0" a43 F)) - (bcStrings (9 "0.0" a44 F)) - (bcStrings (9 "0.0" a45 F)) - (text . "\newline ") - (bcStrings (9 "exp(0.8)" a51 F)) - (bcStrings (9 "exp(-0.8)" a52 F)) - (bcStrings (9 "1.0" a53 F)) - (bcStrings (9 "0.0" a54 F)) - (bcStrings (9 "0.0" a55 F)) - (text . "\newline ") - (bcStrings (9 "0.0" a61 F)) - (bcStrings (9 "0.0" a62 F)) - (bcStrings (9 "0.0" a63 F)) - (bcStrings (9 "0.0" a64 F)) - (bcStrings (9 "0.0" a65 F)) - (text . "\newline ") - (bcStrings (9 "0.0" a71 F)) - (bcStrings (9 "0.0" a72 F)) - (bcStrings (9 "0.0" a73 F)) - (bcStrings (9 "0.0" a74 F)) - (bcStrings (9 "0.0" a75 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it B(m)}:") - (text . "\newline ") - (bcStrings (9 "4.501" b1 F)) - (bcStrings (9 "4.36" b2 F)) - (bcStrings (9 "4.333" b3 F)) - (bcStrings (9 "4.418" b4 F)) - (bcStrings (9 "4.625" b5 F))) - htMakeDoneButton('"Continue",'e02gafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'n,n) - htpSetProperty(page,'toler,toler) - htpSetProperty(page,'la,la) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02gafGen htPage == - m := htpProperty(htPage,'m) - n := htpProperty(htPage,'n) - la := htpProperty(htPage,'la) - toler := htpProperty(htPage,'toler) - ifail := htpProperty(htPage,'ifail) - nplustwo := n + 2 - alist := htpInputAreaAlist htPage - y := alist - for i in 1..m repeat - right := STRCONC ((first y).1," ") - y := rest y - blist := [right,:blist] - bstring := bcwords2liststring blist - y := REVERSE y - k := -1 - matform := [[y.(k := k + 1).1 for j in 0..(nplustwo-1)] for i in 0..(la-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"e02gaf(",STRINGIMAGE m,", ",STRINGIMAGE la,", ") - prefix := STRCONC(prefix,STRINGIMAGE nplustwo,", ",STRINGIMAGE toler,", ") - prefix := STRCONC(prefix,matstring,",[",bstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - - -e02daf() == - htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02daf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02daf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a minimal, least squares bicubic B-spline surface fit") - (text . "\htbitmap{e02daf} to the set of points ") - (text . "{\em (\htbitmap{xr},\htbitmap{yr},\htbitmap{fr})} with weights ") - (text . "\htbitmap{wr}, for r = 1,2,...,m. The user must supply internal ") - (text . "knot sets {\lambda},in the x-direction and {\mu} in the ") - (text . "y-direction, ") - (text . "which can be thought of as dividing the data region into panels;") - (text . "s(x,y) consists of a seperate bicubic polynomial in each panel, ") - (text . "the polynomial joining together with second derivative ") - (text . "continuity. Eight additional (external) knots are added to each ") - (text . "of the knot sets by this routine. The routine minimizes \Sigma, ") - (text . "the sum of squares of the weighted residuals ") - (text . "\htbitmap{e02daf1}, for r = 1,2,...,m, subject to the ") - (text . "given knot sets. \newline ") - (text . "A call of this routine should be preceded by a call of E02ZAF ") - (text . "to provide indexing information. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Knots in x direction {\em px}") - (text . "\htbitmap{great=} 8: \tab{32} \menuitemstyle{}\tab{34}") - (text . "Knots in y direction {\em py}:") - (text . "\newline\tab{2} ") - (bcStrings (6 8 px PI)) - (text . "\tab{34} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Rank threshold {\em eps}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.000001" eps F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Dimension of point {\it npoint}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 43 npoint PI)) - -- include a radio button later to allow switching of - -- x & y if px <= py - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02dafSolve) - htShowPage() - -e02dafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - npoint := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) - objValUnwrap htpLabelSpadValue(htPage, 'npoint) - nc := (px - 4)*(py - 4) - nws := (2*nc + 1)*(3*py - 6) -2 - eps := htpLabelInputString(htPage,'eps) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '30 and px = '8) and py = '10) => e02dafDefaultSolve(htPage,eps,nws,npoint,ifail) - labelList := - "append"/[fxy(i) for i in 1..m] where fxy(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - next := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:next],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - lamList := - "append"/[flam(i) for i in 5..(px-4)] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} lamda(5) to lamda(px-4): ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - postfix := ('"\newline \blankline ") - lamList := [['text,:prefix],:lamList,['text,:postfix]] - muList := - "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\menuitemstyle{} \tab{2} mu(5) to mu(py-4):") - prefix := STRCONC(prefix,"\newline \tab{2} ") - muList := [['text,:prefix],:muList] - pList := - "append"/[fp(i) for i in 1..npoint] where fp(i) == - prefix := ('"\newline \tab{2} ") - pnam := INTERN STRCONC ('"p",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, pnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of Point: ") - pList := [['text,:prefix],:pList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamList,:muList,:pList] - page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " - htSay '"\tab{15} \menuitemstyle{}\tab{17} Values of \htbitmap{yr}:" - htSay '"\tab{30} \menuitemstyle{}\tab{32} Values of \htbitmap{fr}:" - htSay '"\tab{44} \menuitemstyle{}\tab{46} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02dafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'nws,nws) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02dafDefaultSolve (htPage,eps,nws,npoint,ifail) == - m := '30 - px := '8 - py := '10 - page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") - (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") - (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") - (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") - (text . "\tab{46} Values of \htbitmap{wr}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.52" x1 F)) - (text . "\tab{17}") - (bcStrings (8 "0.60" y1 F)) - (text . "\tab{32}") - (bcStrings (8 "0.93" f1 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.61" x2 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.95" y2 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.79" f2 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.93" x3 F)) - (text . "\tab{17}") - (bcStrings (8 "0.87" y3 F)) - (text . "\tab{32}") - (bcStrings (8 "0.36" f3 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.09" x4 F)) - (text . "\tab{17}") - (bcStrings (8 "0.84" y4 F)) - (text . "\tab{32}") - (bcStrings (8 "0.52" f4 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.88" x5 F)) - (text . "\tab{17}") - (bcStrings (8 "0.17" y5 F)) - (text . "\tab{32}") - (bcStrings (8 "0.49" f5 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.70" x6 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.87" y6 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.76" f6 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1" x7 F)) - (text . "\tab{17}") - (bcStrings (8 "1" y7 F)) - (text . "\tab{32}") - (bcStrings (8 "0.33" f7 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1" x8 F)) - (text . "\tab{17}") - (bcStrings (8 "0.1" y8 F)) - (text . "\tab{32}") - (bcStrings (8 "0.48" f8 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.3" x9 F)) - (text . "\tab{17}") - (bcStrings (8 "0.24" y9 F)) - (text . "\tab{32}") - (bcStrings (8 "0.65" f9 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.77" x10 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.77" y10 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.82" f10 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w10 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.23" x11 F)) - (text . "\tab{17}") - (bcStrings (8 "0.32" y11 F)) - (text . "\tab{32}") - (bcStrings (8 "0.92" f11 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w11 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-1" x12 F)) - (text . "\tab{17}") - (bcStrings (8 "1" y12 F)) - (text . "\tab{32}") - (bcStrings (8 "1" f12 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w12 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.26" x13 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.63" y13 F)) - (text . "\tab{32}") - (bcStrings (8 "8.88" f13 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w13 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.83" x14 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.66" y14 F)) - (text . "\tab{32}") - (bcStrings (8 "-2.01" f14 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w14 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.22" x15 F)) - (text . "\tab{17}") - (bcStrings (8 "0.93" y15 F)) - (text . "\tab{32}") - (bcStrings (8 "0.47" f15 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w15 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.89" x16 F)) - (text . "\tab{17}") - (bcStrings (8 "0.15" y16 F)) - (text . "\tab{32}") - (bcStrings (8 "0.49" f16 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w16 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.80" x17 F)) - (text . "\tab{17}") - (bcStrings (8 "0.99" y17 F)) - (text . "\tab{32}") - (bcStrings (8 "0.84" f17 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w17 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.88" x18 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.54" y18 F)) - (text . "\tab{32}") - (bcStrings (8 "-2.42" f18 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w18 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.68" x19 F)) - (text . "\tab{17}") - (bcStrings (8 "0.44" y19 F)) - (text . "\tab{32}") - (bcStrings (8 "0.47" f19 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w19 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.14" x20 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.72" y20 F)) - (text . "\tab{32}") - (bcStrings (8 "7.15" f20 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w20 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.67" x21 F)) - (text . "\tab{17}") - (bcStrings (8 "0.63" y21 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" f21 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w21 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.90" x22 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.40" y22 F)) - (text . "\tab{32}") - (bcStrings (8 "-3.34" f22 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w22 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.84" x23 F)) - (text . "\tab{17}") - (bcStrings (8 "0.20" y23 F)) - (text . "\tab{32}") - (bcStrings (8 "2.78" f23 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w23 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.84" x24 F)) - (text . "\tab{17}") - (bcStrings (8 "0.43" y24 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" f24 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w24 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.15" x25 F)) - (text . "\tab{17}") - (bcStrings (8 "0.28" y25 F)) - (text . "\tab{32}") - (bcStrings (8 "0.70" f25 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w25 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.91" x26 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.24" y26 F)) - (text . "\tab{32}") - (bcStrings (8 "-6.52" f26 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w26 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.35" x27 F)) - (text . "\tab{17}") - (bcStrings (8 "0.86" y27 F)) - (text . "\tab{32}") - (bcStrings (8 "0.66" f27 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w27 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.16" x28 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.41" y28 F)) - (text . "\tab{32}") - (bcStrings (8 "2.32" f28 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w28 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.35" x29 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.05" y29 F)) - (text . "\tab{32}") - (bcStrings (8 "1.66" f29 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w29 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-1" x30 F)) - (text . "\tab{17}") - (bcStrings (8 "-1" y30 F)) - (text . "\tab{32}") - (bcStrings (8 "-1" f30 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w30 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} mu(5) to mu(py-4):") - (text . "\newline \tab{2}") - (bcStrings (8 "-0.50" mu5 F)) - (bcStrings (8 "0.00" mu6 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values for point:") - (text . "\newline \tab{2}") - (bcStrings (6 3 p1 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 6 p2 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 4 p3 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 5 p4 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 7 p5 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 10 p6 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 8 p7 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 9 p8 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 11 p9 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 13 p10 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 12 p11 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 15 p12 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 14 p13 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 18 p14 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 16 p15 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 17 p16 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 19 p17 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 20 p18 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 21 p19 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 30 p20 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 23 p21 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 26 p22 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 24 p23 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 25 p24 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 27 p25 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 28 p26 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p27 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 29 p28 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p29 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p30 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 2 p31 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 22 p32 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 1 p33 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p34 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p35 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p36 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p37 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p38 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p39 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p40 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p41 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p42 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p43 PI)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02dafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'nws,nws) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02dafGen htPage == - m := htpProperty(htPage,'m) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - nws := htpProperty(htPage,'nws) - eps := htpProperty(htPage,'eps) - npoint := htpProperty(htPage,'npoint) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - nadres := (px-7)*(py-7) - -- point - for i in 1..npoint repeat - right := STRCONC ((first y).1," ") - y := rest y - pointList := [right,:pointList] - pstring := bcwords2liststring pointList - -- mu - for i in 1..4 repeat - muList := ['"0 ",:muList] - for i in 5..(py-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - for i in (py-3)..py repeat - muList := ['"0 ",:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..4 repeat - lamList := ['"0 ",:lamList] - for i in 5..(px-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - for i in (px-3)..px repeat - lamList := ['"0 ",:lamList] - lamstring := bcwords2liststring lamList - -- x & y - while y repeat - one := STRCONC((first y).1," ") - y := rest y - two := STRCONC((first y).1," ") - y := rest y - three := STRCONC ((first y).1," ") - y := rest y - four := STRCONC ((first y).1," ") - y := rest y - xlist := [four,:xlist] - ylist := [three,:ylist] - flist := [two,:flist] - wlist := [one,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - nc := (px-4)*(py-4) - prefix := STRCONC('"e02daf(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") - prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") - prefix := STRCONC(prefix,fstring,"],[",wstring,"],[",mustring,"],[") - prefix := STRCONC(prefix,pstring,"], ",STRINGIMAGE npoint,", ") - prefix := STRCONC(prefix,STRINGIMAGE nc,", ",STRINGIMAGE nws,", ",eps,", [") - prefix := STRCONC(prefix,lamstring,"], ",STRINGIMAGE ifail,")") - linkGen prefix - - -e02dcf() == - htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02dcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dcf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Determines a bicubic spline approximation to a set of points ") - (text . "given on a rectangular grid defined by \htbitmap{mx} ") - (text . "points \htbitmap{xq} on the x-axis and ") - (text . "\htbitmap{my} points \htbitmap{yr} on the ") - (text . "y-axix. The knots \htbitmap{lamdai}, for i = 1,2,...,") - (text . "\htbitmap{nx} and \htbitmap{mui}, for ") - (text . "i = 1,2,...,\htbitmap{ny} are chosen for this routine ") - (text . ", but a single parameter S must be specified to control the ") - (text . "trade-off between closeness of fit and smoothness of fit. This ") - (text . "affects the number of knots required by the spline, which is ") - (text . "given in the B-spline representation \htbitmap{e02daf}") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Grid points on x-axis \htbitmap{mx}: ") - (text . "\tab{30} \menuitemstyle{}\tab{32} Grid points on y-axis ") - (text . "\htbitmap{my}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 11 mx PI)) - (text . "\tab{32} ") - (bcStrings (6 9 my PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") - (text . "computed spline, {\it nxest}: \newline\tab{2} ") - (bcStrings (6 15 nxest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") - (text . "spline, {\it nyest}: \newline\tab{2} ") - (bcStrings (6 13 nyest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Smoothing factor {\it s}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "0.1" s F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Start value: ") - (radioButtons start - ("" " Cold Start - no values needed for {\it nx,ny,lamda,mu} or {\it iwrk}" cold) - ("" " Warm Start - uses knots found in a previous call" warm)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02dcfSolve) - htShowPage() - -e02dcfSolve htPage == - mx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) - objValUnwrap htpLabelSpadValue(htPage, 'mx) - my := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) - objValUnwrap htpLabelSpadValue(htPage, 'my) - nxest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) - objValUnwrap htpLabelSpadValue(htPage, 'nxest) - nyest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) - objValUnwrap htpLabelSpadValue(htPage, 'nyest) - wrklist := [my,nxest] - wrkmax := APPLY ('MAX, wrklist) - lwrk := 4*(mx + my) +11*(nxest + nyest) + nxest*my + wrkmax +54 - liwrk := 3 + mx + my + nxest + nyest - s := htpLabelInputString(htPage,'s) - initial := htpButtonValue(htPage,'start) - start := - initial = 'cold => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((mx = 11 and my = 9) and start = 1) => - e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) - start = 1 => e02dcfColdSolve (htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) - -- warm start not really possible from hyperdoc - -- as inputing a workspace array of dimension 592 is asking too much - -- user should use the command line, using the previous calculated - -- parameters - htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\blankline ") - (text . "{\center{\em Hyperdoc interface not available for warm starts.}}") - (text . "\newline ") - (text . "{\center{\em Please use the command line.}}")) - htMakeDoneButton('"Continue",'e02dcf) - htShowPage() - - - -e02dcfColdSolve(htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) == - xList := - "append"/[f(i) for i in 1..mx] where f(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, 0.0, xnam, 'F]]] - yList := - "append"/[g(i) for i in 1..my] where g(i) == - ynam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['bcStrings,[8, 0.0, ynam, 'F]]] - prefix:= ('"\blankline \menuitemstyle{}\tab{2} Values of {\it y(my)}: \newline ") - yList := [['text,:prefix],:yList] - fList := - "append"/[h(i) for i in 1..(mx*my)] where h(i) == - fnam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['bcStrings,[8, 0.0, fnam, 'F]]] - prefix:=('"\blankline \menuitemstyle{} \tab{2} Values of {\it f(mx*my)}: \newline ") - fList := [['text,:prefix],:fList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :xList,:yList,:fList] - page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htSay '"\menuitemstyle{}\tab{2} Values of {\it x(mx)}: \newline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02dcfColdGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == - mx := 11 - my := 9 - page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it x(mx)}:") - (text . "\newline ") - (bcStrings (8 "0" x1 F)) - (bcStrings (8 "0.5" x2 F)) - (bcStrings (8 "1" x3 F)) - (bcStrings (8 "1.5" x4 F)) - (bcStrings (8 "2" x5 F)) - (bcStrings (8 "2.5" x6 F)) - (bcStrings (8 "3" x7 F)) - (bcStrings (8 "3.5" x8 F)) - (bcStrings (8 "4" x9 F)) - (bcStrings (8 "4.5" x10 F)) - (bcStrings (8 "5" x11 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it y(my)}:") - (text . "\newline ") - (bcStrings (8 "0" y1 F)) - (bcStrings (8 "0.5" y2 F)) - (bcStrings (8 "1" y3 F)) - (bcStrings (8 "1.5" y4 F)) - (bcStrings (8 "2" y5 F)) - (bcStrings (8 "2.5" y6 F)) - (bcStrings (8 "3" y7 F)) - (bcStrings (8 "3.5" y8 F)) - (bcStrings (8 "4" y9 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it f(mx*my)}:") - (text . "\newline ") - (bcStrings (8 "1" f1 F)) - (bcStrings (8 "0.88758" f2 F)) - (bcStrings (8 "0.5403" f3 F)) - (bcStrings (8 "0.070737" f4 F)) - (bcStrings (8 "-0.41515" f5 F)) - (bcStrings (8 "-0.80114" f6 F)) - (bcStrings (8 "-0.97999" f7 F)) - (bcStrings (8 "-0.93446" f8 F)) - (bcStrings (8 "-0.65664" f9 F)) - (bcStrings (8 "1.5" f10 F)) - (bcStrings (8 "1.3564" f11 F)) - (bcStrings (8 "0.82045" f12 F)) - (bcStrings (8 "0.10611" f13 F)) - (bcStrings (8 "-0.62422" f14 F)) - (bcStrings (8 "-1.2317" f15 F)) - (bcStrings (8 "-1.485" f16 F)) - (bcStrings (8 "-1.3047" f17 F)) - (bcStrings (8 "-0.98547" f18 F)) - (bcStrings (8 "2.06" f19 F)) - (bcStrings (8 "1.7552" f20 F)) - (bcStrings (8 "1.0806" f21 F)) - (bcStrings (8 "0.15147" f22 F)) - (bcStrings (8 "-0.83229" f23 F)) - (bcStrings (8 "-1.6023" f24 F)) - (bcStrings (8 "-1.97" f25 F)) - (bcStrings (8 "-1.8729" f26 F)) - (bcStrings (8 "-1.4073" f27 F)) - (bcStrings (8 "2.57" f28 F)) - (bcStrings (8 "2.124" f29 F)) - (bcStrings (8 "1.3508" f30 F)) - (bcStrings (8 "0.17684" f31 F)) - (bcStrings (8 "-1.0404" f32 F)) - (bcStrings (8 "-2.0029" f33 F)) - (bcStrings (8 "-2.475" f34 F)) - (bcStrings (8 "-2.3511" f35 F)) - (bcStrings (8 "-1.6741" f36 F)) - (bcStrings (8 "3" f37 F)) - (bcStrings (8 "2.6427" f38 F)) - (bcStrings (8 "1.6309" f39 F)) - (bcStrings (8 "0.21221" f40 F)) - (bcStrings (8 "-1.2484" f41 F)) - (bcStrings (8 "-2.2034" f42 F)) - (bcStrings (8 "-2.97" f43 F)) - (bcStrings (8 "-2.8094" f44 F)) - (bcStrings (8 "-1.9809" f45 F)) - (bcStrings (8 "3.5" f46 F)) - (bcStrings (8 "3.1715" f47 F)) - (bcStrings (8 "1.8611" f48 F)) - (bcStrings (8 "0.24458" f49 F)) - (bcStrings (8 "-1.4565" f50 F)) - (bcStrings (8 "-2.864" f51 F)) - (bcStrings (8 "-3.265" f52 F)) - (bcStrings (8 "-3.2776" f53 F)) - (bcStrings (8 "-2.2878" f54 F)) - (bcStrings (8 "4.04" f55 F)) - (bcStrings (8 "3.5103" f56 F)) - (bcStrings (8 "2.0612" f57 F)) - (bcStrings (8 "0.28595" f58 F)) - (bcStrings (8 "-1.6946" f59 F)) - (bcStrings (8 "-3.2046" f60 F)) - (bcStrings (8 "-3.96" f61 F)) - (bcStrings (8 "-3.7958" f62 F)) - (bcStrings (8 "-2.6146" f63 F)) - (bcStrings (8 "4.5" f64 F)) - (bcStrings (8 "3.9391" f65 F)) - (bcStrings (8 "2.4314" f66 F)) - (bcStrings (8 "0.31632" f67 F)) - (bcStrings (8 "-1.8627" f68 F)) - (bcStrings (8 "-3.6351" f69 F)) - (bcStrings (8 "-4.455" f70 F)) - (bcStrings (8 "-4.2141" f71 F)) - (bcStrings (8 "-2.9314" f72 F)) - (bcStrings (8 "5.04" f73 F)) - (bcStrings (8 "4.3879" f74 F)) - (bcStrings (8 "2.7515" f75 F)) - (bcStrings (8 "0.35369" f76 F)) - (bcStrings (8 "-2.0707" f77 F)) - (bcStrings (8 "-4.0057" f78 F)) - (bcStrings (8 "-4.97" f79 F)) - (bcStrings (8 "-4.6823" f80 F)) - (bcStrings (8 "-3.2382" f81 F)) - (bcStrings (8 "5.505" f82 F)) - (bcStrings (8 "4.8367" f83 F)) - (bcStrings (8 "2.9717" f84 F)) - (bcStrings (8 "0.38505" f85 F)) - (bcStrings (8 "-2.2888" f86 F)) - (bcStrings (8 "-4.4033" f87 F)) - (bcStrings (8 "-5.445" f88 F)) - (bcStrings (8 "-5.1405" f89 F)) - (bcStrings (8 "-3.595" f90 F)) - (bcStrings (8 "6" f91 F)) - (bcStrings (8 "5.2755" f92 F)) - (bcStrings (8 "3.2418" f93 F)) - (bcStrings (8 "0.42442" f94 F)) - (bcStrings (8 "-2.4769" f95 F)) - (bcStrings (8 "-4.8169" f96 F)) - (bcStrings (8 "-5.93" f97 F)) - (bcStrings (8 "-5.6387" f98 F)) - (bcStrings (8 "-3.9319" f99 F))) - htMakeDoneButton('"Continue",'e02dcfColdGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02dcfColdGen htPage == - mx := htpProperty(htPage,'mx) - my := htpProperty(htPage,'my) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - cold := '"c" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(mx*my) repeat - end := STRCONC((first y).1," ") - y := rest y - fList := [end,:fList] - fstring := bcwords2liststring fList - for i in 1..my repeat - mid := STRCONC ((first y).1," ") - y := rest y - ylist := [mid,:ylist] - ystring := bcwords2liststring ylist - while y repeat - start := STRCONC ((first y).1," ") - y := rest y - xlist := [start,:xlist] - xstring := bcwords2liststring xlist - -- additional entries needed to get it running - -- but as Start = c they are not used - prefix := STRCONC('"e02dcf(_"",cold,"_",",STRINGIMAGE mx,", [",xstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE my,",[",ystring,"],[",fstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,",0,new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,") - prefix := STRCONC(prefix,"0,new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") - end := STRCONC("new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,[[0 for i in 1..") - end := STRCONC(end,STRINGIMAGE liwrk,"]]::Matrix Integer,",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,end) - - -e02ddf() == - htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02ddf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ddf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Determines a bicubic spline approximation to a set of scattered") - (text . " points ( \htbitmap{xr},\htbitmap{yr}, ") - (text . "\htbitmap{fr})") - (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") - (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") - (text . "\htbitmap{nx} and \htbitmap{mui}, for ") - (text . "i = 1,2,...,\htbitmap{ny} are chosen by the routine ") - (text . ", but a single parameter S must be specified to control the ") - (text . "trade-off between closeness of fit and smoothness of fit. This ") - (text . "affects the number of knots required by the spline, which is ") - (text . "given in the B-spline representation \htbitmap{e02daf}") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") - (text . "computed spline, {\it nxest}: \newline\tab{2} ") - (bcStrings (6 14 nxest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") - (text . "spline, {\it nyest}: \newline\tab{2} ") - (bcStrings (6 14 nyest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Smoothing factor {\it s}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "10" s F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Start value: ") - (radioButtons start - ("" " Cold Start - no values needed for {\it nx,ny,lamda,wrk,iwrk}" cold) - ("" " Warm Start - uses knots found in a previous call" warm)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02ddfSolve) - htShowPage() - -e02ddfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - nxest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) - objValUnwrap htpLabelSpadValue(htPage, 'nxest) - nyest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) - objValUnwrap htpLabelSpadValue(htPage, 'nyest) - u := nxest - 4 - v := nyest - 4 - wlist := [u,v] - w := APPLY ('MAX, wlist) - lwrk := (7*u*v + 25*w)*(w + 1) + 2*(u + v + 4*m) + 23*w + 56 - liwrk := m + 2*(nxest - 7)*(nyest - 7) - s := htpLabelInputString(htPage,'s) - initial := htpButtonValue(htPage,'start) - start := - initial = 'cold => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = 30 and start = 1) => e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) - start = 1 => e02ddfColdSolve (htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) - -- need to change as only wrk(1) is required - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - post := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - lamdaList := - "append"/[g(i) for i in 1..nxest] where g(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Lamda: \newline") - lamdaList := [['text,:prefix],:lamdaList] - muList := - "append"/[h(i) for i in 1..nyest] where h(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Mu: \newline") - muList := [['text,:prefix],:muList] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of nx: \newline \tab{2}") - nxList := [['text,:prefix],['bcStrings,[8, 10, 'nx, 'PI]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of ny: \newline \tab{2}") - nyList := [['text,:prefix],['bcStrings,[8, 9, 'ny, 'PI]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of WRK(1): \newline \tab{2}") - wList := [['text,:prefix],['bcStrings,[8, 0.0, 'wone, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamdaList,:muList,:nxList,:nyList,:wList] - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" - htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " - htSay '"\htbitmap{fr}: \tab{45} \menuitemstyle{} " - htSay '"\tab{47} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ddfWarmGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - - -e02ddfColdSolve(htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) == - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - post := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" - htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " - htSay '"\htbitmap{fr}: \tab{44} \menuitemstyle{} " - htSay '"\tab{46} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ddfColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == - m := 30 - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") - (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") - (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") - (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") - (text . "\tab{46} Values of \htbitmap{wr}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "11.16" x1 F)) - (text . "\tab{17}") - (bcStrings (8 "1.24" y1 F)) - (text . "\tab{32}") - (bcStrings (8 "22.15" f1 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "12.85" x2 F)) - (text . "\tab{17}") - (bcStrings (8 "3.06" y2 F)) - (text . "\tab{32}") - (bcStrings (8 "22.11" f2 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "19.85" x3 F)) - (text . "\tab{17}") - (bcStrings (8 "10.72" y3 F)) - (text . "\tab{32}") - (bcStrings (8 "7.97" f3 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "19.72" x4 F)) - (text . "\tab{17}") - (bcStrings (8 "1.39" y4 F)) - (text . "\tab{32}") - (bcStrings (8 "16.83" f4 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "15.91" x5 F)) - (text . "\tab{17}") - (bcStrings (8 "7.74" y5 F)) - (text . "\tab{32}") - (bcStrings (8 "15.30" f5 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0" x6 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y6 F)) - (text . "\tab{32}") - (bcStrings (8 "34.6" f6 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "20.87" x7 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y7 F)) - (text . "\tab{32}") - (bcStrings (8 "5.74" f7 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "3.45" x8 F)) - (text . "\tab{17}") - (bcStrings (8 "12.78" y8 F)) - (text . "\tab{32}") - (bcStrings (8 "41.24" f8 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "14.26" x9 F)) - (text . "\tab{17}") - (bcStrings (8 "17.87" y9 F)) - (text . "\tab{32}") - (bcStrings (8 "10.74" f9 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.43" x10 F)) - (text . "\tab{17}") - (bcStrings (8 "3.46" y10 F)) - (text . "\tab{32}") - (bcStrings (8 "18.60" f10 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w10 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.8" x11 F)) - (text . "\tab{17}") - (bcStrings (8 "12.39" y11 F)) - (text . "\tab{32}") - (bcStrings (8 "5.47" f11 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w11 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "7.58" x12 F)) - (text . "\tab{17}") - (bcStrings (8 "1.98" y12 F)) - (text . "\tab{32}") - (bcStrings (8 "29.87" f12 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w12 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "25" x13 F)) - (text . "\tab{17}") - (bcStrings (8 "11.87" y13 F)) - (text . "\tab{32}") - (bcStrings (8 "4.4" f13 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w13 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0" x14 F)) - (text . "\tab{17}") - (bcStrings (8 "0" y14 F)) - (text . "\tab{32}") - (bcStrings (8 "58.2" f14 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w14 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "9.66" x15 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y15 F)) - (text . "\tab{32}") - (bcStrings (8 "4.73" f15 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w15 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "5.22" x16 F)) - (text . "\tab{17}") - (bcStrings (8 "14.66" y16 F)) - (text . "\tab{32}") - (bcStrings (8 "40.36" f16 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w16 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.25" x17 F)) - (text . "\tab{17}") - (bcStrings (8 "19.57" y17 F)) - (text . "\tab{32}") - (bcStrings (8 "6.43" f17 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w17 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "25" x18 F)) - (text . "\tab{17}") - (bcStrings (8 "3.87" y18 F)) - (text . "\tab{32}") - (bcStrings (8 "8.74" f18 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w18 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "12.13" x19 F)) - (text . "\tab{17}") - (bcStrings (8 "10.79" y19 F)) - (text . "\tab{32}") - (bcStrings (8 "13.71" f19 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w19 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.23" x20 F)) - (text . "\tab{17}") - (bcStrings (8 "6.21" y20 F)) - (text . "\tab{32}") - (bcStrings (8 "10.25" f20 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w20 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "11.52" x21 F)) - (text . "\tab{17}") - (bcStrings (8 "8.53" y21 F)) - (text . "\tab{32}") - (bcStrings (8 "15.74" f21 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w21 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "15.2" x22 F)) - (text . "\tab{17}") - (bcStrings (8 "0" y22 F)) - (text . "\tab{32}") - (bcStrings (8 "21.6" f22 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w22 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "7.54" x23 F)) - (text . "\tab{17}") - (bcStrings (8 "10.69" y23 F)) - (text . "\tab{32}") - (bcStrings (8 "19.31" f23 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w23 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.32" x24 F)) - (text . "\tab{17}") - (bcStrings (8 "13.78" y24 F)) - (text . "\tab{32}") - (bcStrings (8 "12.11" f24 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w24 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "2.14" x25 F)) - (text . "\tab{17}") - (bcStrings (8 "15.03" y25 F)) - (text . "\tab{32}") - (bcStrings (8 "53.1" f25 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w25 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.51" x26 F)) - (text . "\tab{17}") - (bcStrings (8 "8.37" y26 F)) - (text . "\tab{32}") - (bcStrings (8 "49.43" f26 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w26 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.69" x27 F)) - (text . "\tab{17}") - (bcStrings (8 "19.63" y27 F)) - (text . "\tab{32}") - (bcStrings (8 "3.25" f27 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w27 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "5.47" x28 F)) - (text . "\tab{17}") - (bcStrings (8 "17.13" y28 F)) - (text . "\tab{32}") - (bcStrings (8 "28.63" f28 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w28 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "21.67" x29 F)) - (text . "\tab{17}") - (bcStrings (8 "14.36" y29 F)) - (text . "\tab{32}") - (bcStrings (8 "5.52" f29 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w29 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "3.31" x30 F)) - (text . "\tab{17}") - (bcStrings (8 "0.33" y30 F)) - (text . "\tab{32}") - (bcStrings (8 "44.08" f30 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w30 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02ddfColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02ddfColdGen htPage == - m := htpProperty(htPage,'m) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - cold := '"c" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - flist := [right,:flist] - wlist := [end,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - -- additional entries nx,ny,lamda,mu,wrk needed to get it running - -- but they are just set to 0.0 - prefix := STRCONC('"e02ddf(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") - prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,", 0,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,0,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nxest,"]],0,") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nyest,"]],") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE lwrk,"]],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e02ddfWarmGen htPage == - m := htpProperty(htPage,'m) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - warm := '"w" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - wrk := (first y).1 - y := rest y - for i in 1..lwrk repeat - wrkList := ['"0.0 ",:wrkList] - wrkList := [wrk,:wrkList] - wrkstring := bcwords2liststring wrkList - ny := STRCONC((first y).1," ") - y := rest y - nx := STRCONC((first y).1," ") - y := rest y - for i in 1..nyest repeat - mu := STRCONC ((first y).1, " ") - y := rest y - muList := [mu,:muList] - mustring := bcwords2liststring muList - for i in 1..nxest repeat - lam := STRCONC ((first y).1, " ") - y := rest y - lamList := [lam,:lamList] - lamstring := bcwords2liststring lamList - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - flist := [right,:flist] - wlist := [end,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - -- additional entries nx,ny,lamda,mu,wrk needed to get it running - -- but they are just set to 0.0 - prefix := STRCONC('"e02ddf(_"",warm,"_",",STRINGIMAGE m,", [",xstring,"],[") - prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",nx,",[",lamstring,"],",ny) - prefix := STRCONC(prefix,",[",mustring,"],[",wrkstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e02zaf() == - htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02zaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02zaf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Sorts the set of points {\em (\htbitmap{xr},") - (text . "\htbitmap{yr})} into panels defined by \space{1}") - (text . "\htbitmap{px} -8 points \htbitmap{lamdai} ") - (text . "on the x-axis and \space{1}\htbitmap{py}-8 points ") - (text . "\htbitmap{muj} on the y axis. The points are ordered ") - (text . "so that all points in a panel occur before data in succeeding ") - (text . "panels. Within a panel, the points maintain their original ") - (text . "order. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of points to be sorted to be sorted {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 10 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Intercepts + 8 on x axis {\em px}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Intercepts + 8 on y axis {\em py}:") - (text . "\newline\tab{2} ") - (bcStrings (6 9 px PI)) - (text . "\tab{34} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Dimension of point {\it npoint}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 45 npoint PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02zafSolve) - htShowPage() - -e02zafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - npoint := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) - objValUnwrap htpLabelSpadValue(htPage, 'npoint) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '10 and px = '9) and py = '10) => e02zafDefaultSolve(htPage,npoint,ifail) - labelList := - "append"/[fxy(i) for i in 1..m] where fxy(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{32} ") - lnam := INTERN STRCONC ('"x",STRINGIMAGE i) - cnam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, lnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, cnam, 'F]]] - lamList := - "append"/[flam(i) for i in 5..(px-4)] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(5) to ") - prefix := STRCONC(prefix,"\lambda(px-4)}: \newline \tab{2} ") - lamList := [['text,:prefix],:lamList] - muList := - "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(5) to \mu(py-4)}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - muList := [['text,:prefix],:muList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamList,:muList] - page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htSay '"\menuitemstyle{}\tab{2} {\it x(m)}: " - htSay '"\tab{30} \menuitemstyle{}\tab{32} {\it y(m)}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02zafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02zafDefaultSolve (htPage,npoint,ifail) == - m := '10 - px := '9 - py := '10 - page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} {\it x(m)}:") - (text . "\tab{30} \menuitemstyle{} \tab{32} {\it y(m)}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "0.00" x1 F)) - (text . "\tab{32}") - (bcStrings (8 "0.77" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.70" x2 F)) - (text . "\tab{32}") - (bcStrings (8 "1.06" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.44" x3 F)) - (text . "\tab{32}") - (bcStrings (8 "0.33" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.21" x4 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.01" x5 F)) - (text . "\tab{32}") - (bcStrings (8 "0.50" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.84" x6 F)) - (text . "\tab{32}") - (bcStrings (8 "0.02" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.71" x7 F)) - (text . "\tab{32}") - (bcStrings (8 "1.95" y7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.00" x8 F)) - (text . "\tab{32}") - (bcStrings (8 "1.20" y8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.54" x9 F)) - (text . "\tab{32}") - (bcStrings (8 "0.04" y9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.531" x10 F)) - (text . "\tab{32}") - (bcStrings (8 "0.18" y10 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \lambda(5) to \lambda(px-4)}:") - (text . "\newline \tab{2}") - (bcStrings (8 "1.00" l5 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \mu(5) to \mu(py-4)}:") - (text . "\newline \tab{2}") - (bcStrings (8 "0.80" mu5 F)) - (bcStrings (8 "1.20" mu6 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'e02zafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02zafGen htPage == - m := htpProperty(htPage,'m) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - npoint := htpProperty(htPage,'npoint) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - nadres := (px-7)*(py-7) - -- mu - for i in 1..4 repeat - muList := ['"0 ",:muList] - for i in 5..(py-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - for i in (py-3)..py repeat - muList := ['"0 ",:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..4 repeat - lamList := ['"0 ",:lamList] - for i in 5..(px-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - for i in (px-3)..px repeat - lamList := ['"0 ",:lamList] - lamstring := bcwords2liststring lamList - -- x & y - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [right,:ylist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - prefix := STRCONC('"e02zaf(",STRINGIMAGE px,", ",STRINGIMAGE py,",[") - prefix := STRCONC(prefix,lamstring,"],[",mustring,"], ",STRINGIMAGE m,", [") - prefix := STRCONC(prefix,xstring,"],[",ystring,"], ",STRINGIMAGE npoint,", ") - prefix := STRCONC(prefix,STRINGIMAGE nadres,", ",STRINGIMAGE ifail,")") - linkGen prefix - - - diff --git a/src/interp/nag-e02.boot.pamphlet b/src/interp/nag-e02.boot.pamphlet new file mode 100644 index 00000000..3d738dd1 --- /dev/null +++ b/src/interp/nag-e02.boot.pamphlet @@ -0,0 +1,4693 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-e02.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +e02adf() == + htInitPage('"E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02adf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines weighted least-squares polynomial approximations of ") + (text . "degrees 0,1,...,k to the set of points {\it (} ") + (text . "\htbitmap{xr}, \htbitmap{yr}{\it )} ") + (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") + (text . "The polynomials are in the Chebyshev series form, the ") + (text . "approximation of degree {\it i} being represented as ") + (text . "\newline \center{\htbitmap{e02adf}} , where ") + (text . "\htbitmap{xbar} is the normalised argument, which is ") + (text . "related to the original variable {\it x} by the transformation ") + (text . "\blankline \center{\htbitmap{e02adf1}} ") + (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") + (text . "the values of \htbitmap{xr} respectively ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}:") + (text . "\newline \tab{2} ") + (bcStrings (6 11 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Maximum degree required {\it k}:") + (text . "\newline \tab{2} ") + (bcStrings (6 3 k PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "First dimension of A, {\it nrows} \htbitmap{great=} {\it k+1}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 50 nrows I)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02adfSolve) + htShowPage() + +e02adfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + k := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) + objValUnwrap htpLabelSpadValue(htPage, 'k) + nrows := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrows) + objValUnwrap htpLabelSpadValue(htPage, 'nrows) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '11 and k ='3) => e02adfDefaultSolve(htPage,k,nrows,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", htpPropertyList htPage) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02adfGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'k,k) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02adfDefaultSolve (htPage,k,nrows,ifail) == + m := '11 + page := htInitPage('"E02ADF - Least-squares curve fit, by polynomials, arbitrary data points", htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{wr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "1.00" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.40" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.10" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.90" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.10" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.70" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.90" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.50" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.90" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.20" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.80" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.20" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.80" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.50" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "5.10" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.80" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.10" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "9.20" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.70" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.80" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "16.10" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.50" z9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.40" x10 F)) + (text . "\tab{22} ") + (bcStrings (10 "24.50" y10 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.30" z10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.00" x11 F)) + (text . "\tab{22} ") + (bcStrings (10 "35.30" y11 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.20" z11 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02adfGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'k,k) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02adfGen htPage == + m := htpProperty(htPage,'m) + k := htpProperty(htPage,'k) + nrows := htpProperty(htPage,'nrows) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + kplus1 := k + 1 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + wlist := [right,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + wstring := bcwords2liststring wlist + prefix := STRCONC('"e02adf(",STRINGIMAGE m,", ",STRINGIMAGE kplus1,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrows,", [",xstring,"],[",ystring,"],[") + prefix := STRCONC(prefix,wstring,"],",STRINGIMAGE ifail,")") + linkGen prefix + +e02aef() == + htInitPage('"E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series form", nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02aef| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates a polynomial in Chabyshev series representation ") + (text . "\newline \center{\htbitmap{e02aef}} ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of terms in the series {\it n}:") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\htbitmap{xbar}: ") + (text . " \newline \tab{2} ") + (bcStrings (6 "-1.0" xcap F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02aefSolve) + htShowPage() + +e02aefSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + xcap := htpLabelInputString(htPage,'xcap) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => e02aefDefaultSolve(htPage,xcap,ifail) + labelList := + "append"/[f(i) for i in 1..(n+1)] where f(i) == + prefix := ('"\newline \tab{15} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, anam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series from", nil) + htSay '"\menuitemstyle{}\tab{2} Enter the coefficients of {\it a(n+1)}:" + htSay '"\blankline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02aefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'xcap,xcap) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02aefDefaultSolve (htPage,xcap,ifail) == + n := '4 + page := htInitPage('"E02AEF - Evaluation of fitted polynomial in one variable from Chebyshev series form", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the coeffients of {\it a(n+1)}: ") + (text . "\blankline ") + (text . "\newline \tab{15} ") + (bcStrings (10 "2.0000" a1 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.5000" a2 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.2500" a3 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.1250" a4 F)) + (text . "\newline \tab{15} ") + (bcStrings (10 "0.0625" a5 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'e02aefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'xcap,xcap) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02aefGen htPage == + n := htpProperty(htPage,'n) + xcap := htpProperty(htPage,'xcap) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + nplus1 := n + 1 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + arrayList := [right,:arrayList] + astring := bcwords2liststring arrayList + prefix := STRCONC('"e02aef(",STRINGIMAGE nplus1,", [",astring ,"], ") + prefix := STRCONC(prefix,STRINGIMAGE xcap,", ",STRINGIMAGE ifail,")") + linkGen prefix + +e02agf() == + htInitPage('"E02AGF - Least-squares polynomial fit, values and derivatives may be constrained, arbitrary data values",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02agf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02agf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines constrained least-squares polynomial approximations ") + (text . "to the set of points {\it (\htbitmap{xr},\htbitmap{yr})} with ") + (text . "weights \htbitmap{wr}, for r = 1,2,...,m. The values of the ") + (text . "approximations and any number of their derivatives must be ") + (text . "specified at a further set of points \htbitmap{xii}, ") + (text . "for i = 1,2,...,{\it mf}. The total number of interpolating ") + (text . "conditions is given by \center{\htbitmap{e02agf}} where ") + (text . "\htbitmap{pi} is the highest order derivative ") + (text . "specified at point \htbitmap{xii}. The values ") + (text . "\htbitmap{xr} and \htbitmap{xii} all lie ") + (text . "in the interval [\htbitmap{xmin},") + (text . "\htbitmap{xmax}]. The polynomials are given in ") + (text . "Chebyshev series form, the approximation of degree {\it i} being") + (text . " represented as\blankline \center{\htbitmap{e02agf1}}") + (text . "\newline, where \htbitmap{xbar} is the normalised ") + (text . "argument, related to the original variable {\it x} by the ") + (text . "transformation \newline \center{\htbitmap{e02adf1}} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Number of data points {\it m}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Maximum degree required {\it k}:") + (text . "\newline\tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 4 k PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "First dimension of A, {\it nrows \htbitmap{great=} k+1}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 6 nrows I)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline \htbitmap{xmin}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\htbitmap{xmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "0.0" xmin F)) + (text . "\tab{34} ") + (bcStrings (6 "4.0" xmax F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Dimension of {\it xf} & {\it ip}, {\it mf}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Dimension of {\it yf}, {\it lyf}:") + (text . "\newline\tab{2} ") + (bcStrings (6 2 mf PI)) + (text . "\tab{34} ") + (bcStrings (6 15 lyf PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02agfSolve) + htShowPage() + +e02agfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + k := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'k) + objValUnwrap htpLabelSpadValue(htPage, 'kplus1) + nrows := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrows) + objValUnwrap htpLabelSpadValue(htPage, 'nrows) + xmin := htpLabelInputString(htPage,'xmin) + xmax := htpLabelInputString(htPage,'xmax) + mf := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mf) + objValUnwrap htpLabelSpadValue(htPage, 'mf) + lyf := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lyf) + objValUnwrap htpLabelSpadValue(htPage, 'lyf) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '5 and k ='4 and mf = '2 and lyf = '15) => e02agfDefaultSolve(htPage,nrows,xmin,xmax,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + xfList := + "append"/[g(j) for j in 1..mf] where g(j) == + xfnam := INTERN STRCONC ('"xf",STRINGIMAGE j) + [['bcStrings,[6, 0.0, xfnam, 'F]]] + prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") + prefix := STRCONC(prefix,"{\it xf}: \newline \tab{2} ") + xfList := [['text,:prefix],:xfList] + ipList := + "append"/[h(k) for k in 1..mf] where h(k) == + ipnam := INTERN STRCONC ('"ip",STRINGIMAGE k) + [['bcStrings,[6, 0, ipnam, 'PI]]] + prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") + prefix := STRCONC(prefix,"{\it ip}: \newline \tab{2} ") + ipList := [['text,:prefix],:ipList] + yfList := + "append"/[i(l) for l in 1..lyf] where i(l) == + prefix := ('"\newline \tab{2} ") + yfnam := INTERN STRCONC ('"lyf",STRINGIMAGE l) + [['text,:prefix],['bcStrings,[10, 0.0, yfnam, 'F]]] + prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} Values of ") + prefix := STRCONC(prefix,"{\it yf}: \newline \tab{2} ") + yfList := [['text,:prefix],:yfList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:xfList,:ipList,:yfList] + page := htInitPage("E02AGF - Least-squares polynomial fit, values and derivatives may be constrained, arbitrary data values",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{wr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02agfGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'k,k) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'mf,mf) + htpSetProperty(page,'lyf,lyf) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02agfDefaultSolve (htPage,nrows,xmin,xmax,ifail) == + m := '5 + k := '4 + mf := '2 + lyf := '15 + page := htInitPage('"E02AGF - Least-squares polynomial fit, values and derivativesby polynomials, arbitrary data points", htpPropertyList htPage) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{wr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.5" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.03" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.0" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.0" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "-0.75" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.0" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.0" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "-1.0" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.0" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.5" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "-0.1" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.0" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.0" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.75" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.0" z5 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it xf}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" xf1 F)) + (bcStrings (6 "4.0" xf2 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it ip}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 ip1 PI)) + (bcStrings (6 0 ip2 PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it yf}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "1.0" lyf1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "-2.0" lyf2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.0" lyf3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf14 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" lyf15 F))) + htMakeDoneButton('"Continue",'e02agfGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'k,k) + htpSetProperty(page,'nrows,nrows) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'mf,mf) + htpSetProperty(page,'lyf,lyf) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02agfGen htPage == + m := htpProperty(htPage,'m) + k := htpProperty(htPage,'k) + nrows := htpProperty(htPage,'nrows) + xmin := htpProperty(htPage,'xmin) + xmax := htpProperty(htPage,'xmax) + mf := htpProperty(htPage,'mf) + lyf := htpProperty(htPage,'lyf) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + kplus1 := k + 1 + ipsum := 0 + y := alist + for i in 1..lyf repeat + yf := STRCONC((first y).1," ") + yfList := [yf,:yfList] + y := rest y + yfstring := bcwords2liststring yfList + for i in 1..mf repeat + iptest := (first y).1 + iptestval := READ_-FROM_-STRING(iptest) + ipsum := ipsum + iptestval + ip := STRCONC(iptest," ") + iptestList := [iptestval,:iptestList] + ipList := [ip,:ipList] + y := rest y + ipstring := bcwords2liststring ipList + ipmax := APPLY ('MAX, iptestList) + n := mf + ipsum + for i in 1..mf repeat + xf := STRCONC((first y).1," ") + xfList := [xf,:xfList] + y := rest y + xfstring := bcwords2liststring xfList + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + wlist := [right,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + wstring := bcwords2liststring wlist + wrktest1 := 4*m + 3*kplus1 + wrktest2 := 8*n + 5*ipmax + mf +10 + wrktestlist := [wrktest1,wrktest2] + wrkmax := APPLY ('MAX, wrktestlist) + lwrk := wrkmax + 2*n + 2 + liwrk := 2*mf + 2 + prefix := STRCONC('"e02agf(",STRINGIMAGE m,", ",STRINGIMAGE kplus1,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrows,", ",xmin,", ",xmax,", [",xstring) + prefix := STRCONC(prefix,"],[",ystring,"],[",wstring,"],",STRINGIMAGE mf) + prefix := STRCONC(prefix,", [",xfstring,"],[",yfstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE lyf,", [",ipstring,"]::Matrix Integer,") + prefix := STRCONC(prefix,STRINGIMAGE lwrk,", ",STRINGIMAGE liwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e02ahf() == + htInitPage('"E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02ahf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ahf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines the indefinite integral of the Chebyshev series ") + (text . "representation \newline \center{\htbitmap{e02ahf1}} ") + (text . "of a polynomial, where \htbitmap{xbar} is the ") + (text . "normalised argument, related to the original variable x by the ") + (text . "transformation \blankline \center{\htbitmap{e02adf1}}") + (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") + (text . "minimum and maximum values of {\it x} respectively. The integral") + (text . " polynomial has the form ") + (text . "\blankline \center{\htbitmap{e02ahf}}") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Degree of the polynomial {\it n}:") + (text . "\newline \tab{2} ") + (bcStrings (6 6 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline \htbitmap{xmin}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\htbitmap{xmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "-0.5" xmin F)) + (text . "\tab{34} ") + (bcStrings (6 "2.5" xmax F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Dimension of array {\it a}, {\it la}: ") +-- (text . "\tab{32} \menuitemstyle{}\tab{34}") +-- (text . "Dimension of {\it adif}, {\it ladif}: ") +-- (text . "\newline\tab{2} ") +-- (bcStrings (6 7 la PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 7 ladif PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Increment of array {\it a}, {\it ia1}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\newline Increment of array {\it adif}, {\it ladif1}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 1 iaone PI)) + (text . "\tab{34} ") + (bcStrings (6 1 ladifone PI)) + (text . "\blankline") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02ahfSolve) + htShowPage() + +e02ahfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + xmin := htpLabelInputString(htPage,'xmin) + xmax := htpLabelInputString(htPage,'xmax) + iaone := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) + objValUnwrap htpLabelSpadValue(htPage, 'iaone) + ladifone := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ladifone) + objValUnwrap htpLabelSpadValue(htPage, 'ladifone) + la := 1+n*iaone +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) +-- objValUnwrap htpLabelSpadValue(htPage, 'la) + ladif :=1+n*ladifone +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ladif) +-- objValUnwrap htpLabelSpadValue(htPage, 'ladif) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and (la ='7 and ladif = '7)) => + e02ahfDefaultSolve(htPage,xmin,xmax,iaone,ladifone,ifail) + labelList := + "append"/[f(i) for i in 1..la] where f(i) == + prefix := ('"\newline \tab{15} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) + htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ahfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'ladif,ladif) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'ladifone,ladifone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02ahfDefaultSolve (htPage,xmin,xmax,iaone,ladifone,ifail) == + n := '6 + la := '7 + ladif := '7 + page := htInitPage('"E02AHF - Derivative of fitted polynomial in Chebyshev series",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} ") + (text . "Coefficients of {\it a(la)}: ") + (text . "\newline \tab{15}") + (bcStrings (10 "2.53213" a1 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "1.13032" a2 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.27150" a3 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.04434" a4 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00547" a5 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00054" a6 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00004" a7 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02ahfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'ladif,ladif) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'ladifone,ladifone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02ahfGen htPage == + n := htpProperty(htPage,'n) + la := htpProperty(htPage,'la) + ladif := htpProperty(htPage,'ladif) + xmin := htpProperty(htPage,'xmin) + xmax := htpProperty(htPage,'xmax) + iaone := htpProperty(htPage,'iaone) + ladifone := htpProperty(htPage,'ladifone) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + np1 := n + 1 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + arrayList := [right,:arrayList] + astring := bcwords2liststring arrayList + prefix := STRCONC('"e02ahf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") + prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") + prefix := STRCONC(prefix,STRINGIMAGE la,", ",STRINGIMAGE ladifone,", ") + prefix := STRCONC(prefix,STRINGIMAGE ladif,", ",STRINGIMAGE ifail,")") + linkGen prefix + +e02ajf() == + htInitPage('"E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02ajf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ajf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines the indefinite integral of the Chebyshev series ") + (text . "representation \newline \center{\htbitmap{e02ahf1}} ") + (text . "of a polynomial, where \htbitmap{xbar} is the normalis") + (text . "ed argument, related to the original variable {\it x} by the ") + (text . "transformation \blankline \center{\htbitmap{e02adf1}}") + (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") + (text . "minimum and maximum values of {\it x} respectively. The integral") + (text . " polynomial has the form ") + (text . "\blankline \center{\htbitmap{e02ajf}}") + (text . "and the integration is with respect to the original variable ") + (text . "{\it x} \blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Degree of the polynomial {\it n}:") + (text . "\newline \tab{2} ") + (bcStrings (6 6 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline \htbitmap{xmin}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\htbitmap{xmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "-0.5" xmin F)) + (text . "\tab{34} ") + (bcStrings (6 "2.5" xmax F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Dimension of array {\it a}, {\it la}: ") +-- (text . "\tab{32} \menuitemstyle{}\tab{34}") +-- (text . "Dimension of {\it aint}, {\it laint}: ") +-- (text . "\newline\tab{2} ") +-- (bcStrings (6 7 la PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 8 laint PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Index increment of {\it a}, {\it ia1}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Increment of {\it aint}, {\it iaint1}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 iaone PI)) + (text . "\tab{34} ") + (bcStrings (6 1 iaintone PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Constant of integration {\it qatm1}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" qatmone F)) + (text . "\blankline") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02ajfSolve) + htShowPage() + +e02ajfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + xmin := htpLabelInputString(htPage,'xmin) + xmax := htpLabelInputString(htPage,'xmax) + iaone := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) + objValUnwrap htpLabelSpadValue(htPage, 'iaone) + iaintone := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaintone) + objValUnwrap htpLabelSpadValue(htPage, 'iaintone) + la := 1+n*iaone +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) +-- objValUnwrap htpLabelSpadValue(htPage, 'la) + laint := n*iaintone + 1 + qatmone := htpLabelInputString(htPage,'qatmone) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and (la ='7 and laint = '7)) => + e02ajfDefaultSolve(htPage,xmin,xmax,iaone,iaintone,qatmone,ifail) + labelList := + "append"/[f(i) for i in 1..la] where f(i) == + prefix := ('"\newline \tab{15} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) + htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ajfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'laint,laint) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'iaintone,iaintone) + htpSetProperty(page,'qatmone,qatmone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02ajfDefaultSolve (htPage,xmin,xmax,iaone,iaintone,qatmone,ifail) == + n := '6 + la := '7 + laint := '8 + page := htInitPage('"E02AJF - Integral of fitted polynomial in Chebyshev series form",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} ") + (text . "Coefficients of {\it a(la)}: ") + (text . "\newline \tab{15}") + (bcStrings (10 "2.53213" a1 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "1.13032" a2 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.27150" a3 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.04434" a4 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00547" a5 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00054" a6 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00004" a7 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02ajfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'laint,laint) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'iaintone,iaintone) + htpSetProperty(page,'qatmone,qatmone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02ajfGen htPage == + n := htpProperty(htPage,'n) + la := htpProperty(htPage,'la) + laint := htpProperty(htPage,'laint) + xmin := htpProperty(htPage,'xmin) + xmax := htpProperty(htPage,'xmax) + iaone := htpProperty(htPage,'iaone) + iaintone := htpProperty(htPage,'iaintone) + qatmone := htpProperty(htPage,'qatmone) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + np1 := n + 1 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + arrayList := [right,:arrayList] + astring := bcwords2liststring arrayList + prefix := STRCONC('"e02ajf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") + prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") + prefix := STRCONC(prefix,STRINGIMAGE la,", ",qatmone,", ") + prefix := STRCONC(prefix,STRINGIMAGE iaintone) + prefix := STRCONC(prefix,", ",STRINGIMAGE laint,", ",STRINGIMAGE ifail,")") + linkGen prefix + +e02akf() == + htInitPage('"E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02akf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02akf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates at the point x the Chebyshev series representation ") + (text . "representation \newline \center{\htbitmap{e02ahf1}} ") + (text . "of a polynomial, where \htbitmap{xbar} is the normalis") + (text . "ed argument, related to the original variable {\it x} by the ") + (text . "transformation \blankline \center{\htbitmap{e02adf1}}") + (text . ",\htbitmap{xmin} and \htbitmap{xmax} being ") + (text . "minimum and maximum values of {\it x} respectively. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Degree of the polynomial {\it n}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Evaluation point {\it x}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 6 n PI)) + (text . "\tab{34} ") + (bcStrings (6 "-0.5" x F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline \htbitmap{xmin}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "\htbitmap{xmax}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "-0.5" xmin F)) + (text . "\tab{34} ") + (bcStrings (6 "2.5" xmax F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Dimension of array {\it a}, {\it la} : ") +-- (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Index increment of {\it a}, {\it ia1}: ") + (text . "\newline\tab{2} ") +-- (bcStrings (6 7 la PI)) +-- (text . "\tab{34} ") + (bcStrings (6 1 iaone PI)) + (text . "\blankline") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02akfSolve) + htShowPage() + +e02akfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + x := htpLabelInputString(htPage,'x) + xmin := htpLabelInputString(htPage,'xmin) + xmax := htpLabelInputString(htPage,'xmax) + iaone := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaone) + objValUnwrap htpLabelSpadValue(htPage, 'iaone) + la := 1+n*iaone +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) +-- objValUnwrap htpLabelSpadValue(htPage, 'la) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and la ='7) => e02akfDefaultSolve(htPage,xmin,xmax,x,iaone,ifail) + labelList := + "append"/[f(i) for i in 1..la] where f(i) == + prefix := ('"\newline \tab{15} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, "0.0000", anam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) + htSay '"\menuitemstyle{}\tab{2} Coefficients of {\it a(la)}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02akfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'x,x) + htpSetProperty(page,'la,la) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02akfDefaultSolve (htPage,xmin,xmax,x,iaone,ifail) == + n := '6 + la := '7 + page := htInitPage('"E02AKF - Evaluation of fitted polynomial in one variable, from Chebyshev series form",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} ") + (text . "Coefficients of {\it a(la)}: ") + (text . "\newline \tab{15}") + (bcStrings (10 "2.53213" a1 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "1.13032" a2 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.27150" a3 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.04434" a4 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00547" a5 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00054" a6 F)) + (text . "\newline \tab{15}") + (bcStrings (10 "0.00004" a7 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02akfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'x,x) + htpSetProperty(page,'xmin,xmin) + htpSetProperty(page,'xmax,xmax) + htpSetProperty(page,'iaone,iaone) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02akfGen htPage == + n := htpProperty(htPage,'n) + x := htpProperty(htPage,'x) + la := htpProperty(htPage,'la) + xmin := htpProperty(htPage,'xmin) + xmax := htpProperty(htPage,'xmax) + iaone := htpProperty(htPage,'iaone) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + np1 := n + 1 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + arrayList := [right,:arrayList] + astring := bcwords2liststring arrayList + prefix := STRCONC('"e02akf(",STRINGIMAGE np1,", ",xmin,", ",xmax,", [") + prefix := STRCONC(prefix,astring,"], ",STRINGIMAGE iaone,", ") + prefix := STRCONC(prefix,STRINGIMAGE la,", ",x,", ",STRINGIMAGE ifail,")") + linkGen prefix + + +e02baf() == + htInitPage('"E02BAF - Least-squares curve cubic spine fit",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02baf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02baf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a least-squares cubic spline approximation to the ") + (text . "set of points {\it (}\htbitmap{xr},") + (text . "\htbitmap{yr}{\it )} with weights ") + (text . "\htbitmap{wr}, for r = 1,2,...,m. ") + (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") + (text . "\htbitmap{ncap}+7, are prescribed by the user. The ") + (text . "spline is given by the B-spline representation \blankline ") + (text . "\center{\htbitmap{e02baf}} where ") + (text . "\htbitmap{ncap} is the number of intervals of the ") + (text . "spline. \blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}:") + (text . "\newline \tab{2} ") + (bcStrings (6 14 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of intervals in the spline \htbitmap{ncap}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 5 ncap PI)) + (text . "\blankline") + (text . "\newline") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02bafSolve) + htShowPage() + +e02bafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + ncap := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) + objValUnwrap htpLabelSpadValue(htPage, 'ncap) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '14 and ncap ='5) => e02bafDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + lamdaList := + "append"/[g(j) for j in 5..(ncap+3)] where g(j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE j) + [['bcStrings,[6, 0.0, anam, 'F]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} Interior knots ") + prefix := STRCONC(prefix,"\htbitmap{lamdai}, for i = 5,6,...,") + prefix := STRCONC(prefix,"\htbitmap{ncap} + 3: \newline \tab{2}" ) + lamdaList := [['text,:prefix],:lamdaList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamdaList] + page := htInitPage("E02BAF - Least-squares curve cubic spline fit",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{fr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{dr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02bafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02bafDefaultSolve (htPage,ifail) == + m := '14 + ncap := '5 + page := htInitPage('"E02BAF - Least-squares curve cubic spline fit",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{wr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.20" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.20" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.47" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.00" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.20" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.74" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.00" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.30" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.09" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.00" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.70" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.60" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.00" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.90" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.90" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.62" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.60" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "9.10" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.10" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.90" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "8.15" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.80" z9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.15" x10 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.00" y10 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.50" z10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.17" x11 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.00" y11 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.70" z11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.00" x12 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.54" y12 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "10.00" x13 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.39" y13 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "12.00" x14 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.56" y14 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "Interior knots \htbitmap{lamdai}, for i = 5,6,...") + (text . "\htbitmap{ncap} + 3: \newline \tab{2}") + (bcStrings (6 "1.50" l1 F)) + (bcStrings (6 "2.60" l2 F)) + (bcStrings (6 "4.00" l3 F)) + (bcStrings (6 "8.00" l4 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02bafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02bafGen htPage == + m := htpProperty(htPage,'m) + ncap := htpProperty(htPage,'ncap) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + ncap7 := ncap + 7 + y := alist + for i in (ncap+4)..(ncap+7) repeat + lambda := STRCONC( "0.0"," ") + lambdaList := [lambda,:lambdaList] + for i in 5..(ncap+3) repeat + lambda := STRCONC ((first y).1," ") + y := rest y + lambdaList := [lambda,:lambdaList] + for i in 1..4 repeat + lambda := STRCONC( "0.0"," ") + lambdaList := [lambda,:lambdaList] + lambdaString := bcwords2liststring lambdaList + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + wlist := [right,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + wstring := bcwords2liststring wlist + prefix := STRCONC('"e02baf(",STRINGIMAGE m,", ",STRINGIMAGE ncap7,", [") + prefix := STRCONC(prefix,xstring,"],[",ystring,"],[",wstring,"], [") + prefix := STRCONC(prefix,lambdaString,"], ",STRINGIMAGE ifail,")") + linkGen prefix + + +e02bbf() == + htInitPage('"E02BBF - Evaluation of fitted cubic spline, function only",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02bbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bbf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates at the point {\it x} a cubic spline from its B-spline ") + (text . "B-spline representation ") + (text . "\center{\htbitmap{e02baf}} where ") + (text . "\htbitmap{ncap} is the number of intervals of the ") + (text . "spline. The spline has knots \htbitmap{lamdai}, for ") + (text . "i = 1,2,...,\htbitmap{ncap} + 7. \blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of intervals in the spline \htbitmap{ncap}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 4 ncap PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Evaluation point {\it x}:") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" x F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02bbfSolve) + htShowPage() + +e02bbfSolve htPage == + ncap := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) + objValUnwrap htpLabelSpadValue(htPage, 'ncap) + x := htpLabelInputString(htPage,'x) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ncap = '4 => e02bbfDefaultSolve(htPage,x,ifail) + labelList := + "append"/[f(i) for i in 1..(ncap+7)] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02BBF - Evaluation of fitted cubic spline, function only",nil) + htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " + htSay '"\tab{20} \menuitemstyle{}\tab{22} " + htSay '"Coefficients \space{1} \htbitmap{ci}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02bbfGen) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'x,x) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02bbfDefaultSolve (htPage,x,ifail) == + ncap := '4 + page := htInitPage('"E02BBF - Evaluation of fitted cubic spline, function only",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Knots \space{1}") + (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Coefficients \space{1} \htbitmap{ci}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "1.00" l1 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.00" c1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" l2 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.00" c2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" l3 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.00" c3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" l4 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.00" c4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l5 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.00" c5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l6 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.00" c6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.00" l7 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.00" c7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.00" l8 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.00" l9 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.00" l10 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "9.00" l11 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c11 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02bbfGen) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'x,x) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02bbfGen htPage == + ncap := htpProperty(htPage,'ncap) + x := htpProperty(htPage,'x) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + ncap7 := ncap + 7 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + lamlist := [left,:lamlist] + clist := [right,:clist] + lamstring := bcwords2liststring lamlist + cstring := bcwords2liststring clist + prefix := STRCONC('"e02bbf(",STRINGIMAGE ncap7,", [",lamstring,"],[") + prefix := STRCONC(prefix,cstring,"], ",x,", ",STRINGIMAGE ifail,")") + linkGen prefix + + +e02bcf() == + htInitPage('"E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02bcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bcf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates at the point {\it x} a cubic spline and its first ") + (text . "three derivatives from its B-spline representation ") + (text . "\center{\htbitmap{e02baf}} where ") + (text . "\htbitmap{ncap} is the number of intervals of the ") + (text . "spline. The spline has knots \htbitmap{lamdai}, for ") + (text . "i = 1,2,...,\htbitmap{ncap} + 7. \blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of intervals in the spline \htbitmap{ncap}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 ncap PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Evaluation point {\it x}:") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" x F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "{\it LEFT} specifies whether LH or RH derivatives are required: ") + (radioButtons deriv + ("" " Left-hand derivative" left) + ("" " Right-hand derivative" right)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02bcfSolve) + htShowPage() + +e02bcfSolve htPage == + ncap := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) + objValUnwrap htpLabelSpadValue(htPage, 'ncap) + x := htpLabelInputString(htPage,'x) + temp := htpButtonValue(htPage,'deriv) + deriv := + temp = 'left => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ncap = '7 => e02bcfDefaultSolve(htPage,x,deriv,ifail) + labelList := + "append"/[f(i) for i in 1..(ncap+7)] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) + htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " + htSay '"\tab{20} \menuitemstyle{}\tab{22} " + htSay '"Coefficients \space{1} \htbitmap{ci}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02bcfGen) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'x,x) + htpSetProperty(page,'deriv,deriv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02bcfDefaultSolve (htPage,x,deriv,ifail) == + ncap := '7 + page := htInitPage('"E02BCF - Evaluation of fitted cubic spline, function and derivatives",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\menuitemstyle{}\tab{2} Knots \space{1}") + (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Coefficients \space{1} \htbitmap{ci}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.0" l1 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.00" c1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l2 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.00" c2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l3 F)) + (text . "\tab{22} ") + (bcStrings (10 "13.00" c3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l4 F)) + (text . "\tab{22} ") + (bcStrings (10 "15.00" c4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" l5 F)) + (text . "\tab{22} ") + (bcStrings (10 "22.00" c5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l6 F)) + (text . "\tab{22} ") + (bcStrings (10 "26.00" c6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l7 F)) + (text . "\tab{22} ") + (bcStrings (10 "24.00" c7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l8 F)) + (text . "\tab{22} ") + (bcStrings (10 "18.00" c8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" l9 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.00" c9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" l10 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.00" c10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l11 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l12 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l13 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l14 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c14 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02bcfGen) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'x,x) + htpSetProperty(page,'deriv,deriv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02bcfGen htPage == + ncap := htpProperty(htPage,'ncap) + x := htpProperty(htPage,'x) + deriv := htpProperty(htPage,'deriv) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + ncap7 := ncap + 7 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + lamlist := [left,:lamlist] + clist := [right,:clist] + lamstring := bcwords2liststring lamlist + cstring := bcwords2liststring clist + prefix := STRCONC('"e02bcf(",STRINGIMAGE ncap7,", [",lamstring,"],[") + prefix := STRCONC(prefix,cstring,"], ",x,", ",STRINGIMAGE deriv) + prefix := STRCONC(prefix,", ",STRINGIMAGE ifail,")") + linkGen prefix + + + +e02bdf() == + htInitPage('"E02BDF - Evaluation of fitted cubic spline, definite integral",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02bdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bdf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates the definite integral of a cubic spline from its ") + (text . "B-spline representation \center{\htbitmap{e02baf}} ") + (text . "where \htbitmap{ncap} is the number of intervals of ") + (text . "the spline. The spline has knots \htbitmap{lamdai}, ") + (text . "for i = 1,2,...,\htbitmap{ncap} + 7, and the integral ") + (text . "is evaluated over the range \htbitmap{e02bdf} ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of intervals in the spline \htbitmap{ncap}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 ncap PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02bdfSolve) + htShowPage() + +e02bdfSolve htPage == + ncap := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncap) + objValUnwrap htpLabelSpadValue(htPage, 'ncap) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ncap = '7 => e02bdfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..(ncap+7)] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, lnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, cnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage("E02BDF - Evaluation of fitted cubic spline, definite integral",nil) + htSay '"\menuitemstyle{}\tab{2} Knots \htbitmap{lamdai}: " + htSay '"\tab{20} \menuitemstyle{}\tab{22} " + htSay '"Coefficients \space{1} \htbitmap{ci}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02bdfGen) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02bdfDefaultSolve(htPage,ifail) == + ncap := '7 + page := htInitPage('"E02BDF - Evaluation of fitted cubic spline, definite integral",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Knots \space{1}") + (text . "\htbitmap{lamdai}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Coefficients \space{1} \htbitmap{ci}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.0" l1 F)) + (text . "\tab{22} ") + (bcStrings (10 "10.00" c1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l2 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.00" c2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l3 F)) + (text . "\tab{22} ") + (bcStrings (10 "13.00" c3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00" l4 F)) + (text . "\tab{22} ") + (bcStrings (10 "15.00" c4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" l5 F)) + (text . "\tab{22} ") + (bcStrings (10 "22.00" c5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l6 F)) + (text . "\tab{22} ") + (bcStrings (10 "26.00" c6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l7 F)) + (text . "\tab{22} ") + (bcStrings (10 "24.00" c7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" l8 F)) + (text . "\tab{22} ") + (bcStrings (10 "18.00" c8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" l9 F)) + (text . "\tab{22} ") + (bcStrings (10 "14.00" c9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" l10 F)) + (text . "\tab{22} ") + (bcStrings (10 "12.00" c10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l11 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l12 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l13 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" l14 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.00" c14 F))) + htpSetProperty(page,'ncap,ncap) + htpSetProperty(page,'ifail,ifail) + htMakeDoneButton('"Continue",'e02bdfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02bdfGen htPage == + ncap := htpProperty(htPage,'ncap) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + ncap7 := ncap + 7 + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + lamlist := [left,:lamlist] + clist := [right,:clist] + lamstring := bcwords2liststring lamlist + cstring := bcwords2liststring clist + prefix := STRCONC('"e02bdf(",STRINGIMAGE ncap7,", [",lamstring,"],[") + prefix := STRCONC(prefix,cstring,"], ",STRINGIMAGE ifail,")") + linkGen prefix + + + +e02bef() == + htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02bef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02bef| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Determines a cubic spline approximation to the set of points ") + (text . "{\it ( \htbitmap{xr},\htbitmap{yr}) } ") + (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") + (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,n, ") + (text . "are chosen by the routine, but a single parameter S must be ") + (text . "specified to control the trade-off between closeness of fit and ") + (text . "smoothness of fit. This affects the number of knots required ") + (text . "by the spline, which is given in the B-spline representation ") + (text . "\center{\htbitmap{e02bef}}, where n-1 is the number of") + (text . " intervals of the spline. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 15 m PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Smoothing factor {\it s}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "1.0" s F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of number n of knots {\it nest}:\newline\tab{2} ") + (bcStrings (6 54 nest PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Start value: ") + (radioButtons start + ("" " Cold Start - no values needed for {\it n,lamda,wrk} or {\it iwrk}" cold) + ("" " Warm Start - uses knots found in a previous call" warm)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02befSolve) + htShowPage() + +e02befSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + nest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nest) + objValUnwrap htpLabelSpadValue(htPage, 'nest) + lwrk := 4*m +16*nest + 41 + s := htpLabelInputString(htPage,'s) + initial := htpButtonValue(htPage,'start) + start := + initial = 'cold => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = 15 and start = 1) => e02befDefaultSolve (htPage,nest,lwrk,s,ifail) + start = 1 => e02befColdSolve (htPage,m,nest,lwrk,s,ifail) + -- warm start not really possible from hyperdoc + -- as inputing a workspace array of dimension 1105 is asking too much + -- user should use the command line, using the previous calculated + -- parameters + htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\blankline ") + (text . "{\center{\it Hyperdoc interface not available for warm starts.}}") + (text . "\newline ") + (text . "{\center{\it Please use the command line.}}")) + htMakeDoneButton('"Continue",'e02bef) + htShowPage() + + + +e02befColdSolve(htPage,m,nest,lwrk,s,ifail) == + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + post := ('" \tab{42} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + num := INTERN STRCONC (STRINGIMAGE (QUOTIENT(i,10)),".",STRINGIMAGE (REM(i,10))) + [['text,:prefix],['bcStrings,[10, num, xnam, 'F]], + ['text,:middle],['bcStrings,[10, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[10, 0.0, znam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{40}" + htSay '"\menuitemstyle{}\tab{42} Values of \space{1} " + htSay '"\htbitmap{wr}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02befColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nest,nest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02befDefaultSolve (htPage,nest,lwrk,s,ifail) == + m := 15 + page := htInitPage('"E02BEF - Least-squares curve cubic spline fit, automatic knot placement",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \space{1} ") + (text . "\htbitmap{xr}: \tab{20} \menuitemstyle{}\tab{22} ") + (text . "Values of \space{1} \htbitmap{yr}: \tab{40} ") + (text . "\menuitemstyle{}\tab{42} Values of \space{1} ") + (text . "\htbitmap{wr}: ") + (text . "\newline \tab{2}") + (bcStrings (10 "0.00" x1 F)) + (text . "\tab{22} ") + (bcStrings (10 "-1.1" y1 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "0.50" x2 F)) + (text . "\tab{22} ") + (bcStrings (10 "-0.372" y2 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.00" z2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.00" x3 F)) + (text . "\tab{22} ") + (bcStrings (10 "0.431" y3 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.50" z3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "1.50" x4 F)) + (text . "\tab{22} ") + (bcStrings (10 "1.69" y4 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.00" x5 F)) + (text . "\tab{22} ") + (bcStrings (10 "2.11" y5 F)) + (text . "\tab{42} ") + (bcStrings (10 "3.00" z5 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "2.50" x6 F)) + (text . "\tab{22} ") + (bcStrings (10 "3.10" y6 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z6 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "3.00" x7 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.23" y7 F)) + (text . "\tab{42} ") + (bcStrings (10 "0.50" z7 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.00" x8 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.35" y8 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z8 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "4.50" x9 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.81" y9 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.00" z9 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.00" x10 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.61" y10 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.50" z10 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "5.50" x11 F)) + (text . "\tab{22} ") + (bcStrings (10 "4.79" y11 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z11 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "6.00" x12 F)) + (text . "\tab{22} ") + (bcStrings (10 "5.23" y12 F)) + (text . "\tab{42} ") + (bcStrings (10 "3.00" z12 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.00" x13 F)) + (text . "\tab{22} ") + (bcStrings (10 "6.35" y13 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z13 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "7.50" x14 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.19" y14 F)) + (text . "\tab{42} ") + (bcStrings (10 "2.00" z14 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "8.00" x15 F)) + (text . "\tab{22} ") + (bcStrings (10 "7.97" y15 F)) + (text . "\tab{42} ") + (bcStrings (10 "1.00" z15 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02befColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nest,nest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02befColdGen htPage == + m := htpProperty(htPage,'m) + nest := htpProperty(htPage,'nest) + lwrk := htpProperty(htPage,'lwrk) + s := htpProperty(htPage,'s) + cold := '"c" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + wlist := [right,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + wstring := bcwords2liststring wlist + -- additional entries needed to get it running + -- but as Start = c they are not used + -- mmax := 50 + -- nest := mmax + 4 (54) + -- lwrk := 4*mmax + 16*nest+41 (1105) + prefix := STRCONC('"e02bef(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") + prefix := STRCONC(prefix,ystring,"],[",wstring,"], ",STRINGIMAGE s,", ") + prefix := STRCONC(prefix,STRINGIMAGE nest,", ",STRINGIMAGE lwrk) +-- prefix := STRCONC(prefix,",0, [[0.0 for i in 1..",STRINGIMAGE nest,"]],") +-- prefix := STRCONC(prefix,STRINGIMAGE ifail,", [[0.0 for i in 1..") +-- prefix := STRCONC(prefix,STRINGIMAGE lwrk,"]], [[0 for i in 1..") +-- prefix := STRCONC(prefix,STRINGIMAGE nest,"]] :: Matrix Integer)") + prefix := STRCONC(prefix,",0, new(1,",STRINGIMAGE nest,",0.0)$Matrix DoubleFloat,") + prefix := STRCONC(prefix,STRINGIMAGE ifail,", new(1,",STRINGIMAGE lwrk,",0.0)$Matrix DoubleFloat, ") + prefix := STRCONC(prefix," new(1,",STRINGIMAGE nest,",0)$Matrix Integer)") + linkGen prefix + +e02def() == + htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02def} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02def| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates a bicubic spline at the (\htbitmap{xr},") + (text . "\htbitmap{yr}), for r = 1,2,...,m, from its B-spline ") + (text . "representation \htbitmap{e02daf} ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of evaluation points, {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 m PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of (interior & exterior) knots ") + (text . "\lambda, \htbitmap{px} \htbitmap{great=} 8: \newline\tab{2} ") + (bcStrings (6 11 px PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of (interior & exterior) knots ") + (text . "\mu, \htbitmap{py} \htbitmap{great=} 8: \newline\tab{2} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02defSolve) + htShowPage() + +e02defSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '7 and px = '11) and py = '10) => e02defDefaultSolve(htPage,ifail) + labelList := + "append"/[fxy(i) for i in 1..m] where fxy(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{22} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]]] + lamList := + "append"/[flam(i) for i in 1..px] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(nxest)}: \newline") + lamList := [['text,:prefix],:lamList] + muList := + "append"/[fmu(i) for i in 1..(py)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(nyest)}:") + prefix := STRCONC(prefix,"\newline ") + muList := [['text,:prefix],:muList] + cList := + "append"/[fp(i) for i in 1..((px-4)*(py-4))] where fp(i) == + pnam := INTERN STRCONC ('"p",STRINGIMAGE i) + [['bcStrings,[8, 0.0, pnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2}Enter values of ") + prefix := STRCONC(prefix,"{\it c((nxest*4)-(nyest*4))}: \newline ") + cList := [['text,:prefix],:cList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamList,:muList,:cList] + page := htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " + htSay '"\tab{20} \menuitemstyle{}\tab{22} Values of \htbitmap{yr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02defGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02defDefaultSolve (htPage,ifail) == + m := '7 + px := '11 + py := '10 + page := htInitPage('"E02DEF - Evaluation of a fitted bicubic spline at a vector of points",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") + (text . "\tab{20} \menuitemstyle{} \tab{22} Values of ") + (text . "\htbitmap{yr}: ") + (text . "\newline \tab{2} ") + (bcStrings (8 "1" x1 F)) + (text . "\tab{22}") + (bcStrings (8 "0" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.1" x2 F)) + (text . "\tab{22}") + (bcStrings (8 "0.1" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.5" x3 F)) + (text . "\tab{22}") + (bcStrings (8 "0.7" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.6" x4 F)) + (text . "\tab{22}") + (bcStrings (8 "0.4" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.9" x5 F)) + (text . "\tab{22}") + (bcStrings (8 "0.3" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.9" x6 F)) + (text . "\tab{22}") + (bcStrings (8 "0.8" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "2" x7 F)) + (text . "\tab{22}") + (bcStrings (8 "1" y7 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \lambda(nxest)}:") + (text . "\newline ") + (bcStrings (8 "1.0" l1 F)) + (bcStrings (8 "1.0" l2 F)) + (bcStrings (8 "1.0" l3 F)) + (bcStrings (8 "1.0" l4 F)) + (bcStrings (8 "1.3" l5 F)) + (bcStrings (8 "1.5" l6 F)) + (bcStrings (8 "1.6" l7 F)) + (bcStrings (8 "2" l8 F)) + (bcStrings (8 "2" l9 F)) + (bcStrings (8 "2" l10 F)) + (bcStrings (8 "2" l11 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \mu(nyest)}:") + (text . "\newline ") + (bcStrings (8 "0" mu1 F)) + (bcStrings (8 "0" mu2 F)) + (bcStrings (8 "0" mu3 F)) + (bcStrings (8 "0" mu4 F)) + (bcStrings (8 "0.4" mu5 F)) + (bcStrings (8 "0.7" mu6 F)) + (bcStrings (8 "1" mu7 F)) + (bcStrings (8 "1" mu8 F)) + (bcStrings (8 "1" mu9 F)) + (bcStrings (8 "1" mu10 F)) + (text . "\blankline \menuitemstyle{}\tab{2} ") + (text . "Enter values for {\it c((nxest-4)*(nyest-4))}:") + (text . "\newline ") + (bcStrings (8 "1" c1 F)) + (bcStrings (8 "1.1333" c2 F)) + (bcStrings (8 "1.3667" c3 F)) + (bcStrings (8 "1.7" c4 F)) + (bcStrings (8 "1.9" c5 F)) + (bcStrings (8 "2" c6 F)) + (bcStrings (8 "1.2" c7 F)) + (bcStrings (8 "1.3333" c8 F)) + (bcStrings (8 "1.5667" c9 F)) + (bcStrings (8 "1.9" c10 F)) + (bcStrings (8 "2.1" c11 F)) + (bcStrings (8 "2.2" c12 F)) + (bcStrings (8 "1.5833" c13 F)) + (bcStrings (8 "1.7167" c14 F)) + (bcStrings (8 "1.95" c15 F)) + (bcStrings (8 "2.2833" c16 F)) + (bcStrings (8 "2.4833" c17 F)) + (bcStrings (8 "2.5833" c18 F)) + (bcStrings (8 "2.1433" c19 F)) + (bcStrings (8 "2.2767" c20 F)) + (bcStrings (8 "2.51" c21 F)) + (bcStrings (8 "2.8433" c22 F)) + (bcStrings (8 "3.0433" c23 F)) + (bcStrings (8 "3.1433" c24 F)) + (bcStrings (8 "2.8667" c25 F)) + (bcStrings (8 "3" c26 F)) + (bcStrings (8 "3.2333" c27 F)) + (bcStrings (8 "3.5667" c28 F)) + (bcStrings (8 "3.7667" c29 F)) + (bcStrings (8 "3.8667" c30 F)) + (bcStrings (8 "3.4667" c31 F)) + (bcStrings (8 "3.6" c32 F)) + (bcStrings (8 "3.8333" c33 F)) + (bcStrings (8 "4.1667" c34 F)) + (bcStrings (8 "4.3667" c35 F)) + (bcStrings (8 "4.4667" c36 F)) + (bcStrings (8 "4" c37 F)) + (bcStrings (8 "4.1333" c38 F)) + (bcStrings (8 "4.3667" c39 F)) + (bcStrings (8 "4.7" c40 F)) + (bcStrings (8 "4.9" c41 F)) + (bcStrings (8 "5" c42 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'e02defGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02defGen htPage == + m := htpProperty(htPage,'m) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + -- c + for i in 1..((px-4)*(py-4)) repeat + right := STRCONC ((first y).1," ") + y := rest y + cList := [right,:cList] + cstring := bcwords2liststring cList + -- mu + for i in 1..py repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..px repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + lamstring := bcwords2liststring lamList + -- x & y + while y repeat + one := STRCONC((first y).1," ") + y := rest y + two := STRCONC((first y).1," ") + y := rest y + xlist := [two,:xlist] + ylist := [one,:ylist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + prefix := STRCONC('"e02def(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") + prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") + prefix := STRCONC(prefix,lamstring,"],[",mustring,"],[",cstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + + +e02dff() == + htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02dff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dff| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Evaluates a bicubic spline at all the points on a rectangular ") + (text . "grid defined by \htbitmap{mx} points ") + (text . "\htbitmap{xq}on the x-axis and \htbitmap{my}") + (text . "points \htbitmap{yr} on the y-axis, from its B-spline ") + (text . "representation \center{\htbitmap{e02daf}} \newline with knot sets ") + (text . "\{\lambda\} and \{\mu\}. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Grid points on x-axis \htbitmap{mx}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Grid points on y-axis \htbitmap{my}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 mx PI)) + (text . "\tab{34} ") + (bcStrings (6 6 my PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Number of (interior & exterior) knots \lambda, ") + (text . "\htbitmap{px} \htbitmap{great=} 8: \newline\tab{2} ") + (bcStrings (6 11 px PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Number of (interior & exterior) knots \mu, ") + (text . "\htbitmap{py} \htbitmap{great=} 8: \newline\tab{2} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02dffSolve) + htShowPage() + +e02dffSolve htPage == + mx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) + objValUnwrap htpLabelSpadValue(htPage, 'mx) + my := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) + objValUnwrap htpLabelSpadValue(htPage, 'my) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + nwrk1 := 4*mx + px + nwrk2 := 4*my + py + nwrklist := [nwrk1,nwrk2] + nwrkmin := APPLY ('MIN, nwrklist) + lwrk := nwrkmin + liwrk := + nwrkmin = nwrk2 => my + py -4 + mx + px -4 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((mx = '7 and my = '6) and (px = '11 and py = '10)) => + e02dffDefaultSolve(htPage,lwrk,liwrk,ifail) + xList := + "append"/[fx(i) for i in 1..mx] where fx(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, 0.0, xnam, 'F]]] + yList := + "append"/[fy(i) for i in 1..my] where fy(i) == + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['bcStrings,[8, 0.0, ynam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of ") + prefix := STRCONC(prefix,"\htbitmap{yr} : \newline") + yList := [['text,:prefix],:yList] + lamList := + "append"/[flam(i) for i in 1..px] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it \lambda(nxest)}:\newline") + lamList := [['text,:prefix],:lamList] + muList := + "append"/[fmu(i) for i in 1..(py)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it mu(nyest)}:") + prefix := STRCONC(prefix,"\newline ") + muList := [['text,:prefix],:muList] + cList := + "append"/[fp(i) for i in 1..((px-4)*(py-4))] where fp(i) == + pnam := INTERN STRCONC ('"p",STRINGIMAGE i) + [['bcStrings,[8, 0.0, pnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} Enter values of ") + prefix := STRCONC(prefix,"{\it c((px-4)*(py-4))}: \newline") + cList := [['text,:prefix],:cList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :xList,:yList,:lamList,:muList,:cList] + page := htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:\newline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02dffGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02dffDefaultSolve (htPage,lwrk,liwrk,ifail) == + mx := '7 + my := '6 + px := '11 + py := '10 + page := htInitPage('"E02DFF - Evaluation of a fitted bicubic spline at a mesh of points",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \htbitmap{xr}:") + (text . "\newline ") + (bcStrings (8 "1" x1 F)) + (bcStrings (8 "1.1" x2 F)) + (bcStrings (8 "1.3" x3 F)) + (bcStrings (8 "1.4" x4 F)) + (bcStrings (8 "1.5" x5 F)) + (bcStrings (8 "1.7" x6 F)) + (bcStrings (8 "2" x7 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \htbitmap{yr}:") + (text . "\newline ") + (bcStrings (8 "0" y1 F)) + (bcStrings (8 "0.2" y2 F)) + (bcStrings (8 "0.4" y3 F)) + (bcStrings (8 "0.6" y4 F)) + (bcStrings (8 "0.8" y5 F)) + (bcStrings (8 "1" y6 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it \lambda(nxest)}:") + (text . "\newline ") + (bcStrings (8 "1" l1 F)) + (bcStrings (8 "1" l2 F)) + (bcStrings (8 "1" l3 F)) + (bcStrings (8 "1" l4 F)) + (bcStrings (8 "1.3" l5 F)) + (bcStrings (8 "1.5" l6 F)) + (bcStrings (8 "1.6" l7 F)) + (bcStrings (8 "2" l8 F)) + (bcStrings (8 "2" l9 F)) + (bcStrings (8 "2" l10 F)) + (bcStrings (8 "2" l11 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it \mu(nyest)}:") + (text . "\newline ") + (bcStrings (8 "0" mu1 F)) + (bcStrings (8 "0" mu2 F)) + (bcStrings (8 "0" mu3 F)) + (bcStrings (8 "0" mu4 F)) + (bcStrings (8 "0.4" mu5 F)) + (bcStrings (8 "0.7" mu6 F)) + (bcStrings (8 "1" mu7 F)) + (bcStrings (8 "1" mu8 F)) + (bcStrings (8 "1" mu9 F)) + (bcStrings (8 "1" mu10 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it c((px-4)*(py-4))}:") + (text . "\newline ") + (bcStrings (8 "1" c1 F)) + (bcStrings (8 "1.1333" c2 F)) + (bcStrings (8 "1.3667" c3 F)) + (bcStrings (8 "1.7" c4 F)) + (bcStrings (8 "1.9" c5 F)) + (bcStrings (8 "2" c6 F)) + (bcStrings (8 "1.2" c7 F)) + (bcStrings (8 "1.3333" c8 F)) + (bcStrings (8 "1.5667" c9 F)) + (bcStrings (8 "1.9" c10 F)) + (bcStrings (8 "2.1" c11 F)) + (bcStrings (8 "2.2" c12 F)) + (bcStrings (8 "1.5833" c13 F)) + (bcStrings (8 "1.7167" c14 F)) + (bcStrings (8 "1.95" c15 F)) + (bcStrings (8 "2.2833" c16 F)) + (bcStrings (8 "2.4833" c17 F)) + (bcStrings (8 "2.5833" c18 F)) + (bcStrings (8 "2.1433" c19 F)) + (bcStrings (8 "2.2767" c20 F)) + (bcStrings (8 "2.51" c21 F)) + (bcStrings (8 "2.8433" c22 F)) + (bcStrings (8 "3.0433" c23 F)) + (bcStrings (8 "3.1433" c24 F)) + (bcStrings (8 "2.8667" c25 F)) + (bcStrings (8 "3" c26 F)) + (bcStrings (8 "3.2333" c27 F)) + (bcStrings (8 "3.5667" c28 F)) + (bcStrings (8 "3.7667" c29 F)) + (bcStrings (8 "3.8667" c30 F)) + (bcStrings (8 "3.4667" c31 F)) + (bcStrings (8 "3.6" c32 F)) + (bcStrings (8 "3.8333" c33 F)) + (bcStrings (8 "4.1667" c34 F)) + (bcStrings (8 "4.3667" c35 F)) + (bcStrings (8 "4.4667" c36 F)) + (bcStrings (8 "4" c37 F)) + (bcStrings (8 "4.1333" c38 F)) + (bcStrings (8 "4.3667" c39 F)) + (bcStrings (8 "4.7" c40 F)) + (bcStrings (8 "4.9" c41 F)) + (bcStrings (8 "5" c42 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02dffGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02dffGen htPage == + mx := htpProperty(htPage,'mx) + my := htpProperty(htPage,'my) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + -- c + for i in 1..((px-4)*(py-4)) repeat + right := STRCONC ((first y).1," ") + y := rest y + cList := [right,:cList] + cstring := bcwords2liststring cList + -- mu + for i in 1..py repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..px repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + lamstring := bcwords2liststring lamList + -- y + for i in 1..my repeat + right := STRCONC ((first y).1," ") + y := rest y + yList := [right,:yList] + ystring := bcwords2liststring yList + -- x + for i in 1..mx repeat + right := STRCONC ((first y).1," ") + y := rest y + xList := [right,:xList] + xstring := bcwords2liststring xList + prefix := STRCONC('"e02dff(",STRINGIMAGE mx,", ",STRINGIMAGE my,", ") + prefix := STRCONC(prefix,STRINGIMAGE px,", ",STRINGIMAGE py,",[") + prefix := STRCONC(prefix,xstring,"],[",ystring,"],[",lamstring,"],[") + prefix := STRCONC(prefix,mustring,"],[",cstring,"],",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",STRINGIMAGE ifail,")") + linkGen prefix + +e02gaf() == + htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02gaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02gaf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Calculates an \htbitmap{l1} solution to the over determined system") + (text . " of linear equations {\it Ax = b}, where A is an {\it m} by {\it n") + (text . "} matrix, {\it x} is an {\it n} element vector, and {\it b} is an ") + (text . "{\it m} element vector. The matrix {\it A} need not be of full ") + (text . "rank. \blankline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "Number of rows of {\it A}, {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "Number of columns of {\it A}, {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2} \newline ") +-- (text . "First dimension of {\it A(la,n+2)}, {\it la}\htbitmap{great=}") +-- (text . " {\it m + 2}: \newline\tab{2} ") +-- (bcStrings (6 7 la PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} \newline ") + (text . "Tolerance (default is zero), {\it toler}: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.0" toler F)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02gafSolve) + htShowPage() + +e02gafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + la := m+2 +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'la) +-- objValUnwrap htpLabelSpadValue(htPage, 'la) + toler := htpLabelInputString(htPage,'toler) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = 5 and n = 3) and la = 7) => e02gafDefaultSolve (htPage,toler,ifail) + labelList := + "append"/[fc(i,n) for i in 1..la] where fc(i,n) == + tempList := + "append"/[fr(i,j) for j in 1..(n+2)] where fr(i,j) == + fnam := INTERN STRCONC ('"f",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[9, 0.0, fnam, 'F]]] + prefix := ('"\newline ") + tempList := [['text,:prefix],:tempList] + bList := + "append"/[fb(i) for i in 1..m] where fb(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[9, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of {\it B(m)}: \newline") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:bList] + page := htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) + htSay '"\menuitemstyle{}\tab{2} Values of {\it A(la,n+2)}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02gafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'n,n) + htpSetProperty(page,'la,la) + htpSetProperty(page,'toler,toler) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02gafDefaultSolve (htPage,toler,ifail) == + m := '5 + n := '3 + la := '7 + page := htInitPage('"E02GAF - \htbitmap{l1}-approximation by general linear function",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it A(la,n+2)}:") + (text . "\newline ") + (bcStrings (9 "1.0" a11 F)) + (bcStrings (9 "1.0" a12 F)) + (bcStrings (9 "1.0" a13 F)) + (bcStrings (9 "0.0" a14 F)) + (bcStrings (9 "0.0" a15 F)) + (text . "\newline ") + (bcStrings (9 "exp(0.2)" a21 F)) + (bcStrings (9 "exp(-0.2)" a22 F)) + (bcStrings (9 "1.0" a23 F)) + (bcStrings (9 "0.0" a24 F)) + (bcStrings (9 "0.0" a25 F)) + (text . "\newline ") + (bcStrings (9 "exp(0.4)" a31 F)) + (bcStrings (9 "exp(-0.4)" a32 F)) + (bcStrings (9 "1.0" a33 F)) + (bcStrings (9 "0.0" a34 F)) + (bcStrings (9 "0.0" a35 F)) + (text . "\newline ") + (bcStrings (9 "exp(0.6)" a41 F)) + (bcStrings (9 "exp(-0.6)" a42 F)) + (bcStrings (9 "1.0" a43 F)) + (bcStrings (9 "0.0" a44 F)) + (bcStrings (9 "0.0" a45 F)) + (text . "\newline ") + (bcStrings (9 "exp(0.8)" a51 F)) + (bcStrings (9 "exp(-0.8)" a52 F)) + (bcStrings (9 "1.0" a53 F)) + (bcStrings (9 "0.0" a54 F)) + (bcStrings (9 "0.0" a55 F)) + (text . "\newline ") + (bcStrings (9 "0.0" a61 F)) + (bcStrings (9 "0.0" a62 F)) + (bcStrings (9 "0.0" a63 F)) + (bcStrings (9 "0.0" a64 F)) + (bcStrings (9 "0.0" a65 F)) + (text . "\newline ") + (bcStrings (9 "0.0" a71 F)) + (bcStrings (9 "0.0" a72 F)) + (bcStrings (9 "0.0" a73 F)) + (bcStrings (9 "0.0" a74 F)) + (bcStrings (9 "0.0" a75 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it B(m)}:") + (text . "\newline ") + (bcStrings (9 "4.501" b1 F)) + (bcStrings (9 "4.36" b2 F)) + (bcStrings (9 "4.333" b3 F)) + (bcStrings (9 "4.418" b4 F)) + (bcStrings (9 "4.625" b5 F))) + htMakeDoneButton('"Continue",'e02gafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'n,n) + htpSetProperty(page,'toler,toler) + htpSetProperty(page,'la,la) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02gafGen htPage == + m := htpProperty(htPage,'m) + n := htpProperty(htPage,'n) + la := htpProperty(htPage,'la) + toler := htpProperty(htPage,'toler) + ifail := htpProperty(htPage,'ifail) + nplustwo := n + 2 + alist := htpInputAreaAlist htPage + y := alist + for i in 1..m repeat + right := STRCONC ((first y).1," ") + y := rest y + blist := [right,:blist] + bstring := bcwords2liststring blist + y := REVERSE y + k := -1 + matform := [[y.(k := k + 1).1 for j in 0..(nplustwo-1)] for i in 0..(la-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"e02gaf(",STRINGIMAGE m,", ",STRINGIMAGE la,", ") + prefix := STRCONC(prefix,STRINGIMAGE nplustwo,", ",STRINGIMAGE toler,", ") + prefix := STRCONC(prefix,matstring,",[",bstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + + +e02daf() == + htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02daf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02daf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a minimal, least squares bicubic B-spline surface fit") + (text . "\htbitmap{e02daf} to the set of points ") + (text . "{\em (\htbitmap{xr},\htbitmap{yr},\htbitmap{fr})} with weights ") + (text . "\htbitmap{wr}, for r = 1,2,...,m. The user must supply internal ") + (text . "knot sets {\lambda},in the x-direction and {\mu} in the ") + (text . "y-direction, ") + (text . "which can be thought of as dividing the data region into panels;") + (text . "s(x,y) consists of a seperate bicubic polynomial in each panel, ") + (text . "the polynomial joining together with second derivative ") + (text . "continuity. Eight additional (external) knots are added to each ") + (text . "of the knot sets by this routine. The routine minimizes \Sigma, ") + (text . "the sum of squares of the weighted residuals ") + (text . "\htbitmap{e02daf1}, for r = 1,2,...,m, subject to the ") + (text . "given knot sets. \newline ") + (text . "A call of this routine should be preceded by a call of E02ZAF ") + (text . "to provide indexing information. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Knots in x direction {\em px}") + (text . "\htbitmap{great=} 8: \tab{32} \menuitemstyle{}\tab{34}") + (text . "Knots in y direction {\em py}:") + (text . "\newline\tab{2} ") + (bcStrings (6 8 px PI)) + (text . "\tab{34} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Rank threshold {\em eps}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.000001" eps F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Dimension of point {\it npoint}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 43 npoint PI)) + -- include a radio button later to allow switching of + -- x & y if px <= py + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02dafSolve) + htShowPage() + +e02dafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + npoint := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) + objValUnwrap htpLabelSpadValue(htPage, 'npoint) + nc := (px - 4)*(py - 4) + nws := (2*nc + 1)*(3*py - 6) -2 + eps := htpLabelInputString(htPage,'eps) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '30 and px = '8) and py = '10) => e02dafDefaultSolve(htPage,eps,nws,npoint,ifail) + labelList := + "append"/[fxy(i) for i in 1..m] where fxy(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + next := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:next],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + lamList := + "append"/[flam(i) for i in 5..(px-4)] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} lamda(5) to lamda(px-4): ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + postfix := ('"\newline \blankline ") + lamList := [['text,:prefix],:lamList,['text,:postfix]] + muList := + "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\menuitemstyle{} \tab{2} mu(5) to mu(py-4):") + prefix := STRCONC(prefix,"\newline \tab{2} ") + muList := [['text,:prefix],:muList] + pList := + "append"/[fp(i) for i in 1..npoint] where fp(i) == + prefix := ('"\newline \tab{2} ") + pnam := INTERN STRCONC ('"p",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, pnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of Point: ") + pList := [['text,:prefix],:pList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamList,:muList,:pList] + page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " + htSay '"\tab{15} \menuitemstyle{}\tab{17} Values of \htbitmap{yr}:" + htSay '"\tab{30} \menuitemstyle{}\tab{32} Values of \htbitmap{fr}:" + htSay '"\tab{44} \menuitemstyle{}\tab{46} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02dafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'nws,nws) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02dafDefaultSolve (htPage,eps,nws,npoint,ifail) == + m := '30 + px := '8 + py := '10 + page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") + (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") + (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") + (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") + (text . "\tab{46} Values of \htbitmap{wr}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.52" x1 F)) + (text . "\tab{17}") + (bcStrings (8 "0.60" y1 F)) + (text . "\tab{32}") + (bcStrings (8 "0.93" f1 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.61" x2 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.95" y2 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.79" f2 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.93" x3 F)) + (text . "\tab{17}") + (bcStrings (8 "0.87" y3 F)) + (text . "\tab{32}") + (bcStrings (8 "0.36" f3 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.09" x4 F)) + (text . "\tab{17}") + (bcStrings (8 "0.84" y4 F)) + (text . "\tab{32}") + (bcStrings (8 "0.52" f4 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.88" x5 F)) + (text . "\tab{17}") + (bcStrings (8 "0.17" y5 F)) + (text . "\tab{32}") + (bcStrings (8 "0.49" f5 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.70" x6 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.87" y6 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.76" f6 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1" x7 F)) + (text . "\tab{17}") + (bcStrings (8 "1" y7 F)) + (text . "\tab{32}") + (bcStrings (8 "0.33" f7 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1" x8 F)) + (text . "\tab{17}") + (bcStrings (8 "0.1" y8 F)) + (text . "\tab{32}") + (bcStrings (8 "0.48" f8 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.3" x9 F)) + (text . "\tab{17}") + (bcStrings (8 "0.24" y9 F)) + (text . "\tab{32}") + (bcStrings (8 "0.65" f9 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.77" x10 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.77" y10 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.82" f10 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w10 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.23" x11 F)) + (text . "\tab{17}") + (bcStrings (8 "0.32" y11 F)) + (text . "\tab{32}") + (bcStrings (8 "0.92" f11 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w11 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-1" x12 F)) + (text . "\tab{17}") + (bcStrings (8 "1" y12 F)) + (text . "\tab{32}") + (bcStrings (8 "1" f12 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w12 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.26" x13 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.63" y13 F)) + (text . "\tab{32}") + (bcStrings (8 "8.88" f13 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w13 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.83" x14 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.66" y14 F)) + (text . "\tab{32}") + (bcStrings (8 "-2.01" f14 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w14 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.22" x15 F)) + (text . "\tab{17}") + (bcStrings (8 "0.93" y15 F)) + (text . "\tab{32}") + (bcStrings (8 "0.47" f15 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w15 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.89" x16 F)) + (text . "\tab{17}") + (bcStrings (8 "0.15" y16 F)) + (text . "\tab{32}") + (bcStrings (8 "0.49" f16 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w16 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.80" x17 F)) + (text . "\tab{17}") + (bcStrings (8 "0.99" y17 F)) + (text . "\tab{32}") + (bcStrings (8 "0.84" f17 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w17 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.88" x18 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.54" y18 F)) + (text . "\tab{32}") + (bcStrings (8 "-2.42" f18 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w18 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.68" x19 F)) + (text . "\tab{17}") + (bcStrings (8 "0.44" y19 F)) + (text . "\tab{32}") + (bcStrings (8 "0.47" f19 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w19 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.14" x20 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.72" y20 F)) + (text . "\tab{32}") + (bcStrings (8 "7.15" f20 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w20 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.67" x21 F)) + (text . "\tab{17}") + (bcStrings (8 "0.63" y21 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" f21 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w21 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.90" x22 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.40" y22 F)) + (text . "\tab{32}") + (bcStrings (8 "-3.34" f22 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w22 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.84" x23 F)) + (text . "\tab{17}") + (bcStrings (8 "0.20" y23 F)) + (text . "\tab{32}") + (bcStrings (8 "2.78" f23 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w23 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.84" x24 F)) + (text . "\tab{17}") + (bcStrings (8 "0.43" y24 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" f24 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w24 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.15" x25 F)) + (text . "\tab{17}") + (bcStrings (8 "0.28" y25 F)) + (text . "\tab{32}") + (bcStrings (8 "0.70" f25 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w25 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.91" x26 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.24" y26 F)) + (text . "\tab{32}") + (bcStrings (8 "-6.52" f26 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w26 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.35" x27 F)) + (text . "\tab{17}") + (bcStrings (8 "0.86" y27 F)) + (text . "\tab{32}") + (bcStrings (8 "0.66" f27 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w27 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.16" x28 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.41" y28 F)) + (text . "\tab{32}") + (bcStrings (8 "2.32" f28 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w28 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.35" x29 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.05" y29 F)) + (text . "\tab{32}") + (bcStrings (8 "1.66" f29 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w29 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-1" x30 F)) + (text . "\tab{17}") + (bcStrings (8 "-1" y30 F)) + (text . "\tab{32}") + (bcStrings (8 "-1" f30 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w30 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} mu(5) to mu(py-4):") + (text . "\newline \tab{2}") + (bcStrings (8 "-0.50" mu5 F)) + (bcStrings (8 "0.00" mu6 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values for point:") + (text . "\newline \tab{2}") + (bcStrings (6 3 p1 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 6 p2 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 4 p3 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 5 p4 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 7 p5 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 10 p6 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 8 p7 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 9 p8 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 11 p9 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 13 p10 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 12 p11 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 15 p12 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 14 p13 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 18 p14 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 16 p15 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 17 p16 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 19 p17 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 20 p18 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 21 p19 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 30 p20 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 23 p21 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 26 p22 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 24 p23 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 25 p24 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 27 p25 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 28 p26 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p27 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 29 p28 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p29 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p30 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 2 p31 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 22 p32 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 1 p33 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p34 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p35 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p36 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p37 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p38 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p39 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p40 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p41 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p42 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p43 PI)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02dafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'nws,nws) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02dafGen htPage == + m := htpProperty(htPage,'m) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + nws := htpProperty(htPage,'nws) + eps := htpProperty(htPage,'eps) + npoint := htpProperty(htPage,'npoint) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + nadres := (px-7)*(py-7) + -- point + for i in 1..npoint repeat + right := STRCONC ((first y).1," ") + y := rest y + pointList := [right,:pointList] + pstring := bcwords2liststring pointList + -- mu + for i in 1..4 repeat + muList := ['"0 ",:muList] + for i in 5..(py-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + for i in (py-3)..py repeat + muList := ['"0 ",:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..4 repeat + lamList := ['"0 ",:lamList] + for i in 5..(px-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + for i in (px-3)..px repeat + lamList := ['"0 ",:lamList] + lamstring := bcwords2liststring lamList + -- x & y + while y repeat + one := STRCONC((first y).1," ") + y := rest y + two := STRCONC((first y).1," ") + y := rest y + three := STRCONC ((first y).1," ") + y := rest y + four := STRCONC ((first y).1," ") + y := rest y + xlist := [four,:xlist] + ylist := [three,:ylist] + flist := [two,:flist] + wlist := [one,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + nc := (px-4)*(py-4) + prefix := STRCONC('"e02daf(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") + prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") + prefix := STRCONC(prefix,fstring,"],[",wstring,"],[",mustring,"],[") + prefix := STRCONC(prefix,pstring,"], ",STRINGIMAGE npoint,", ") + prefix := STRCONC(prefix,STRINGIMAGE nc,", ",STRINGIMAGE nws,", ",eps,", [") + prefix := STRCONC(prefix,lamstring,"], ",STRINGIMAGE ifail,")") + linkGen prefix + + +e02dcf() == + htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02dcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dcf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Determines a bicubic spline approximation to a set of points ") + (text . "given on a rectangular grid defined by \htbitmap{mx} ") + (text . "points \htbitmap{xq} on the x-axis and ") + (text . "\htbitmap{my} points \htbitmap{yr} on the ") + (text . "y-axix. The knots \htbitmap{lamdai}, for i = 1,2,...,") + (text . "\htbitmap{nx} and \htbitmap{mui}, for ") + (text . "i = 1,2,...,\htbitmap{ny} are chosen for this routine ") + (text . ", but a single parameter S must be specified to control the ") + (text . "trade-off between closeness of fit and smoothness of fit. This ") + (text . "affects the number of knots required by the spline, which is ") + (text . "given in the B-spline representation \htbitmap{e02daf}") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Grid points on x-axis \htbitmap{mx}: ") + (text . "\tab{30} \menuitemstyle{}\tab{32} Grid points on y-axis ") + (text . "\htbitmap{my}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 11 mx PI)) + (text . "\tab{32} ") + (bcStrings (6 9 my PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") + (text . "computed spline, {\it nxest}: \newline\tab{2} ") + (bcStrings (6 15 nxest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") + (text . "spline, {\it nyest}: \newline\tab{2} ") + (bcStrings (6 13 nyest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Smoothing factor {\it s}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "0.1" s F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Start value: ") + (radioButtons start + ("" " Cold Start - no values needed for {\it nx,ny,lamda,mu} or {\it iwrk}" cold) + ("" " Warm Start - uses knots found in a previous call" warm)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02dcfSolve) + htShowPage() + +e02dcfSolve htPage == + mx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) + objValUnwrap htpLabelSpadValue(htPage, 'mx) + my := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) + objValUnwrap htpLabelSpadValue(htPage, 'my) + nxest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) + objValUnwrap htpLabelSpadValue(htPage, 'nxest) + nyest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) + objValUnwrap htpLabelSpadValue(htPage, 'nyest) + wrklist := [my,nxest] + wrkmax := APPLY ('MAX, wrklist) + lwrk := 4*(mx + my) +11*(nxest + nyest) + nxest*my + wrkmax +54 + liwrk := 3 + mx + my + nxest + nyest + s := htpLabelInputString(htPage,'s) + initial := htpButtonValue(htPage,'start) + start := + initial = 'cold => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((mx = 11 and my = 9) and start = 1) => + e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) + start = 1 => e02dcfColdSolve (htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) + -- warm start not really possible from hyperdoc + -- as inputing a workspace array of dimension 592 is asking too much + -- user should use the command line, using the previous calculated + -- parameters + htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\blankline ") + (text . "{\center{\em Hyperdoc interface not available for warm starts.}}") + (text . "\newline ") + (text . "{\center{\em Please use the command line.}}")) + htMakeDoneButton('"Continue",'e02dcf) + htShowPage() + + + +e02dcfColdSolve(htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) == + xList := + "append"/[f(i) for i in 1..mx] where f(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, 0.0, xnam, 'F]]] + yList := + "append"/[g(i) for i in 1..my] where g(i) == + ynam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['bcStrings,[8, 0.0, ynam, 'F]]] + prefix:= ('"\blankline \menuitemstyle{}\tab{2} Values of {\it y(my)}: \newline ") + yList := [['text,:prefix],:yList] + fList := + "append"/[h(i) for i in 1..(mx*my)] where h(i) == + fnam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['bcStrings,[8, 0.0, fnam, 'F]]] + prefix:=('"\blankline \menuitemstyle{} \tab{2} Values of {\it f(mx*my)}: \newline ") + fList := [['text,:prefix],:fList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :xList,:yList,:fList] + page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htSay '"\menuitemstyle{}\tab{2} Values of {\it x(mx)}: \newline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02dcfColdGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == + mx := 11 + my := 9 + page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it x(mx)}:") + (text . "\newline ") + (bcStrings (8 "0" x1 F)) + (bcStrings (8 "0.5" x2 F)) + (bcStrings (8 "1" x3 F)) + (bcStrings (8 "1.5" x4 F)) + (bcStrings (8 "2" x5 F)) + (bcStrings (8 "2.5" x6 F)) + (bcStrings (8 "3" x7 F)) + (bcStrings (8 "3.5" x8 F)) + (bcStrings (8 "4" x9 F)) + (bcStrings (8 "4.5" x10 F)) + (bcStrings (8 "5" x11 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it y(my)}:") + (text . "\newline ") + (bcStrings (8 "0" y1 F)) + (bcStrings (8 "0.5" y2 F)) + (bcStrings (8 "1" y3 F)) + (bcStrings (8 "1.5" y4 F)) + (bcStrings (8 "2" y5 F)) + (bcStrings (8 "2.5" y6 F)) + (bcStrings (8 "3" y7 F)) + (bcStrings (8 "3.5" y8 F)) + (bcStrings (8 "4" y9 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it f(mx*my)}:") + (text . "\newline ") + (bcStrings (8 "1" f1 F)) + (bcStrings (8 "0.88758" f2 F)) + (bcStrings (8 "0.5403" f3 F)) + (bcStrings (8 "0.070737" f4 F)) + (bcStrings (8 "-0.41515" f5 F)) + (bcStrings (8 "-0.80114" f6 F)) + (bcStrings (8 "-0.97999" f7 F)) + (bcStrings (8 "-0.93446" f8 F)) + (bcStrings (8 "-0.65664" f9 F)) + (bcStrings (8 "1.5" f10 F)) + (bcStrings (8 "1.3564" f11 F)) + (bcStrings (8 "0.82045" f12 F)) + (bcStrings (8 "0.10611" f13 F)) + (bcStrings (8 "-0.62422" f14 F)) + (bcStrings (8 "-1.2317" f15 F)) + (bcStrings (8 "-1.485" f16 F)) + (bcStrings (8 "-1.3047" f17 F)) + (bcStrings (8 "-0.98547" f18 F)) + (bcStrings (8 "2.06" f19 F)) + (bcStrings (8 "1.7552" f20 F)) + (bcStrings (8 "1.0806" f21 F)) + (bcStrings (8 "0.15147" f22 F)) + (bcStrings (8 "-0.83229" f23 F)) + (bcStrings (8 "-1.6023" f24 F)) + (bcStrings (8 "-1.97" f25 F)) + (bcStrings (8 "-1.8729" f26 F)) + (bcStrings (8 "-1.4073" f27 F)) + (bcStrings (8 "2.57" f28 F)) + (bcStrings (8 "2.124" f29 F)) + (bcStrings (8 "1.3508" f30 F)) + (bcStrings (8 "0.17684" f31 F)) + (bcStrings (8 "-1.0404" f32 F)) + (bcStrings (8 "-2.0029" f33 F)) + (bcStrings (8 "-2.475" f34 F)) + (bcStrings (8 "-2.3511" f35 F)) + (bcStrings (8 "-1.6741" f36 F)) + (bcStrings (8 "3" f37 F)) + (bcStrings (8 "2.6427" f38 F)) + (bcStrings (8 "1.6309" f39 F)) + (bcStrings (8 "0.21221" f40 F)) + (bcStrings (8 "-1.2484" f41 F)) + (bcStrings (8 "-2.2034" f42 F)) + (bcStrings (8 "-2.97" f43 F)) + (bcStrings (8 "-2.8094" f44 F)) + (bcStrings (8 "-1.9809" f45 F)) + (bcStrings (8 "3.5" f46 F)) + (bcStrings (8 "3.1715" f47 F)) + (bcStrings (8 "1.8611" f48 F)) + (bcStrings (8 "0.24458" f49 F)) + (bcStrings (8 "-1.4565" f50 F)) + (bcStrings (8 "-2.864" f51 F)) + (bcStrings (8 "-3.265" f52 F)) + (bcStrings (8 "-3.2776" f53 F)) + (bcStrings (8 "-2.2878" f54 F)) + (bcStrings (8 "4.04" f55 F)) + (bcStrings (8 "3.5103" f56 F)) + (bcStrings (8 "2.0612" f57 F)) + (bcStrings (8 "0.28595" f58 F)) + (bcStrings (8 "-1.6946" f59 F)) + (bcStrings (8 "-3.2046" f60 F)) + (bcStrings (8 "-3.96" f61 F)) + (bcStrings (8 "-3.7958" f62 F)) + (bcStrings (8 "-2.6146" f63 F)) + (bcStrings (8 "4.5" f64 F)) + (bcStrings (8 "3.9391" f65 F)) + (bcStrings (8 "2.4314" f66 F)) + (bcStrings (8 "0.31632" f67 F)) + (bcStrings (8 "-1.8627" f68 F)) + (bcStrings (8 "-3.6351" f69 F)) + (bcStrings (8 "-4.455" f70 F)) + (bcStrings (8 "-4.2141" f71 F)) + (bcStrings (8 "-2.9314" f72 F)) + (bcStrings (8 "5.04" f73 F)) + (bcStrings (8 "4.3879" f74 F)) + (bcStrings (8 "2.7515" f75 F)) + (bcStrings (8 "0.35369" f76 F)) + (bcStrings (8 "-2.0707" f77 F)) + (bcStrings (8 "-4.0057" f78 F)) + (bcStrings (8 "-4.97" f79 F)) + (bcStrings (8 "-4.6823" f80 F)) + (bcStrings (8 "-3.2382" f81 F)) + (bcStrings (8 "5.505" f82 F)) + (bcStrings (8 "4.8367" f83 F)) + (bcStrings (8 "2.9717" f84 F)) + (bcStrings (8 "0.38505" f85 F)) + (bcStrings (8 "-2.2888" f86 F)) + (bcStrings (8 "-4.4033" f87 F)) + (bcStrings (8 "-5.445" f88 F)) + (bcStrings (8 "-5.1405" f89 F)) + (bcStrings (8 "-3.595" f90 F)) + (bcStrings (8 "6" f91 F)) + (bcStrings (8 "5.2755" f92 F)) + (bcStrings (8 "3.2418" f93 F)) + (bcStrings (8 "0.42442" f94 F)) + (bcStrings (8 "-2.4769" f95 F)) + (bcStrings (8 "-4.8169" f96 F)) + (bcStrings (8 "-5.93" f97 F)) + (bcStrings (8 "-5.6387" f98 F)) + (bcStrings (8 "-3.9319" f99 F))) + htMakeDoneButton('"Continue",'e02dcfColdGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02dcfColdGen htPage == + mx := htpProperty(htPage,'mx) + my := htpProperty(htPage,'my) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + cold := '"c" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(mx*my) repeat + end := STRCONC((first y).1," ") + y := rest y + fList := [end,:fList] + fstring := bcwords2liststring fList + for i in 1..my repeat + mid := STRCONC ((first y).1," ") + y := rest y + ylist := [mid,:ylist] + ystring := bcwords2liststring ylist + while y repeat + start := STRCONC ((first y).1," ") + y := rest y + xlist := [start,:xlist] + xstring := bcwords2liststring xlist + -- additional entries needed to get it running + -- but as Start = c they are not used + prefix := STRCONC('"e02dcf(_"",cold,"_",",STRINGIMAGE mx,", [",xstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE my,",[",ystring,"],[",fstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,",0,new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,") + prefix := STRCONC(prefix,"0,new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") + end := STRCONC("new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,[[0 for i in 1..") + end := STRCONC(end,STRINGIMAGE liwrk,"]]::Matrix Integer,",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,end) + + +e02ddf() == + htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02ddf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ddf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Determines a bicubic spline approximation to a set of scattered") + (text . " points ( \htbitmap{xr},\htbitmap{yr}, ") + (text . "\htbitmap{fr})") + (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") + (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") + (text . "\htbitmap{nx} and \htbitmap{mui}, for ") + (text . "i = 1,2,...,\htbitmap{ny} are chosen by the routine ") + (text . ", but a single parameter S must be specified to control the ") + (text . "trade-off between closeness of fit and smoothness of fit. This ") + (text . "affects the number of knots required by the spline, which is ") + (text . "given in the B-spline representation \htbitmap{e02daf}") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") + (text . "computed spline, {\it nxest}: \newline\tab{2} ") + (bcStrings (6 14 nxest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") + (text . "spline, {\it nyest}: \newline\tab{2} ") + (bcStrings (6 14 nyest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Smoothing factor {\it s}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "10" s F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Start value: ") + (radioButtons start + ("" " Cold Start - no values needed for {\it nx,ny,lamda,wrk,iwrk}" cold) + ("" " Warm Start - uses knots found in a previous call" warm)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02ddfSolve) + htShowPage() + +e02ddfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + nxest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) + objValUnwrap htpLabelSpadValue(htPage, 'nxest) + nyest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) + objValUnwrap htpLabelSpadValue(htPage, 'nyest) + u := nxest - 4 + v := nyest - 4 + wlist := [u,v] + w := APPLY ('MAX, wlist) + lwrk := (7*u*v + 25*w)*(w + 1) + 2*(u + v + 4*m) + 23*w + 56 + liwrk := m + 2*(nxest - 7)*(nyest - 7) + s := htpLabelInputString(htPage,'s) + initial := htpButtonValue(htPage,'start) + start := + initial = 'cold => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = 30 and start = 1) => e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) + start = 1 => e02ddfColdSolve (htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) + -- need to change as only wrk(1) is required + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + post := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + lamdaList := + "append"/[g(i) for i in 1..nxest] where g(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Lamda: \newline") + lamdaList := [['text,:prefix],:lamdaList] + muList := + "append"/[h(i) for i in 1..nyest] where h(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Mu: \newline") + muList := [['text,:prefix],:muList] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of nx: \newline \tab{2}") + nxList := [['text,:prefix],['bcStrings,[8, 10, 'nx, 'PI]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of ny: \newline \tab{2}") + nyList := [['text,:prefix],['bcStrings,[8, 9, 'ny, 'PI]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of WRK(1): \newline \tab{2}") + wList := [['text,:prefix],['bcStrings,[8, 0.0, 'wone, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamdaList,:muList,:nxList,:nyList,:wList] + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" + htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " + htSay '"\htbitmap{fr}: \tab{45} \menuitemstyle{} " + htSay '"\tab{47} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ddfWarmGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + + +e02ddfColdSolve(htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) == + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + post := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" + htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " + htSay '"\htbitmap{fr}: \tab{44} \menuitemstyle{} " + htSay '"\tab{46} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ddfColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == + m := 30 + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") + (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") + (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") + (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") + (text . "\tab{46} Values of \htbitmap{wr}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "11.16" x1 F)) + (text . "\tab{17}") + (bcStrings (8 "1.24" y1 F)) + (text . "\tab{32}") + (bcStrings (8 "22.15" f1 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "12.85" x2 F)) + (text . "\tab{17}") + (bcStrings (8 "3.06" y2 F)) + (text . "\tab{32}") + (bcStrings (8 "22.11" f2 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "19.85" x3 F)) + (text . "\tab{17}") + (bcStrings (8 "10.72" y3 F)) + (text . "\tab{32}") + (bcStrings (8 "7.97" f3 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "19.72" x4 F)) + (text . "\tab{17}") + (bcStrings (8 "1.39" y4 F)) + (text . "\tab{32}") + (bcStrings (8 "16.83" f4 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "15.91" x5 F)) + (text . "\tab{17}") + (bcStrings (8 "7.74" y5 F)) + (text . "\tab{32}") + (bcStrings (8 "15.30" f5 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0" x6 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y6 F)) + (text . "\tab{32}") + (bcStrings (8 "34.6" f6 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "20.87" x7 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y7 F)) + (text . "\tab{32}") + (bcStrings (8 "5.74" f7 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "3.45" x8 F)) + (text . "\tab{17}") + (bcStrings (8 "12.78" y8 F)) + (text . "\tab{32}") + (bcStrings (8 "41.24" f8 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "14.26" x9 F)) + (text . "\tab{17}") + (bcStrings (8 "17.87" y9 F)) + (text . "\tab{32}") + (bcStrings (8 "10.74" f9 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.43" x10 F)) + (text . "\tab{17}") + (bcStrings (8 "3.46" y10 F)) + (text . "\tab{32}") + (bcStrings (8 "18.60" f10 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w10 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.8" x11 F)) + (text . "\tab{17}") + (bcStrings (8 "12.39" y11 F)) + (text . "\tab{32}") + (bcStrings (8 "5.47" f11 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w11 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "7.58" x12 F)) + (text . "\tab{17}") + (bcStrings (8 "1.98" y12 F)) + (text . "\tab{32}") + (bcStrings (8 "29.87" f12 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w12 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "25" x13 F)) + (text . "\tab{17}") + (bcStrings (8 "11.87" y13 F)) + (text . "\tab{32}") + (bcStrings (8 "4.4" f13 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w13 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0" x14 F)) + (text . "\tab{17}") + (bcStrings (8 "0" y14 F)) + (text . "\tab{32}") + (bcStrings (8 "58.2" f14 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w14 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "9.66" x15 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y15 F)) + (text . "\tab{32}") + (bcStrings (8 "4.73" f15 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w15 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "5.22" x16 F)) + (text . "\tab{17}") + (bcStrings (8 "14.66" y16 F)) + (text . "\tab{32}") + (bcStrings (8 "40.36" f16 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w16 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.25" x17 F)) + (text . "\tab{17}") + (bcStrings (8 "19.57" y17 F)) + (text . "\tab{32}") + (bcStrings (8 "6.43" f17 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w17 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "25" x18 F)) + (text . "\tab{17}") + (bcStrings (8 "3.87" y18 F)) + (text . "\tab{32}") + (bcStrings (8 "8.74" f18 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w18 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "12.13" x19 F)) + (text . "\tab{17}") + (bcStrings (8 "10.79" y19 F)) + (text . "\tab{32}") + (bcStrings (8 "13.71" f19 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w19 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.23" x20 F)) + (text . "\tab{17}") + (bcStrings (8 "6.21" y20 F)) + (text . "\tab{32}") + (bcStrings (8 "10.25" f20 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w20 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "11.52" x21 F)) + (text . "\tab{17}") + (bcStrings (8 "8.53" y21 F)) + (text . "\tab{32}") + (bcStrings (8 "15.74" f21 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w21 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "15.2" x22 F)) + (text . "\tab{17}") + (bcStrings (8 "0" y22 F)) + (text . "\tab{32}") + (bcStrings (8 "21.6" f22 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w22 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "7.54" x23 F)) + (text . "\tab{17}") + (bcStrings (8 "10.69" y23 F)) + (text . "\tab{32}") + (bcStrings (8 "19.31" f23 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w23 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.32" x24 F)) + (text . "\tab{17}") + (bcStrings (8 "13.78" y24 F)) + (text . "\tab{32}") + (bcStrings (8 "12.11" f24 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w24 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "2.14" x25 F)) + (text . "\tab{17}") + (bcStrings (8 "15.03" y25 F)) + (text . "\tab{32}") + (bcStrings (8 "53.1" f25 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w25 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.51" x26 F)) + (text . "\tab{17}") + (bcStrings (8 "8.37" y26 F)) + (text . "\tab{32}") + (bcStrings (8 "49.43" f26 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w26 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.69" x27 F)) + (text . "\tab{17}") + (bcStrings (8 "19.63" y27 F)) + (text . "\tab{32}") + (bcStrings (8 "3.25" f27 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w27 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "5.47" x28 F)) + (text . "\tab{17}") + (bcStrings (8 "17.13" y28 F)) + (text . "\tab{32}") + (bcStrings (8 "28.63" f28 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w28 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "21.67" x29 F)) + (text . "\tab{17}") + (bcStrings (8 "14.36" y29 F)) + (text . "\tab{32}") + (bcStrings (8 "5.52" f29 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w29 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "3.31" x30 F)) + (text . "\tab{17}") + (bcStrings (8 "0.33" y30 F)) + (text . "\tab{32}") + (bcStrings (8 "44.08" f30 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w30 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02ddfColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02ddfColdGen htPage == + m := htpProperty(htPage,'m) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + cold := '"c" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + flist := [right,:flist] + wlist := [end,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + -- additional entries nx,ny,lamda,mu,wrk needed to get it running + -- but they are just set to 0.0 + prefix := STRCONC('"e02ddf(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") + prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,", 0,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,0,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nxest,"]],0,") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nyest,"]],") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE lwrk,"]],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e02ddfWarmGen htPage == + m := htpProperty(htPage,'m) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + warm := '"w" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + wrk := (first y).1 + y := rest y + for i in 1..lwrk repeat + wrkList := ['"0.0 ",:wrkList] + wrkList := [wrk,:wrkList] + wrkstring := bcwords2liststring wrkList + ny := STRCONC((first y).1," ") + y := rest y + nx := STRCONC((first y).1," ") + y := rest y + for i in 1..nyest repeat + mu := STRCONC ((first y).1, " ") + y := rest y + muList := [mu,:muList] + mustring := bcwords2liststring muList + for i in 1..nxest repeat + lam := STRCONC ((first y).1, " ") + y := rest y + lamList := [lam,:lamList] + lamstring := bcwords2liststring lamList + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + flist := [right,:flist] + wlist := [end,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + -- additional entries nx,ny,lamda,mu,wrk needed to get it running + -- but they are just set to 0.0 + prefix := STRCONC('"e02ddf(_"",warm,"_",",STRINGIMAGE m,", [",xstring,"],[") + prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",nx,",[",lamstring,"],",ny) + prefix := STRCONC(prefix,",[",mustring,"],[",wrkstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e02zaf() == + htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02zaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02zaf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Sorts the set of points {\em (\htbitmap{xr},") + (text . "\htbitmap{yr})} into panels defined by \space{1}") + (text . "\htbitmap{px} -8 points \htbitmap{lamdai} ") + (text . "on the x-axis and \space{1}\htbitmap{py}-8 points ") + (text . "\htbitmap{muj} on the y axis. The points are ordered ") + (text . "so that all points in a panel occur before data in succeeding ") + (text . "panels. Within a panel, the points maintain their original ") + (text . "order. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of points to be sorted to be sorted {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 10 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Intercepts + 8 on x axis {\em px}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Intercepts + 8 on y axis {\em py}:") + (text . "\newline\tab{2} ") + (bcStrings (6 9 px PI)) + (text . "\tab{34} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Dimension of point {\it npoint}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 45 npoint PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02zafSolve) + htShowPage() + +e02zafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + npoint := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) + objValUnwrap htpLabelSpadValue(htPage, 'npoint) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '10 and px = '9) and py = '10) => e02zafDefaultSolve(htPage,npoint,ifail) + labelList := + "append"/[fxy(i) for i in 1..m] where fxy(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{32} ") + lnam := INTERN STRCONC ('"x",STRINGIMAGE i) + cnam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, lnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, cnam, 'F]]] + lamList := + "append"/[flam(i) for i in 5..(px-4)] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(5) to ") + prefix := STRCONC(prefix,"\lambda(px-4)}: \newline \tab{2} ") + lamList := [['text,:prefix],:lamList] + muList := + "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(5) to \mu(py-4)}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + muList := [['text,:prefix],:muList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamList,:muList] + page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htSay '"\menuitemstyle{}\tab{2} {\it x(m)}: " + htSay '"\tab{30} \menuitemstyle{}\tab{32} {\it y(m)}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02zafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02zafDefaultSolve (htPage,npoint,ifail) == + m := '10 + px := '9 + py := '10 + page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} {\it x(m)}:") + (text . "\tab{30} \menuitemstyle{} \tab{32} {\it y(m)}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "0.00" x1 F)) + (text . "\tab{32}") + (bcStrings (8 "0.77" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.70" x2 F)) + (text . "\tab{32}") + (bcStrings (8 "1.06" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.44" x3 F)) + (text . "\tab{32}") + (bcStrings (8 "0.33" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.21" x4 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.01" x5 F)) + (text . "\tab{32}") + (bcStrings (8 "0.50" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.84" x6 F)) + (text . "\tab{32}") + (bcStrings (8 "0.02" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.71" x7 F)) + (text . "\tab{32}") + (bcStrings (8 "1.95" y7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.00" x8 F)) + (text . "\tab{32}") + (bcStrings (8 "1.20" y8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.54" x9 F)) + (text . "\tab{32}") + (bcStrings (8 "0.04" y9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.531" x10 F)) + (text . "\tab{32}") + (bcStrings (8 "0.18" y10 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \lambda(5) to \lambda(px-4)}:") + (text . "\newline \tab{2}") + (bcStrings (8 "1.00" l5 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \mu(5) to \mu(py-4)}:") + (text . "\newline \tab{2}") + (bcStrings (8 "0.80" mu5 F)) + (bcStrings (8 "1.20" mu6 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'e02zafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02zafGen htPage == + m := htpProperty(htPage,'m) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + npoint := htpProperty(htPage,'npoint) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + nadres := (px-7)*(py-7) + -- mu + for i in 1..4 repeat + muList := ['"0 ",:muList] + for i in 5..(py-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + for i in (py-3)..py repeat + muList := ['"0 ",:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..4 repeat + lamList := ['"0 ",:lamList] + for i in 5..(px-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + for i in (px-3)..px repeat + lamList := ['"0 ",:lamList] + lamstring := bcwords2liststring lamList + -- x & y + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [right,:ylist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + prefix := STRCONC('"e02zaf(",STRINGIMAGE px,", ",STRINGIMAGE py,",[") + prefix := STRCONC(prefix,lamstring,"],[",mustring,"], ",STRINGIMAGE m,", [") + prefix := STRCONC(prefix,xstring,"],[",ystring,"], ",STRINGIMAGE npoint,", ") + prefix := STRCONC(prefix,STRINGIMAGE nadres,", ",STRINGIMAGE ifail,")") + linkGen prefix + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-e02b.boot b/src/interp/nag-e02b.boot deleted file mode 100644 index 7a22ba63..00000000 --- a/src/interp/nag-e02b.boot +++ /dev/null @@ -1,1735 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- READ THIS NOW! --- --- The automatic make fails to compile this file properly, leaving a --- truncated clisp file in int/interp. So if you change this file it --- must be compiled by hand in the interpreter (which works fine). --- MCD. --- - -e02daf() == - htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02daf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02daf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Determines a minimal, least squares bicubic B-spline surface fit") - (text . "\htbitmap{e02daf} to the set of points ") - (text . "{\em (\htbitmap{xr},\htbitmap{yr},\htbitmap{fr})} with weights ") - (text . "\htbitmap{wr}, for r = 1,2,...,m. The user must supply internal ") - (text . "knot sets {\lambda},in the x-direction and {\mu} in the ") - (text . "y-direction, ") - (text . "which can be thought of as dividing the data region into panels;") - (text . "s(x,y) consists of a seperate bicubic polynomial in each panel, ") - (text . "the polynomial joining together with second derivative ") - (text . "continuity. Eight additional (external) knots are added to each ") - (text . "of the knot sets by this routine. The routine minimizes \Sigma, ") - (text . "the sum of squares of the weighted residuals ") - (text . "\htbitmap{e02daf1}, for r = 1,2,...,m, subject to the ") - (text . "given knot sets. \newline ") - (text . "A call of this routine should be preceded by a call of E02ZAF ") - (text . "to provide indexing information. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Knots in x direction {\em px}") - (text . "\htbitmap{great=} 8: \tab{32} \menuitemstyle{}\tab{34}") - (text . "Knots in y direction {\em py}:") - (text . "\newline\tab{2} ") - (bcStrings (6 8 px PI)) - (text . "\tab{34} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Rank threshold {\em eps}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.000001" eps F)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Dimension of point {\it npoint}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 43 npoint PI)) - -- include a radio button later to allow switching of - -- x & y if px <= py - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02dafSolve) - htShowPage() - -e02dafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - npoint := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) - objValUnwrap htpLabelSpadValue(htPage, 'npoint) - nc := (px - 4)*(py - 4) - nws := (2*nc + 1)*(3*py - 6) -2 - eps := htpLabelInputString(htPage,'eps) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '30 and px = '8) and py = '10) => e02dafDefaultSolve(htPage,eps,nws,npoint,ifail) - labelList := - "append"/[fxy(i) for i in 1..m] where fxy(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - next := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:next],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - lamList := - "append"/[flam(i) for i in 5..(px-4)] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} lamda(5) to lamda(px-4): ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - postfix := ('"\newline \blankline ") - lamList := [['text,:prefix],:lamList,['text,:postfix]] - muList := - "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\menuitemstyle{} \tab{2} mu(5) to mu(py-4):") - prefix := STRCONC(prefix,"\newline \tab{2} ") - muList := [['text,:prefix],:muList] - pList := - "append"/[fp(i) for i in 1..npoint] where fp(i) == - prefix := ('"\newline \tab{2} ") - pnam := INTERN STRCONC ('"p",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, pnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of Point: ") - pList := [['text,:prefix],:pList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamList,:muList,:pList] - page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " - htSay '"\tab{15} \menuitemstyle{}\tab{17} Values of \htbitmap{yr}:" - htSay '"\tab{30} \menuitemstyle{}\tab{32} Values of \htbitmap{fr}:" - htSay '"\tab{44} \menuitemstyle{}\tab{46} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02dafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'nws,nws) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02dafDefaultSolve (htPage,eps,nws,npoint,ifail) == - m := '30 - px := '8 - py := '10 - page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") - (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") - (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") - (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") - (text . "\tab{46} Values of \htbitmap{wr}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.52" x1 F)) - (text . "\tab{17}") - (bcStrings (8 "0.60" y1 F)) - (text . "\tab{32}") - (bcStrings (8 "0.93" f1 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.61" x2 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.95" y2 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.79" f2 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.93" x3 F)) - (text . "\tab{17}") - (bcStrings (8 "0.87" y3 F)) - (text . "\tab{32}") - (bcStrings (8 "0.36" f3 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.09" x4 F)) - (text . "\tab{17}") - (bcStrings (8 "0.84" y4 F)) - (text . "\tab{32}") - (bcStrings (8 "0.52" f4 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.88" x5 F)) - (text . "\tab{17}") - (bcStrings (8 "0.17" y5 F)) - (text . "\tab{32}") - (bcStrings (8 "0.49" f5 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.70" x6 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.87" y6 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.76" f6 F)) - (text . "\tab{47}") - (bcStrings (8 "10" w6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1" x7 F)) - (text . "\tab{17}") - (bcStrings (8 "1" y7 F)) - (text . "\tab{32}") - (bcStrings (8 "0.33" f7 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1" x8 F)) - (text . "\tab{17}") - (bcStrings (8 "0.1" y8 F)) - (text . "\tab{32}") - (bcStrings (8 "0.48" f8 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.3" x9 F)) - (text . "\tab{17}") - (bcStrings (8 "0.24" y9 F)) - (text . "\tab{32}") - (bcStrings (8 "0.65" f9 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.77" x10 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.77" y10 F)) - (text . "\tab{32}") - (bcStrings (8 "-1.82" f10 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w10 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.23" x11 F)) - (text . "\tab{17}") - (bcStrings (8 "0.32" y11 F)) - (text . "\tab{32}") - (bcStrings (8 "0.92" f11 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w11 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-1" x12 F)) - (text . "\tab{17}") - (bcStrings (8 "1" y12 F)) - (text . "\tab{32}") - (bcStrings (8 "1" f12 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w12 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.26" x13 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.63" y13 F)) - (text . "\tab{32}") - (bcStrings (8 "8.88" f13 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w13 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.83" x14 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.66" y14 F)) - (text . "\tab{32}") - (bcStrings (8 "-2.01" f14 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w14 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.22" x15 F)) - (text . "\tab{17}") - (bcStrings (8 "0.93" y15 F)) - (text . "\tab{32}") - (bcStrings (8 "0.47" f15 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w15 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.89" x16 F)) - (text . "\tab{17}") - (bcStrings (8 "0.15" y16 F)) - (text . "\tab{32}") - (bcStrings (8 "0.49" f16 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w16 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.80" x17 F)) - (text . "\tab{17}") - (bcStrings (8 "0.99" y17 F)) - (text . "\tab{32}") - (bcStrings (8 "0.84" f17 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w17 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.88" x18 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.54" y18 F)) - (text . "\tab{32}") - (bcStrings (8 "-2.42" f18 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w18 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.68" x19 F)) - (text . "\tab{17}") - (bcStrings (8 "0.44" y19 F)) - (text . "\tab{32}") - (bcStrings (8 "0.47" f19 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w19 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.14" x20 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.72" y20 F)) - (text . "\tab{32}") - (bcStrings (8 "7.15" f20 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w20 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.67" x21 F)) - (text . "\tab{17}") - (bcStrings (8 "0.63" y21 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" f21 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w21 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.90" x22 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.40" y22 F)) - (text . "\tab{32}") - (bcStrings (8 "-3.34" f22 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w22 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.84" x23 F)) - (text . "\tab{17}") - (bcStrings (8 "0.20" y23 F)) - (text . "\tab{32}") - (bcStrings (8 "2.78" f23 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w23 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.84" x24 F)) - (text . "\tab{17}") - (bcStrings (8 "0.43" y24 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" f24 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w24 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.15" x25 F)) - (text . "\tab{17}") - (bcStrings (8 "0.28" y25 F)) - (text . "\tab{32}") - (bcStrings (8 "0.70" f25 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w25 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.91" x26 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.24" y26 F)) - (text . "\tab{32}") - (bcStrings (8 "-6.52" f26 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w26 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.35" x27 F)) - (text . "\tab{17}") - (bcStrings (8 "0.86" y27 F)) - (text . "\tab{32}") - (bcStrings (8 "0.66" f27 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w27 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.16" x28 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.41" y28 F)) - (text . "\tab{32}") - (bcStrings (8 "2.32" f28 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w28 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-0.35" x29 F)) - (text . "\tab{17}") - (bcStrings (8 "-0.05" y29 F)) - (text . "\tab{32}") - (bcStrings (8 "1.66" f29 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w29 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "-1" x30 F)) - (text . "\tab{17}") - (bcStrings (8 "-1" y30 F)) - (text . "\tab{32}") - (bcStrings (8 "-1" f30 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w30 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} mu(5) to mu(py-4):") - (text . "\newline \tab{2}") - (bcStrings (8 "-0.50" mu5 F)) - (bcStrings (8 "0.00" mu6 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values for point:") - (text . "\newline \tab{2}") - (bcStrings (6 3 p1 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 6 p2 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 4 p3 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 5 p4 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 7 p5 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 10 p6 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 8 p7 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 9 p8 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 11 p9 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 13 p10 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 12 p11 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 15 p12 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 14 p13 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 18 p14 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 16 p15 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 17 p16 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 19 p17 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 20 p18 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 21 p19 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 30 p20 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 23 p21 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 26 p22 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 24 p23 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 25 p24 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 27 p25 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 28 p26 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p27 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 29 p28 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p29 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p30 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 2 p31 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 22 p32 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 1 p33 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p34 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p35 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p36 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p37 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p38 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p39 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p40 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p41 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p42 PI)) - (text . "\newline \tab{2}") - (bcStrings (6 0 p43 PI)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02dafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'nws,nws) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02dafGen htPage == - m := htpProperty(htPage,'m) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - nws := htpProperty(htPage,'nws) - eps := htpProperty(htPage,'eps) - npoint := htpProperty(htPage,'npoint) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - nadres := (px-7)*(py-7) - -- point - for i in 1..npoint repeat - right := STRCONC ((first y).1," ") - y := rest y - pointList := [right,:pointList] - pstring := bcwords2liststring pointList - -- mu - for i in 1..4 repeat - muList := ['"0 ",:muList] - for i in 5..(py-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - for i in (py-3)..py repeat - muList := ['"0 ",:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..4 repeat - lamList := ['"0 ",:lamList] - for i in 5..(px-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - for i in (px-3)..px repeat - lamList := ['"0 ",:lamList] - lamstring := bcwords2liststring lamList - -- x & y - while y repeat - one := STRCONC((first y).1," ") - y := rest y - two := STRCONC((first y).1," ") - y := rest y - three := STRCONC ((first y).1," ") - y := rest y - four := STRCONC ((first y).1," ") - y := rest y - xlist := [four,:xlist] - ylist := [three,:ylist] - flist := [two,:flist] - wlist := [one,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - nc := (px-4)*(py-4) - prefix := STRCONC('"e02daf(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") - prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") - prefix := STRCONC(prefix,fstring,"],[",wstring,"],[",mustring,"],[") - prefix := STRCONC(prefix,pstring,"], ",STRINGIMAGE npoint,", ") - prefix := STRCONC(prefix,STRINGIMAGE nc,", ",STRINGIMAGE nws,", ",eps,", [") - prefix := STRCONC(prefix,lamstring,"], ",STRINGIMAGE ifail,")") - linkGen prefix - - -e02dcf() == - htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02dcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dcf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Determines a bicubic spline approximation to a set of points ") - (text . "given on a rectangular grid defined by \htbitmap{mx} ") - (text . "points \htbitmap{xq} on the x-axis and ") - (text . "\htbitmap{my} points \htbitmap{yr} on the ") - (text . "y-axix. The knots \htbitmap{lamdai}, for i = 1,2,...,") - (text . "\htbitmap{nx} and \htbitmap{mui}, for ") - (text . "i = 1,2,...,\htbitmap{ny} are chosen for this routine ") - (text . ", but a single parameter S must be specified to control the ") - (text . "trade-off between closeness of fit and smoothness of fit. This ") - (text . "affects the number of knots required by the spline, which is ") - (text . "given in the B-spline representation \htbitmap{e02daf}") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Grid points on x-axis \htbitmap{mx}: ") - (text . "\tab{30} \menuitemstyle{}\tab{32} Grid points on y-axis ") - (text . "\htbitmap{my}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 11 mx PI)) - (text . "\tab{32} ") - (bcStrings (6 9 my PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") - (text . "computed spline, {\it nxest}: \newline\tab{2} ") - (bcStrings (6 15 nxest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") - (text . "spline, {\it nyest}: \newline\tab{2} ") - (bcStrings (6 13 nyest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Smoothing factor {\it s}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "0.1" s F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Start value: ") - (radioButtons start - ("" " Cold Start - no values needed for {\it nx,ny,lamda,mu} or {\it iwrk}" cold) - ("" " Warm Start - uses knots found in a previous call" warm)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02dcfSolve) - htShowPage() - -e02dcfSolve htPage == - mx := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) - objValUnwrap htpLabelSpadValue(htPage, 'mx) - my := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) - objValUnwrap htpLabelSpadValue(htPage, 'my) - nxest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) - objValUnwrap htpLabelSpadValue(htPage, 'nxest) - nyest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) - objValUnwrap htpLabelSpadValue(htPage, 'nyest) - wrklist := [my,nxest] - wrkmax := APPLY ('MAX, wrklist) - lwrk := 4*(mx + my) +11*(nxest + nyest) + nxest*my + wrkmax +54 - liwrk := 3 + mx + my + nxest + nyest - s := htpLabelInputString(htPage,'s) - initial := htpButtonValue(htPage,'start) - start := - initial = 'cold => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((mx = 11 and my = 9) and start = 1) => - e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) - start = 1 => e02dcfColdSolve (htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) - -- warm start not really possible from hyperdoc - -- as inputing a workspace array of dimension 592 is asking too much - -- user should use the command line, using the previous calculated - -- parameters - htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\blankline ") - (text . "{\center{\em Hyperdoc interface not available for warm starts.}}") - (text . "\newline ") - (text . "{\center{\em Please use the command line.}}")) - htMakeDoneButton('"Continue",'e02dcf) - htShowPage() - - - -e02dcfColdSolve(htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) == - xList := - "append"/[f(i) for i in 1..mx] where f(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, 0.0, xnam, 'F]]] - yList := - "append"/[g(i) for i in 1..my] where g(i) == - ynam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['bcStrings,[8, 0.0, ynam, 'F]]] - prefix:= ('"\blankline \menuitemstyle{}\tab{2} Values of {\it y(my)}: \newline ") - yList := [['text,:prefix],:yList] - fList := - "append"/[h(i) for i in 1..(mx*my)] where h(i) == - fnam := INTERN STRCONC ('"g",STRINGIMAGE i) - [['bcStrings,[8, 0.0, fnam, 'F]]] - prefix:=('"\blankline \menuitemstyle{} \tab{2} Values of {\it f(mx*my)}: \newline ") - fList := [['text,:prefix],:fList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :xList,:yList,:fList] - page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htSay '"\menuitemstyle{}\tab{2} Values of {\it x(mx)}: \newline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02dcfColdGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == - mx := 11 - my := 9 - page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it x(mx)}:") - (text . "\newline ") - (bcStrings (8 "0" x1 F)) - (bcStrings (8 "0.5" x2 F)) - (bcStrings (8 "1" x3 F)) - (bcStrings (8 "1.5" x4 F)) - (bcStrings (8 "2" x5 F)) - (bcStrings (8 "2.5" x6 F)) - (bcStrings (8 "3" x7 F)) - (bcStrings (8 "3.5" x8 F)) - (bcStrings (8 "4" x9 F)) - (bcStrings (8 "4.5" x10 F)) - (bcStrings (8 "5" x11 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it y(my)}:") - (text . "\newline ") - (bcStrings (8 "0" y1 F)) - (bcStrings (8 "0.5" y2 F)) - (bcStrings (8 "1" y3 F)) - (bcStrings (8 "1.5" y4 F)) - (bcStrings (8 "2" y5 F)) - (bcStrings (8 "2.5" y6 F)) - (bcStrings (8 "3" y7 F)) - (bcStrings (8 "3.5" y8 F)) - (bcStrings (8 "4" y9 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Values of {\it f(mx*my)}:") - (text . "\newline ") - (bcStrings (8 "1" f1 F)) - (bcStrings (8 "0.88758" f2 F)) - (bcStrings (8 "0.5403" f3 F)) - (bcStrings (8 "0.070737" f4 F)) - (bcStrings (8 "-0.41515" f5 F)) - (bcStrings (8 "-0.80114" f6 F)) - (bcStrings (8 "-0.97999" f7 F)) - (bcStrings (8 "-0.93446" f8 F)) - (bcStrings (8 "-0.65664" f9 F)) - (bcStrings (8 "1.5" f10 F)) - (bcStrings (8 "1.3564" f11 F)) - (bcStrings (8 "0.82045" f12 F)) - (bcStrings (8 "0.10611" f13 F)) - (bcStrings (8 "-0.62422" f14 F)) - (bcStrings (8 "-1.2317" f15 F)) - (bcStrings (8 "-1.485" f16 F)) - (bcStrings (8 "-1.3047" f17 F)) - (bcStrings (8 "-0.98547" f18 F)) - (bcStrings (8 "2.06" f19 F)) - (bcStrings (8 "1.7552" f20 F)) - (bcStrings (8 "1.0806" f21 F)) - (bcStrings (8 "0.15147" f22 F)) - (bcStrings (8 "-0.83229" f23 F)) - (bcStrings (8 "-1.6023" f24 F)) - (bcStrings (8 "-1.97" f25 F)) - (bcStrings (8 "-1.8729" f26 F)) - (bcStrings (8 "-1.4073" f27 F)) - (bcStrings (8 "2.57" f28 F)) - (bcStrings (8 "2.124" f29 F)) - (bcStrings (8 "1.3508" f30 F)) - (bcStrings (8 "0.17684" f31 F)) - (bcStrings (8 "-1.0404" f32 F)) - (bcStrings (8 "-2.0029" f33 F)) - (bcStrings (8 "-2.475" f34 F)) - (bcStrings (8 "-2.3511" f35 F)) - (bcStrings (8 "-1.6741" f36 F)) - (bcStrings (8 "3" f37 F)) - (bcStrings (8 "2.6427" f38 F)) - (bcStrings (8 "1.6309" f39 F)) - (bcStrings (8 "0.21221" f40 F)) - (bcStrings (8 "-1.2484" f41 F)) - (bcStrings (8 "-2.2034" f42 F)) - (bcStrings (8 "-2.97" f43 F)) - (bcStrings (8 "-2.8094" f44 F)) - (bcStrings (8 "-1.9809" f45 F)) - (bcStrings (8 "3.5" f46 F)) - (bcStrings (8 "3.1715" f47 F)) - (bcStrings (8 "1.8611" f48 F)) - (bcStrings (8 "0.24458" f49 F)) - (bcStrings (8 "-1.4565" f50 F)) - (bcStrings (8 "-2.864" f51 F)) - (bcStrings (8 "-3.265" f52 F)) - (bcStrings (8 "-3.2776" f53 F)) - (bcStrings (8 "-2.2878" f54 F)) - (bcStrings (8 "4.04" f55 F)) - (bcStrings (8 "3.5103" f56 F)) - (bcStrings (8 "2.0612" f57 F)) - (bcStrings (8 "0.28595" f58 F)) - (bcStrings (8 "-1.6946" f59 F)) - (bcStrings (8 "-3.2046" f60 F)) - (bcStrings (8 "-3.96" f61 F)) - (bcStrings (8 "-3.7958" f62 F)) - (bcStrings (8 "-2.6146" f63 F)) - (bcStrings (8 "4.5" f64 F)) - (bcStrings (8 "3.9391" f65 F)) - (bcStrings (8 "2.4314" f66 F)) - (bcStrings (8 "0.31632" f67 F)) - (bcStrings (8 "-1.8627" f68 F)) - (bcStrings (8 "-3.6351" f69 F)) - (bcStrings (8 "-4.455" f70 F)) - (bcStrings (8 "-4.2141" f71 F)) - (bcStrings (8 "-2.9314" f72 F)) - (bcStrings (8 "5.04" f73 F)) - (bcStrings (8 "4.3879" f74 F)) - (bcStrings (8 "2.7515" f75 F)) - (bcStrings (8 "0.35369" f76 F)) - (bcStrings (8 "-2.0707" f77 F)) - (bcStrings (8 "-4.0057" f78 F)) - (bcStrings (8 "-4.97" f79 F)) - (bcStrings (8 "-4.6823" f80 F)) - (bcStrings (8 "-3.2382" f81 F)) - (bcStrings (8 "5.505" f82 F)) - (bcStrings (8 "4.8367" f83 F)) - (bcStrings (8 "2.9717" f84 F)) - (bcStrings (8 "0.38505" f85 F)) - (bcStrings (8 "-2.2888" f86 F)) - (bcStrings (8 "-4.4033" f87 F)) - (bcStrings (8 "-5.445" f88 F)) - (bcStrings (8 "-5.1405" f89 F)) - (bcStrings (8 "-3.595" f90 F)) - (bcStrings (8 "6" f91 F)) - (bcStrings (8 "5.2755" f92 F)) - (bcStrings (8 "3.2418" f93 F)) - (bcStrings (8 "0.42442" f94 F)) - (bcStrings (8 "-2.4769" f95 F)) - (bcStrings (8 "-4.8169" f96 F)) - (bcStrings (8 "-5.93" f97 F)) - (bcStrings (8 "-5.6387" f98 F)) - (bcStrings (8 "-3.9319" f99 F))) - htMakeDoneButton('"Continue",'e02dcfColdGen) - htpSetProperty(page,'mx,mx) - htpSetProperty(page,'my,my) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02dcfColdGen htPage == - mx := htpProperty(htPage,'mx) - my := htpProperty(htPage,'my) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - cold := '"c" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(mx*my) repeat - end := STRCONC((first y).1," ") - y := rest y - fList := [end,:fList] - fstring := bcwords2liststring fList - for i in 1..my repeat - mid := STRCONC ((first y).1," ") - y := rest y - ylist := [mid,:ylist] - ystring := bcwords2liststring ylist - while y repeat - start := STRCONC ((first y).1," ") - y := rest y - xlist := [start,:xlist] - xstring := bcwords2liststring xlist - -- additional entries needed to get it running - -- but as Start = c they are not used - prefix := STRCONC('"e02dcf(_"",cold,"_",",STRINGIMAGE mx,", [",xstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE my,",[",ystring,"],[",fstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,",0,new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,") - prefix := STRCONC(prefix,"0,new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") - end := STRCONC("new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,[[0 for i in 1..") - end := STRCONC(end,STRINGIMAGE liwrk,"]]::Matrix Integer,",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,end) - - -e02ddf() == - htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02ddf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ddf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Determines a bicubic spline approximation to a set of scattered") - (text . " points ( \htbitmap{xr},\htbitmap{yr}, ") - (text . "\htbitmap{fr})") - (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") - (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") - (text . "\htbitmap{nx} and \htbitmap{mui}, for ") - (text . "i = 1,2,...,\htbitmap{ny} are chosen by the routine ") - (text . ", but a single parameter S must be specified to control the ") - (text . "trade-off between closeness of fit and smoothness of fit. This ") - (text . "affects the number of knots required by the spline, which is ") - (text . "given in the B-spline representation \htbitmap{e02daf}") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of data points {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 30 m PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") - (text . "computed spline, {\it nxest}: \newline\tab{2} ") - (bcStrings (6 14 nxest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") - (text . "spline, {\it nyest}: \newline\tab{2} ") - (bcStrings (6 14 nyest PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Smoothing factor {\it s}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 "10" s F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Start value: ") - (radioButtons start - ("" " Cold Start - no values needed for {\it nx,ny,lamda,wrk,iwrk}" cold) - ("" " Warm Start - uses knots found in a previous call" warm)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02ddfSolve) - htShowPage() - -e02ddfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - nxest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) - objValUnwrap htpLabelSpadValue(htPage, 'nxest) - nyest := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) - objValUnwrap htpLabelSpadValue(htPage, 'nyest) - u := nxest - 4 - v := nyest - 4 - wlist := [u,v] - w := APPLY ('MAX, wlist) - lwrk := (7*u*v + 25*w)*(w + 1) + 2*(u + v + 4*m) + 23*w + 56 - liwrk := m + 2*(nxest - 7)*(nyest - 7) - s := htpLabelInputString(htPage,'s) - initial := htpButtonValue(htPage,'start) - start := - initial = 'cold => '1 - '2 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = 30 and start = 1) => e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) - start = 1 => e02ddfColdSolve (htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) - -- need to change as only wrk(1) is required - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - post := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - lamdaList := - "append"/[g(i) for i in 1..nxest] where g(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Lamda: \newline") - lamdaList := [['text,:prefix],:lamdaList] - muList := - "append"/[h(i) for i in 1..nyest] where h(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Mu: \newline") - muList := [['text,:prefix],:muList] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of nx: \newline \tab{2}") - nxList := [['text,:prefix],['bcStrings,[8, 10, 'nx, 'PI]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of ny: \newline \tab{2}") - nyList := [['text,:prefix],['bcStrings,[8, 9, 'ny, 'PI]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of WRK(1): \newline \tab{2}") - wList := [['text,:prefix],['bcStrings,[8, 0.0, 'wone, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamdaList,:muList,:nxList,:nyList,:wList] - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" - htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " - htSay '"\htbitmap{fr}: \tab{45} \menuitemstyle{} " - htSay '"\tab{47} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ddfWarmGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - - -e02ddfColdSolve(htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) == - labelList := - "append"/[f(i) for i in 1..m] where f(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{17} ") - post := ('"\tab{32} ") - end := ('"\tab{47} ") - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ynam := INTERN STRCONC ('"y",STRINGIMAGE i) - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - wnam := INTERN STRCONC ('"w",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], - ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], - ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList] - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " - htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " - htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" - htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " - htSay '"\htbitmap{fr}: \tab{44} \menuitemstyle{} " - htSay '"\tab{46} Values of \htbitmap{wr}:" - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02ddfColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == - m := 30 - page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") - (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") - (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") - (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") - (text . "\tab{46} Values of \htbitmap{wr}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "11.16" x1 F)) - (text . "\tab{17}") - (bcStrings (8 "1.24" y1 F)) - (text . "\tab{32}") - (bcStrings (8 "22.15" f1 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "12.85" x2 F)) - (text . "\tab{17}") - (bcStrings (8 "3.06" y2 F)) - (text . "\tab{32}") - (bcStrings (8 "22.11" f2 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "19.85" x3 F)) - (text . "\tab{17}") - (bcStrings (8 "10.72" y3 F)) - (text . "\tab{32}") - (bcStrings (8 "7.97" f3 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "19.72" x4 F)) - (text . "\tab{17}") - (bcStrings (8 "1.39" y4 F)) - (text . "\tab{32}") - (bcStrings (8 "16.83" f4 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "15.91" x5 F)) - (text . "\tab{17}") - (bcStrings (8 "7.74" y5 F)) - (text . "\tab{32}") - (bcStrings (8 "15.30" f5 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0" x6 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y6 F)) - (text . "\tab{32}") - (bcStrings (8 "34.6" f6 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "20.87" x7 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y7 F)) - (text . "\tab{32}") - (bcStrings (8 "5.74" f7 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "3.45" x8 F)) - (text . "\tab{17}") - (bcStrings (8 "12.78" y8 F)) - (text . "\tab{32}") - (bcStrings (8 "41.24" f8 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "14.26" x9 F)) - (text . "\tab{17}") - (bcStrings (8 "17.87" y9 F)) - (text . "\tab{32}") - (bcStrings (8 "10.74" f9 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.43" x10 F)) - (text . "\tab{17}") - (bcStrings (8 "3.46" y10 F)) - (text . "\tab{32}") - (bcStrings (8 "18.60" f10 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w10 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.8" x11 F)) - (text . "\tab{17}") - (bcStrings (8 "12.39" y11 F)) - (text . "\tab{32}") - (bcStrings (8 "5.47" f11 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w11 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "7.58" x12 F)) - (text . "\tab{17}") - (bcStrings (8 "1.98" y12 F)) - (text . "\tab{32}") - (bcStrings (8 "29.87" f12 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w12 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "25" x13 F)) - (text . "\tab{17}") - (bcStrings (8 "11.87" y13 F)) - (text . "\tab{32}") - (bcStrings (8 "4.4" f13 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w13 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0" x14 F)) - (text . "\tab{17}") - (bcStrings (8 "0" y14 F)) - (text . "\tab{32}") - (bcStrings (8 "58.2" f14 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w14 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "9.66" x15 F)) - (text . "\tab{17}") - (bcStrings (8 "20" y15 F)) - (text . "\tab{32}") - (bcStrings (8 "4.73" f15 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w15 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "5.22" x16 F)) - (text . "\tab{17}") - (bcStrings (8 "14.66" y16 F)) - (text . "\tab{32}") - (bcStrings (8 "40.36" f16 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w16 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.25" x17 F)) - (text . "\tab{17}") - (bcStrings (8 "19.57" y17 F)) - (text . "\tab{32}") - (bcStrings (8 "6.43" f17 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w17 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "25" x18 F)) - (text . "\tab{17}") - (bcStrings (8 "3.87" y18 F)) - (text . "\tab{32}") - (bcStrings (8 "8.74" f18 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w18 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "12.13" x19 F)) - (text . "\tab{17}") - (bcStrings (8 "10.79" y19 F)) - (text . "\tab{32}") - (bcStrings (8 "13.71" f19 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w19 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.23" x20 F)) - (text . "\tab{17}") - (bcStrings (8 "6.21" y20 F)) - (text . "\tab{32}") - (bcStrings (8 "10.25" f20 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w20 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "11.52" x21 F)) - (text . "\tab{17}") - (bcStrings (8 "8.53" y21 F)) - (text . "\tab{32}") - (bcStrings (8 "15.74" f21 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w21 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "15.2" x22 F)) - (text . "\tab{17}") - (bcStrings (8 "0" y22 F)) - (text . "\tab{32}") - (bcStrings (8 "21.6" f22 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w22 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "7.54" x23 F)) - (text . "\tab{17}") - (bcStrings (8 "10.69" y23 F)) - (text . "\tab{32}") - (bcStrings (8 "19.31" f23 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w23 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "17.32" x24 F)) - (text . "\tab{17}") - (bcStrings (8 "13.78" y24 F)) - (text . "\tab{32}") - (bcStrings (8 "12.11" f24 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w24 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "2.14" x25 F)) - (text . "\tab{17}") - (bcStrings (8 "15.03" y25 F)) - (text . "\tab{32}") - (bcStrings (8 "53.1" f25 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w25 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.51" x26 F)) - (text . "\tab{17}") - (bcStrings (8 "8.37" y26 F)) - (text . "\tab{32}") - (bcStrings (8 "49.43" f26 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w26 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "22.69" x27 F)) - (text . "\tab{17}") - (bcStrings (8 "19.63" y27 F)) - (text . "\tab{32}") - (bcStrings (8 "3.25" f27 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w27 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "5.47" x28 F)) - (text . "\tab{17}") - (bcStrings (8 "17.13" y28 F)) - (text . "\tab{32}") - (bcStrings (8 "28.63" f28 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w28 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "21.67" x29 F)) - (text . "\tab{17}") - (bcStrings (8 "14.36" y29 F)) - (text . "\tab{32}") - (bcStrings (8 "5.52" f29 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w29 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "3.31" x30 F)) - (text . "\tab{17}") - (bcStrings (8 "0.33" y30 F)) - (text . "\tab{32}") - (bcStrings (8 "44.08" f30 F)) - (text . "\tab{47}") - (bcStrings (8 "1" w30 F)) - (text . "\blankline")) - htMakeDoneButton('"Continue",'e02ddfColdGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'nxest,nxest) - htpSetProperty(page,'nyest,nyest) - htpSetProperty(page,'lwrk,lwrk) - htpSetProperty(page,'liwrk,liwrk) - htpSetProperty(page,'s,s) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02ddfColdGen htPage == - m := htpProperty(htPage,'m) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - cold := '"c" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - flist := [right,:flist] - wlist := [end,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - -- additional entries nx,ny,lamda,mu,wrk needed to get it running - -- but they are just set to 0.0 - prefix := STRCONC('"e02ddf(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") - prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,", 0,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,0,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") - prefix := STRCONC(prefix,"new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nxest,"]],0,") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nyest,"]],") --- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE lwrk,"]],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e02ddfWarmGen htPage == - m := htpProperty(htPage,'m) - nxest := htpProperty(htPage,'nxest) - nyest := htpProperty(htPage,'nyest) - lwrk := htpProperty(htPage,'lwrk) - liwrk := htpProperty(htPage,'liwrk) - s := htpProperty(htPage,'s) - warm := '"w" - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - wrk := (first y).1 - y := rest y - for i in 1..lwrk repeat - wrkList := ['"0.0 ",:wrkList] - wrkList := [wrk,:wrkList] - wrkstring := bcwords2liststring wrkList - ny := STRCONC((first y).1," ") - y := rest y - nx := STRCONC((first y).1," ") - y := rest y - for i in 1..nyest repeat - mu := STRCONC ((first y).1, " ") - y := rest y - muList := [mu,:muList] - mustring := bcwords2liststring muList - for i in 1..nxest repeat - lam := STRCONC ((first y).1, " ") - y := rest y - lamList := [lam,:lamList] - lamstring := bcwords2liststring lamList - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - right := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [mid,:ylist] - flist := [right,:flist] - wlist := [end,:wlist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - fstring := bcwords2liststring flist - wstring := bcwords2liststring wlist - -- additional entries nx,ny,lamda,mu,wrk needed to get it running - -- but they are just set to 0.0 - prefix := STRCONC('"e02ddf(_"",warm,"_",",STRINGIMAGE m,", [",xstring,"],[") - prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") - prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") - prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",nx,",[",lamstring,"],",ny) - prefix := STRCONC(prefix,",[",mustring,"],[",wrkstring,"],") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -e02zaf() == - htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe02zaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02zaf| '|NagFittingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Sorts the set of points {\em (\htbitmap{xr},") - (text . "\htbitmap{yr})} into panels defined by \space{1}") - (text . "\htbitmap{px} -8 points \htbitmap{lamdai} ") - (text . "on the x-axis and \space{1}\htbitmap{py}-8 points ") - (text . "\htbitmap{muj} on the y axis. The points are ordered ") - (text . "so that all points in a panel occur before data in succeeding ") - (text . "panels. Within a panel, the points maintain their original ") - (text . "order. ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Number of points to be sorted to be sorted {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 10 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Intercepts + 8 on x axis {\em px}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Intercepts + 8 on y axis {\em py}:") - (text . "\newline\tab{2} ") - (bcStrings (6 9 px PI)) - (text . "\tab{34} ") - (bcStrings (6 10 py PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} \newline ") - (text . "Dimension of point {\it npoint}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 45 npoint PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e02zafSolve) - htShowPage() - -e02zafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - px := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) - objValUnwrap htpLabelSpadValue(htPage, 'px) - py := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) - objValUnwrap htpLabelSpadValue(htPage, 'py) - npoint := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) - objValUnwrap htpLabelSpadValue(htPage, 'npoint) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '10 and px = '9) and py = '10) => e02zafDefaultSolve(htPage,npoint,ifail) - labelList := - "append"/[fxy(i) for i in 1..m] where fxy(i) == - prefix := ('"\newline \tab{2} ") - middle := ('"\tab{32} ") - lnam := INTERN STRCONC ('"x",STRINGIMAGE i) - cnam := INTERN STRCONC ('"y",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, lnam, 'F]], - ['text,:middle],['bcStrings,[8, 0.0, cnam, 'F]]] - lamList := - "append"/[flam(i) for i in 5..(px-4)] where flam(i) == - lnam := INTERN STRCONC ('"l",STRINGIMAGE i) - [['bcStrings,[8, 0.0, lnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(5) to ") - prefix := STRCONC(prefix,"\lambda(px-4)}: \newline \tab{2} ") - lamList := [['text,:prefix],:lamList] - muList := - "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE i) - [['bcStrings,[8, 0.0, mnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(5) to \mu(py-4)}: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - muList := [['text,:prefix],:muList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:lamList,:muList] - page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htSay '"\menuitemstyle{}\tab{2} {\it x(m)}: " - htSay '"\tab{30} \menuitemstyle{}\tab{32} {\it y(m)}: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'e02zafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e02zafDefaultSolve (htPage,npoint,ifail) == - m := '10 - px := '9 - py := '10 - page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} {\it x(m)}:") - (text . "\tab{30} \menuitemstyle{} \tab{32} {\it y(m)}:") - (text . "\newline \tab{2} ") - (bcStrings (8 "0.00" x1 F)) - (text . "\tab{32}") - (bcStrings (8 "0.77" y1 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.70" x2 F)) - (text . "\tab{32}") - (bcStrings (8 "1.06" y2 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.44" x3 F)) - (text . "\tab{32}") - (bcStrings (8 "0.33" y3 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.21" x4 F)) - (text . "\tab{32}") - (bcStrings (8 "0.44" y4 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.01" x5 F)) - (text . "\tab{32}") - (bcStrings (8 "0.50" y5 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.84" x6 F)) - (text . "\tab{32}") - (bcStrings (8 "0.02" y6 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.71" x7 F)) - (text . "\tab{32}") - (bcStrings (8 "1.95" y7 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.00" x8 F)) - (text . "\tab{32}") - (bcStrings (8 "1.20" y8 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "0.54" x9 F)) - (text . "\tab{32}") - (bcStrings (8 "0.04" y9 F)) - (text . "\newline \tab{2} ") - (bcStrings (8 "1.531" x10 F)) - (text . "\tab{32}") - (bcStrings (8 "0.18" y10 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \lambda(5) to \lambda(px-4)}:") - (text . "\newline \tab{2}") - (bcStrings (8 "1.00" l5 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it \mu(5) to \mu(py-4)}:") - (text . "\newline \tab{2}") - (bcStrings (8 "0.80" mu5 F)) - (bcStrings (8 "1.20" mu6 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'e02zafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'px,px) - htpSetProperty(page,'py,py) - htpSetProperty(page,'npoint,npoint) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e02zafGen htPage == - m := htpProperty(htPage,'m) - px := htpProperty(htPage,'px) - py := htpProperty(htPage,'py) - npoint := htpProperty(htPage,'npoint) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - nadres := (px-7)*(py-7) - -- mu - for i in 1..4 repeat - muList := ['"0 ",:muList] - for i in 5..(py-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - muList := [right,:muList] - for i in (py-3)..py repeat - muList := ['"0 ",:muList] - mustring := bcwords2liststring muList - -- lamda - for i in 1..4 repeat - lamList := ['"0 ",:lamList] - for i in 5..(px-4) repeat - right := STRCONC ((first y).1," ") - y := rest y - lamList := [right,:lamList] - for i in (px-3)..px repeat - lamList := ['"0 ",:lamList] - lamstring := bcwords2liststring lamList - -- x & y - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - left := STRCONC ((first y).1," ") - y := rest y - xlist := [left,:xlist] - ylist := [right,:ylist] - xstring := bcwords2liststring xlist - ystring := bcwords2liststring ylist - prefix := STRCONC('"e02zaf(",STRINGIMAGE px,", ",STRINGIMAGE py,",[") - prefix := STRCONC(prefix,lamstring,"],[",mustring,"], ",STRINGIMAGE m,", [") - prefix := STRCONC(prefix,xstring,"],[",ystring,"], ",STRINGIMAGE npoint,", ") - prefix := STRCONC(prefix,STRINGIMAGE nadres,", ",STRINGIMAGE ifail,")") - linkGen prefix - - - diff --git a/src/interp/nag-e02b.boot.pamphlet b/src/interp/nag-e02b.boot.pamphlet new file mode 100644 index 00000000..d9874717 --- /dev/null +++ b/src/interp/nag-e02b.boot.pamphlet @@ -0,0 +1,1757 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-e02b.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- READ THIS NOW! +-- +-- The automatic make fails to compile this file properly, leaving a +-- truncated clisp file in int/interp. So if you change this file it +-- must be compiled by hand in the interpreter (which works fine). +-- MCD. +-- + +e02daf() == + htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02daf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02daf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Determines a minimal, least squares bicubic B-spline surface fit") + (text . "\htbitmap{e02daf} to the set of points ") + (text . "{\em (\htbitmap{xr},\htbitmap{yr},\htbitmap{fr})} with weights ") + (text . "\htbitmap{wr}, for r = 1,2,...,m. The user must supply internal ") + (text . "knot sets {\lambda},in the x-direction and {\mu} in the ") + (text . "y-direction, ") + (text . "which can be thought of as dividing the data region into panels;") + (text . "s(x,y) consists of a seperate bicubic polynomial in each panel, ") + (text . "the polynomial joining together with second derivative ") + (text . "continuity. Eight additional (external) knots are added to each ") + (text . "of the knot sets by this routine. The routine minimizes \Sigma, ") + (text . "the sum of squares of the weighted residuals ") + (text . "\htbitmap{e02daf1}, for r = 1,2,...,m, subject to the ") + (text . "given knot sets. \newline ") + (text . "A call of this routine should be preceded by a call of E02ZAF ") + (text . "to provide indexing information. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Knots in x direction {\em px}") + (text . "\htbitmap{great=} 8: \tab{32} \menuitemstyle{}\tab{34}") + (text . "Knots in y direction {\em py}:") + (text . "\newline\tab{2} ") + (bcStrings (6 8 px PI)) + (text . "\tab{34} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Rank threshold {\em eps}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.000001" eps F)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Dimension of point {\it npoint}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 43 npoint PI)) + -- include a radio button later to allow switching of + -- x & y if px <= py + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02dafSolve) + htShowPage() + +e02dafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + npoint := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) + objValUnwrap htpLabelSpadValue(htPage, 'npoint) + nc := (px - 4)*(py - 4) + nws := (2*nc + 1)*(3*py - 6) -2 + eps := htpLabelInputString(htPage,'eps) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '30 and px = '8) and py = '10) => e02dafDefaultSolve(htPage,eps,nws,npoint,ifail) + labelList := + "append"/[fxy(i) for i in 1..m] where fxy(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + next := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:next],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + lamList := + "append"/[flam(i) for i in 5..(px-4)] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} lamda(5) to lamda(px-4): ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + postfix := ('"\newline \blankline ") + lamList := [['text,:prefix],:lamList,['text,:postfix]] + muList := + "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\menuitemstyle{} \tab{2} mu(5) to mu(py-4):") + prefix := STRCONC(prefix,"\newline \tab{2} ") + muList := [['text,:prefix],:muList] + pList := + "append"/[fp(i) for i in 1..npoint] where fp(i) == + prefix := ('"\newline \tab{2} ") + pnam := INTERN STRCONC ('"p",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, pnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Enter values of Point: ") + pList := [['text,:prefix],:pList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamList,:muList,:pList] + page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \htbitmap{xr}: " + htSay '"\tab{15} \menuitemstyle{}\tab{17} Values of \htbitmap{yr}:" + htSay '"\tab{30} \menuitemstyle{}\tab{32} Values of \htbitmap{fr}:" + htSay '"\tab{44} \menuitemstyle{}\tab{46} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02dafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'nws,nws) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02dafDefaultSolve (htPage,eps,nws,npoint,ifail) == + m := '30 + px := '8 + py := '10 + page := htInitPage('"E02DAF - Least-squares surface fit, bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") + (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") + (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") + (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") + (text . "\tab{46} Values of \htbitmap{wr}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.52" x1 F)) + (text . "\tab{17}") + (bcStrings (8 "0.60" y1 F)) + (text . "\tab{32}") + (bcStrings (8 "0.93" f1 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.61" x2 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.95" y2 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.79" f2 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.93" x3 F)) + (text . "\tab{17}") + (bcStrings (8 "0.87" y3 F)) + (text . "\tab{32}") + (bcStrings (8 "0.36" f3 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.09" x4 F)) + (text . "\tab{17}") + (bcStrings (8 "0.84" y4 F)) + (text . "\tab{32}") + (bcStrings (8 "0.52" f4 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.88" x5 F)) + (text . "\tab{17}") + (bcStrings (8 "0.17" y5 F)) + (text . "\tab{32}") + (bcStrings (8 "0.49" f5 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.70" x6 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.87" y6 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.76" f6 F)) + (text . "\tab{47}") + (bcStrings (8 "10" w6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1" x7 F)) + (text . "\tab{17}") + (bcStrings (8 "1" y7 F)) + (text . "\tab{32}") + (bcStrings (8 "0.33" f7 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1" x8 F)) + (text . "\tab{17}") + (bcStrings (8 "0.1" y8 F)) + (text . "\tab{32}") + (bcStrings (8 "0.48" f8 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.3" x9 F)) + (text . "\tab{17}") + (bcStrings (8 "0.24" y9 F)) + (text . "\tab{32}") + (bcStrings (8 "0.65" f9 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.77" x10 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.77" y10 F)) + (text . "\tab{32}") + (bcStrings (8 "-1.82" f10 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w10 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.23" x11 F)) + (text . "\tab{17}") + (bcStrings (8 "0.32" y11 F)) + (text . "\tab{32}") + (bcStrings (8 "0.92" f11 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w11 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-1" x12 F)) + (text . "\tab{17}") + (bcStrings (8 "1" y12 F)) + (text . "\tab{32}") + (bcStrings (8 "1" f12 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w12 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.26" x13 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.63" y13 F)) + (text . "\tab{32}") + (bcStrings (8 "8.88" f13 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w13 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.83" x14 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.66" y14 F)) + (text . "\tab{32}") + (bcStrings (8 "-2.01" f14 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w14 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.22" x15 F)) + (text . "\tab{17}") + (bcStrings (8 "0.93" y15 F)) + (text . "\tab{32}") + (bcStrings (8 "0.47" f15 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w15 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.89" x16 F)) + (text . "\tab{17}") + (bcStrings (8 "0.15" y16 F)) + (text . "\tab{32}") + (bcStrings (8 "0.49" f16 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w16 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.80" x17 F)) + (text . "\tab{17}") + (bcStrings (8 "0.99" y17 F)) + (text . "\tab{32}") + (bcStrings (8 "0.84" f17 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w17 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.88" x18 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.54" y18 F)) + (text . "\tab{32}") + (bcStrings (8 "-2.42" f18 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w18 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.68" x19 F)) + (text . "\tab{17}") + (bcStrings (8 "0.44" y19 F)) + (text . "\tab{32}") + (bcStrings (8 "0.47" f19 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w19 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.14" x20 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.72" y20 F)) + (text . "\tab{32}") + (bcStrings (8 "7.15" f20 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w20 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.67" x21 F)) + (text . "\tab{17}") + (bcStrings (8 "0.63" y21 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" f21 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w21 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.90" x22 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.40" y22 F)) + (text . "\tab{32}") + (bcStrings (8 "-3.34" f22 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w22 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.84" x23 F)) + (text . "\tab{17}") + (bcStrings (8 "0.20" y23 F)) + (text . "\tab{32}") + (bcStrings (8 "2.78" f23 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w23 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.84" x24 F)) + (text . "\tab{17}") + (bcStrings (8 "0.43" y24 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" f24 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w24 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.15" x25 F)) + (text . "\tab{17}") + (bcStrings (8 "0.28" y25 F)) + (text . "\tab{32}") + (bcStrings (8 "0.70" f25 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w25 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.91" x26 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.24" y26 F)) + (text . "\tab{32}") + (bcStrings (8 "-6.52" f26 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w26 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.35" x27 F)) + (text . "\tab{17}") + (bcStrings (8 "0.86" y27 F)) + (text . "\tab{32}") + (bcStrings (8 "0.66" f27 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w27 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.16" x28 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.41" y28 F)) + (text . "\tab{32}") + (bcStrings (8 "2.32" f28 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w28 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-0.35" x29 F)) + (text . "\tab{17}") + (bcStrings (8 "-0.05" y29 F)) + (text . "\tab{32}") + (bcStrings (8 "1.66" f29 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w29 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "-1" x30 F)) + (text . "\tab{17}") + (bcStrings (8 "-1" y30 F)) + (text . "\tab{32}") + (bcStrings (8 "-1" f30 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w30 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} mu(5) to mu(py-4):") + (text . "\newline \tab{2}") + (bcStrings (8 "-0.50" mu5 F)) + (bcStrings (8 "0.00" mu6 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values for point:") + (text . "\newline \tab{2}") + (bcStrings (6 3 p1 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 6 p2 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 4 p3 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 5 p4 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 7 p5 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 10 p6 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 8 p7 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 9 p8 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 11 p9 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 13 p10 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 12 p11 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 15 p12 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 14 p13 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 18 p14 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 16 p15 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 17 p16 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 19 p17 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 20 p18 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 21 p19 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 30 p20 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 23 p21 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 26 p22 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 24 p23 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 25 p24 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 27 p25 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 28 p26 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p27 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 29 p28 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p29 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p30 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 2 p31 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 22 p32 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 1 p33 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p34 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p35 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p36 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p37 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p38 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p39 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p40 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p41 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p42 PI)) + (text . "\newline \tab{2}") + (bcStrings (6 0 p43 PI)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02dafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'nws,nws) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02dafGen htPage == + m := htpProperty(htPage,'m) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + nws := htpProperty(htPage,'nws) + eps := htpProperty(htPage,'eps) + npoint := htpProperty(htPage,'npoint) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + nadres := (px-7)*(py-7) + -- point + for i in 1..npoint repeat + right := STRCONC ((first y).1," ") + y := rest y + pointList := [right,:pointList] + pstring := bcwords2liststring pointList + -- mu + for i in 1..4 repeat + muList := ['"0 ",:muList] + for i in 5..(py-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + for i in (py-3)..py repeat + muList := ['"0 ",:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..4 repeat + lamList := ['"0 ",:lamList] + for i in 5..(px-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + for i in (px-3)..px repeat + lamList := ['"0 ",:lamList] + lamstring := bcwords2liststring lamList + -- x & y + while y repeat + one := STRCONC((first y).1," ") + y := rest y + two := STRCONC((first y).1," ") + y := rest y + three := STRCONC ((first y).1," ") + y := rest y + four := STRCONC ((first y).1," ") + y := rest y + xlist := [four,:xlist] + ylist := [three,:ylist] + flist := [two,:flist] + wlist := [one,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + nc := (px-4)*(py-4) + prefix := STRCONC('"e02daf(",STRINGIMAGE m,", ",STRINGIMAGE px,", ") + prefix := STRCONC(prefix,STRINGIMAGE py,",[",xstring,"],[",ystring,"],[") + prefix := STRCONC(prefix,fstring,"],[",wstring,"],[",mustring,"],[") + prefix := STRCONC(prefix,pstring,"], ",STRINGIMAGE npoint,", ") + prefix := STRCONC(prefix,STRINGIMAGE nc,", ",STRINGIMAGE nws,", ",eps,", [") + prefix := STRCONC(prefix,lamstring,"], ",STRINGIMAGE ifail,")") + linkGen prefix + + +e02dcf() == + htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02dcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02dcf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Determines a bicubic spline approximation to a set of points ") + (text . "given on a rectangular grid defined by \htbitmap{mx} ") + (text . "points \htbitmap{xq} on the x-axis and ") + (text . "\htbitmap{my} points \htbitmap{yr} on the ") + (text . "y-axix. The knots \htbitmap{lamdai}, for i = 1,2,...,") + (text . "\htbitmap{nx} and \htbitmap{mui}, for ") + (text . "i = 1,2,...,\htbitmap{ny} are chosen for this routine ") + (text . ", but a single parameter S must be specified to control the ") + (text . "trade-off between closeness of fit and smoothness of fit. This ") + (text . "affects the number of knots required by the spline, which is ") + (text . "given in the B-spline representation \htbitmap{e02daf}") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Grid points on x-axis \htbitmap{mx}: ") + (text . "\tab{30} \menuitemstyle{}\tab{32} Grid points on y-axis ") + (text . "\htbitmap{my}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 11 mx PI)) + (text . "\tab{32} ") + (bcStrings (6 9 my PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") + (text . "computed spline, {\it nxest}: \newline\tab{2} ") + (bcStrings (6 15 nxest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") + (text . "spline, {\it nyest}: \newline\tab{2} ") + (bcStrings (6 13 nyest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Smoothing factor {\it s}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "0.1" s F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Start value: ") + (radioButtons start + ("" " Cold Start - no values needed for {\it nx,ny,lamda,mu} or {\it iwrk}" cold) + ("" " Warm Start - uses knots found in a previous call" warm)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02dcfSolve) + htShowPage() + +e02dcfSolve htPage == + mx := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'mx) + objValUnwrap htpLabelSpadValue(htPage, 'mx) + my := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'my) + objValUnwrap htpLabelSpadValue(htPage, 'my) + nxest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) + objValUnwrap htpLabelSpadValue(htPage, 'nxest) + nyest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) + objValUnwrap htpLabelSpadValue(htPage, 'nyest) + wrklist := [my,nxest] + wrkmax := APPLY ('MAX, wrklist) + lwrk := 4*(mx + my) +11*(nxest + nyest) + nxest*my + wrkmax +54 + liwrk := 3 + mx + my + nxest + nyest + s := htpLabelInputString(htPage,'s) + initial := htpButtonValue(htPage,'start) + start := + initial = 'cold => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((mx = 11 and my = 9) and start = 1) => + e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) + start = 1 => e02dcfColdSolve (htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) + -- warm start not really possible from hyperdoc + -- as inputing a workspace array of dimension 592 is asking too much + -- user should use the command line, using the previous calculated + -- parameters + htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\blankline ") + (text . "{\center{\em Hyperdoc interface not available for warm starts.}}") + (text . "\newline ") + (text . "{\center{\em Please use the command line.}}")) + htMakeDoneButton('"Continue",'e02dcf) + htShowPage() + + + +e02dcfColdSolve(htPage,mx,my,nxest,nyest,lwrk,liwrk,s,ifail) == + xList := + "append"/[f(i) for i in 1..mx] where f(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, 0.0, xnam, 'F]]] + yList := + "append"/[g(i) for i in 1..my] where g(i) == + ynam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['bcStrings,[8, 0.0, ynam, 'F]]] + prefix:= ('"\blankline \menuitemstyle{}\tab{2} Values of {\it y(my)}: \newline ") + yList := [['text,:prefix],:yList] + fList := + "append"/[h(i) for i in 1..(mx*my)] where h(i) == + fnam := INTERN STRCONC ('"g",STRINGIMAGE i) + [['bcStrings,[8, 0.0, fnam, 'F]]] + prefix:=('"\blankline \menuitemstyle{} \tab{2} Values of {\it f(mx*my)}: \newline ") + fList := [['text,:prefix],:fList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :xList,:yList,:fList] + page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htSay '"\menuitemstyle{}\tab{2} Values of {\it x(mx)}: \newline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02dcfColdGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02dcfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == + mx := 11 + my := 9 + page := htInitPage('"E02DCF - Least-squares curve by bicubic splines with automatic knot placement, data on a rectangular grid",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it x(mx)}:") + (text . "\newline ") + (bcStrings (8 "0" x1 F)) + (bcStrings (8 "0.5" x2 F)) + (bcStrings (8 "1" x3 F)) + (bcStrings (8 "1.5" x4 F)) + (bcStrings (8 "2" x5 F)) + (bcStrings (8 "2.5" x6 F)) + (bcStrings (8 "3" x7 F)) + (bcStrings (8 "3.5" x8 F)) + (bcStrings (8 "4" x9 F)) + (bcStrings (8 "4.5" x10 F)) + (bcStrings (8 "5" x11 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it y(my)}:") + (text . "\newline ") + (bcStrings (8 "0" y1 F)) + (bcStrings (8 "0.5" y2 F)) + (bcStrings (8 "1" y3 F)) + (bcStrings (8 "1.5" y4 F)) + (bcStrings (8 "2" y5 F)) + (bcStrings (8 "2.5" y6 F)) + (bcStrings (8 "3" y7 F)) + (bcStrings (8 "3.5" y8 F)) + (bcStrings (8 "4" y9 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Values of {\it f(mx*my)}:") + (text . "\newline ") + (bcStrings (8 "1" f1 F)) + (bcStrings (8 "0.88758" f2 F)) + (bcStrings (8 "0.5403" f3 F)) + (bcStrings (8 "0.070737" f4 F)) + (bcStrings (8 "-0.41515" f5 F)) + (bcStrings (8 "-0.80114" f6 F)) + (bcStrings (8 "-0.97999" f7 F)) + (bcStrings (8 "-0.93446" f8 F)) + (bcStrings (8 "-0.65664" f9 F)) + (bcStrings (8 "1.5" f10 F)) + (bcStrings (8 "1.3564" f11 F)) + (bcStrings (8 "0.82045" f12 F)) + (bcStrings (8 "0.10611" f13 F)) + (bcStrings (8 "-0.62422" f14 F)) + (bcStrings (8 "-1.2317" f15 F)) + (bcStrings (8 "-1.485" f16 F)) + (bcStrings (8 "-1.3047" f17 F)) + (bcStrings (8 "-0.98547" f18 F)) + (bcStrings (8 "2.06" f19 F)) + (bcStrings (8 "1.7552" f20 F)) + (bcStrings (8 "1.0806" f21 F)) + (bcStrings (8 "0.15147" f22 F)) + (bcStrings (8 "-0.83229" f23 F)) + (bcStrings (8 "-1.6023" f24 F)) + (bcStrings (8 "-1.97" f25 F)) + (bcStrings (8 "-1.8729" f26 F)) + (bcStrings (8 "-1.4073" f27 F)) + (bcStrings (8 "2.57" f28 F)) + (bcStrings (8 "2.124" f29 F)) + (bcStrings (8 "1.3508" f30 F)) + (bcStrings (8 "0.17684" f31 F)) + (bcStrings (8 "-1.0404" f32 F)) + (bcStrings (8 "-2.0029" f33 F)) + (bcStrings (8 "-2.475" f34 F)) + (bcStrings (8 "-2.3511" f35 F)) + (bcStrings (8 "-1.6741" f36 F)) + (bcStrings (8 "3" f37 F)) + (bcStrings (8 "2.6427" f38 F)) + (bcStrings (8 "1.6309" f39 F)) + (bcStrings (8 "0.21221" f40 F)) + (bcStrings (8 "-1.2484" f41 F)) + (bcStrings (8 "-2.2034" f42 F)) + (bcStrings (8 "-2.97" f43 F)) + (bcStrings (8 "-2.8094" f44 F)) + (bcStrings (8 "-1.9809" f45 F)) + (bcStrings (8 "3.5" f46 F)) + (bcStrings (8 "3.1715" f47 F)) + (bcStrings (8 "1.8611" f48 F)) + (bcStrings (8 "0.24458" f49 F)) + (bcStrings (8 "-1.4565" f50 F)) + (bcStrings (8 "-2.864" f51 F)) + (bcStrings (8 "-3.265" f52 F)) + (bcStrings (8 "-3.2776" f53 F)) + (bcStrings (8 "-2.2878" f54 F)) + (bcStrings (8 "4.04" f55 F)) + (bcStrings (8 "3.5103" f56 F)) + (bcStrings (8 "2.0612" f57 F)) + (bcStrings (8 "0.28595" f58 F)) + (bcStrings (8 "-1.6946" f59 F)) + (bcStrings (8 "-3.2046" f60 F)) + (bcStrings (8 "-3.96" f61 F)) + (bcStrings (8 "-3.7958" f62 F)) + (bcStrings (8 "-2.6146" f63 F)) + (bcStrings (8 "4.5" f64 F)) + (bcStrings (8 "3.9391" f65 F)) + (bcStrings (8 "2.4314" f66 F)) + (bcStrings (8 "0.31632" f67 F)) + (bcStrings (8 "-1.8627" f68 F)) + (bcStrings (8 "-3.6351" f69 F)) + (bcStrings (8 "-4.455" f70 F)) + (bcStrings (8 "-4.2141" f71 F)) + (bcStrings (8 "-2.9314" f72 F)) + (bcStrings (8 "5.04" f73 F)) + (bcStrings (8 "4.3879" f74 F)) + (bcStrings (8 "2.7515" f75 F)) + (bcStrings (8 "0.35369" f76 F)) + (bcStrings (8 "-2.0707" f77 F)) + (bcStrings (8 "-4.0057" f78 F)) + (bcStrings (8 "-4.97" f79 F)) + (bcStrings (8 "-4.6823" f80 F)) + (bcStrings (8 "-3.2382" f81 F)) + (bcStrings (8 "5.505" f82 F)) + (bcStrings (8 "4.8367" f83 F)) + (bcStrings (8 "2.9717" f84 F)) + (bcStrings (8 "0.38505" f85 F)) + (bcStrings (8 "-2.2888" f86 F)) + (bcStrings (8 "-4.4033" f87 F)) + (bcStrings (8 "-5.445" f88 F)) + (bcStrings (8 "-5.1405" f89 F)) + (bcStrings (8 "-3.595" f90 F)) + (bcStrings (8 "6" f91 F)) + (bcStrings (8 "5.2755" f92 F)) + (bcStrings (8 "3.2418" f93 F)) + (bcStrings (8 "0.42442" f94 F)) + (bcStrings (8 "-2.4769" f95 F)) + (bcStrings (8 "-4.8169" f96 F)) + (bcStrings (8 "-5.93" f97 F)) + (bcStrings (8 "-5.6387" f98 F)) + (bcStrings (8 "-3.9319" f99 F))) + htMakeDoneButton('"Continue",'e02dcfColdGen) + htpSetProperty(page,'mx,mx) + htpSetProperty(page,'my,my) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02dcfColdGen htPage == + mx := htpProperty(htPage,'mx) + my := htpProperty(htPage,'my) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + cold := '"c" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(mx*my) repeat + end := STRCONC((first y).1," ") + y := rest y + fList := [end,:fList] + fstring := bcwords2liststring fList + for i in 1..my repeat + mid := STRCONC ((first y).1," ") + y := rest y + ylist := [mid,:ylist] + ystring := bcwords2liststring ylist + while y repeat + start := STRCONC ((first y).1," ") + y := rest y + xlist := [start,:xlist] + xstring := bcwords2liststring xlist + -- additional entries needed to get it running + -- but as Start = c they are not used + prefix := STRCONC('"e02dcf(_"",cold,"_",",STRINGIMAGE mx,", [",xstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE my,",[",ystring,"],[",fstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,",0,new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,") + prefix := STRCONC(prefix,"0,new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") + end := STRCONC("new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,[[0 for i in 1..") + end := STRCONC(end,STRINGIMAGE liwrk,"]]::Matrix Integer,",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,end) + + +e02ddf() == + htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02ddf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02ddf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Determines a bicubic spline approximation to a set of scattered") + (text . " points ( \htbitmap{xr},\htbitmap{yr}, ") + (text . "\htbitmap{fr})") + (text . "with weights \htbitmap{wr}, for r = 1,2,...,m. ") + (text . "The knots \htbitmap{lamdai}, for i = 1,2,...,") + (text . "\htbitmap{nx} and \htbitmap{mui}, for ") + (text . "i = 1,2,...,\htbitmap{ny} are chosen by the routine ") + (text . ", but a single parameter S must be specified to control the ") + (text . "trade-off between closeness of fit and smoothness of fit. This ") + (text . "affects the number of knots required by the spline, which is ") + (text . "given in the B-spline representation \htbitmap{e02daf}") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of data points {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 30 m PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{nx} of knots \lambda of the ") + (text . "computed spline, {\it nxest}: \newline\tab{2} ") + (bcStrings (6 14 nxest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Over-estimate of \htbitmap{ny} of knots \mu of the computed ") + (text . "spline, {\it nyest}: \newline\tab{2} ") + (bcStrings (6 14 nyest PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Smoothing factor {\it s}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 "10" s F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Start value: ") + (radioButtons start + ("" " Cold Start - no values needed for {\it nx,ny,lamda,wrk,iwrk}" cold) + ("" " Warm Start - uses knots found in a previous call" warm)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02ddfSolve) + htShowPage() + +e02ddfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + nxest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nxest) + objValUnwrap htpLabelSpadValue(htPage, 'nxest) + nyest := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nyest) + objValUnwrap htpLabelSpadValue(htPage, 'nyest) + u := nxest - 4 + v := nyest - 4 + wlist := [u,v] + w := APPLY ('MAX, wlist) + lwrk := (7*u*v + 25*w)*(w + 1) + 2*(u + v + 4*m) + 23*w + 56 + liwrk := m + 2*(nxest - 7)*(nyest - 7) + s := htpLabelInputString(htPage,'s) + initial := htpButtonValue(htPage,'start) + start := + initial = 'cold => '1 + '2 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = 30 and start = 1) => e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) + start = 1 => e02ddfColdSolve (htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) + -- need to change as only wrk(1) is required + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + post := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + lamdaList := + "append"/[g(i) for i in 1..nxest] where g(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Lamda: \newline") + lamdaList := [['text,:prefix],:lamdaList] + muList := + "append"/[h(i) for i in 1..nyest] where h(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Values of Mu: \newline") + muList := [['text,:prefix],:muList] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of nx: \newline \tab{2}") + nxList := [['text,:prefix],['bcStrings,[8, 10, 'nx, 'PI]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of ny: \newline \tab{2}") + nyList := [['text,:prefix],['bcStrings,[8, 9, 'ny, 'PI]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} Value of WRK(1): \newline \tab{2}") + wList := [['text,:prefix],['bcStrings,[8, 0.0, 'wone, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamdaList,:muList,:nxList,:nyList,:wList] + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" + htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " + htSay '"\htbitmap{fr}: \tab{45} \menuitemstyle{} " + htSay '"\tab{47} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ddfWarmGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + + +e02ddfColdSolve(htPage,m,nxest,nyest,lwrk,liwrk,s,ifail) == + labelList := + "append"/[f(i) for i in 1..m] where f(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{17} ") + post := ('"\tab{32} ") + end := ('"\tab{47} ") + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ynam := INTERN STRCONC ('"y",STRINGIMAGE i) + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + wnam := INTERN STRCONC ('"w",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, xnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, ynam, 'F]], + ['text,:post],['bcStrings,[8, 0.0, fnam, 'F]], + ['text,:end],['bcStrings,[8, 0.0, wnam, 'F]]] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList] + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htSay '"\menuitemstyle{}\tab{2} Values of \space{1} " + htSay '"\htbitmap{xr}: \tab{15} \menuitemstyle{}\tab{17} " + htSay '"Values of \space{1} \htbitmap{yr}: \tab{30}" + htSay '"\menuitemstyle{}\tab{32} Values of \space{1} " + htSay '"\htbitmap{fr}: \tab{44} \menuitemstyle{} " + htSay '"\tab{46} Values of \htbitmap{wr}:" + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02ddfColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02ddfDefaultSolve (htPage,nxest,nyest,lwrk,liwrk,s,ifail) == + m := 30 + page := htInitPage('"E02DDF - Least-squares surface fit by bicubic splines with automatic knot placement, scattered data",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Values of \htbitmap{xr}:") + (text . "\tab{15} \menuitemstyle{} \tab{17} Values of ") + (text . "\htbitmap{yr}: \tab{30} \menuitemstyle{} \tab{32} ") + (text . "Values of \htbitmap{fr}: \tab{44} \menuitemstyle{} ") + (text . "\tab{46} Values of \htbitmap{wr}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "11.16" x1 F)) + (text . "\tab{17}") + (bcStrings (8 "1.24" y1 F)) + (text . "\tab{32}") + (bcStrings (8 "22.15" f1 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "12.85" x2 F)) + (text . "\tab{17}") + (bcStrings (8 "3.06" y2 F)) + (text . "\tab{32}") + (bcStrings (8 "22.11" f2 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "19.85" x3 F)) + (text . "\tab{17}") + (bcStrings (8 "10.72" y3 F)) + (text . "\tab{32}") + (bcStrings (8 "7.97" f3 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "19.72" x4 F)) + (text . "\tab{17}") + (bcStrings (8 "1.39" y4 F)) + (text . "\tab{32}") + (bcStrings (8 "16.83" f4 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "15.91" x5 F)) + (text . "\tab{17}") + (bcStrings (8 "7.74" y5 F)) + (text . "\tab{32}") + (bcStrings (8 "15.30" f5 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0" x6 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y6 F)) + (text . "\tab{32}") + (bcStrings (8 "34.6" f6 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "20.87" x7 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y7 F)) + (text . "\tab{32}") + (bcStrings (8 "5.74" f7 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "3.45" x8 F)) + (text . "\tab{17}") + (bcStrings (8 "12.78" y8 F)) + (text . "\tab{32}") + (bcStrings (8 "41.24" f8 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "14.26" x9 F)) + (text . "\tab{17}") + (bcStrings (8 "17.87" y9 F)) + (text . "\tab{32}") + (bcStrings (8 "10.74" f9 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.43" x10 F)) + (text . "\tab{17}") + (bcStrings (8 "3.46" y10 F)) + (text . "\tab{32}") + (bcStrings (8 "18.60" f10 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w10 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.8" x11 F)) + (text . "\tab{17}") + (bcStrings (8 "12.39" y11 F)) + (text . "\tab{32}") + (bcStrings (8 "5.47" f11 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w11 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "7.58" x12 F)) + (text . "\tab{17}") + (bcStrings (8 "1.98" y12 F)) + (text . "\tab{32}") + (bcStrings (8 "29.87" f12 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w12 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "25" x13 F)) + (text . "\tab{17}") + (bcStrings (8 "11.87" y13 F)) + (text . "\tab{32}") + (bcStrings (8 "4.4" f13 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w13 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0" x14 F)) + (text . "\tab{17}") + (bcStrings (8 "0" y14 F)) + (text . "\tab{32}") + (bcStrings (8 "58.2" f14 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w14 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "9.66" x15 F)) + (text . "\tab{17}") + (bcStrings (8 "20" y15 F)) + (text . "\tab{32}") + (bcStrings (8 "4.73" f15 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w15 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "5.22" x16 F)) + (text . "\tab{17}") + (bcStrings (8 "14.66" y16 F)) + (text . "\tab{32}") + (bcStrings (8 "40.36" f16 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w16 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.25" x17 F)) + (text . "\tab{17}") + (bcStrings (8 "19.57" y17 F)) + (text . "\tab{32}") + (bcStrings (8 "6.43" f17 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w17 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "25" x18 F)) + (text . "\tab{17}") + (bcStrings (8 "3.87" y18 F)) + (text . "\tab{32}") + (bcStrings (8 "8.74" f18 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w18 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "12.13" x19 F)) + (text . "\tab{17}") + (bcStrings (8 "10.79" y19 F)) + (text . "\tab{32}") + (bcStrings (8 "13.71" f19 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w19 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.23" x20 F)) + (text . "\tab{17}") + (bcStrings (8 "6.21" y20 F)) + (text . "\tab{32}") + (bcStrings (8 "10.25" f20 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w20 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "11.52" x21 F)) + (text . "\tab{17}") + (bcStrings (8 "8.53" y21 F)) + (text . "\tab{32}") + (bcStrings (8 "15.74" f21 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w21 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "15.2" x22 F)) + (text . "\tab{17}") + (bcStrings (8 "0" y22 F)) + (text . "\tab{32}") + (bcStrings (8 "21.6" f22 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w22 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "7.54" x23 F)) + (text . "\tab{17}") + (bcStrings (8 "10.69" y23 F)) + (text . "\tab{32}") + (bcStrings (8 "19.31" f23 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w23 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "17.32" x24 F)) + (text . "\tab{17}") + (bcStrings (8 "13.78" y24 F)) + (text . "\tab{32}") + (bcStrings (8 "12.11" f24 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w24 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "2.14" x25 F)) + (text . "\tab{17}") + (bcStrings (8 "15.03" y25 F)) + (text . "\tab{32}") + (bcStrings (8 "53.1" f25 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w25 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.51" x26 F)) + (text . "\tab{17}") + (bcStrings (8 "8.37" y26 F)) + (text . "\tab{32}") + (bcStrings (8 "49.43" f26 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w26 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "22.69" x27 F)) + (text . "\tab{17}") + (bcStrings (8 "19.63" y27 F)) + (text . "\tab{32}") + (bcStrings (8 "3.25" f27 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w27 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "5.47" x28 F)) + (text . "\tab{17}") + (bcStrings (8 "17.13" y28 F)) + (text . "\tab{32}") + (bcStrings (8 "28.63" f28 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w28 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "21.67" x29 F)) + (text . "\tab{17}") + (bcStrings (8 "14.36" y29 F)) + (text . "\tab{32}") + (bcStrings (8 "5.52" f29 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w29 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "3.31" x30 F)) + (text . "\tab{17}") + (bcStrings (8 "0.33" y30 F)) + (text . "\tab{32}") + (bcStrings (8 "44.08" f30 F)) + (text . "\tab{47}") + (bcStrings (8 "1" w30 F)) + (text . "\blankline")) + htMakeDoneButton('"Continue",'e02ddfColdGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'nxest,nxest) + htpSetProperty(page,'nyest,nyest) + htpSetProperty(page,'lwrk,lwrk) + htpSetProperty(page,'liwrk,liwrk) + htpSetProperty(page,'s,s) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02ddfColdGen htPage == + m := htpProperty(htPage,'m) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + cold := '"c" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + flist := [right,:flist] + wlist := [end,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + -- additional entries nx,ny,lamda,mu,wrk needed to get it running + -- but they are just set to 0.0 + prefix := STRCONC('"e02ddf(_"",cold,"_",",STRINGIMAGE m,", [",xstring,"],[") + prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,", 0,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nxest,",0.0)$MATRIX DFLOAT,0,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE nyest,",0.0)$MATRIX DFLOAT,") + prefix := STRCONC(prefix,"new(1,", STRINGIMAGE lwrk,",0.0)$MATRIX DFLOAT,") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nxest,"]],0,") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE nyest,"]],") +-- prefix := STRCONC(prefix,"[[0.0 for i in 1..", STRINGIMAGE lwrk,"]],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e02ddfWarmGen htPage == + m := htpProperty(htPage,'m) + nxest := htpProperty(htPage,'nxest) + nyest := htpProperty(htPage,'nyest) + lwrk := htpProperty(htPage,'lwrk) + liwrk := htpProperty(htPage,'liwrk) + s := htpProperty(htPage,'s) + warm := '"w" + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + wrk := (first y).1 + y := rest y + for i in 1..lwrk repeat + wrkList := ['"0.0 ",:wrkList] + wrkList := [wrk,:wrkList] + wrkstring := bcwords2liststring wrkList + ny := STRCONC((first y).1," ") + y := rest y + nx := STRCONC((first y).1," ") + y := rest y + for i in 1..nyest repeat + mu := STRCONC ((first y).1, " ") + y := rest y + muList := [mu,:muList] + mustring := bcwords2liststring muList + for i in 1..nxest repeat + lam := STRCONC ((first y).1, " ") + y := rest y + lamList := [lam,:lamList] + lamstring := bcwords2liststring lamList + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + right := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [mid,:ylist] + flist := [right,:flist] + wlist := [end,:wlist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + fstring := bcwords2liststring flist + wstring := bcwords2liststring wlist + -- additional entries nx,ny,lamda,mu,wrk needed to get it running + -- but they are just set to 0.0 + prefix := STRCONC('"e02ddf(_"",warm,"_",",STRINGIMAGE m,", [",xstring,"],[") + prefix := STRCONC(prefix,ystring,"],[",fstring,"],[",wstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE s,", ",STRINGIMAGE nxest,", ") + prefix := STRCONC(prefix,STRINGIMAGE nyest,", ",STRINGIMAGE lwrk,", ") + prefix := STRCONC(prefix,STRINGIMAGE liwrk,", ",nx,",[",lamstring,"],",ny) + prefix := STRCONC(prefix,",[",mustring,"],[",wrkstring,"],") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +e02zaf() == + htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe02zaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e02zaf| '|NagFittingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Sorts the set of points {\em (\htbitmap{xr},") + (text . "\htbitmap{yr})} into panels defined by \space{1}") + (text . "\htbitmap{px} -8 points \htbitmap{lamdai} ") + (text . "on the x-axis and \space{1}\htbitmap{py}-8 points ") + (text . "\htbitmap{muj} on the y axis. The points are ordered ") + (text . "so that all points in a panel occur before data in succeeding ") + (text . "panels. Within a panel, the points maintain their original ") + (text . "order. ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Number of points to be sorted to be sorted {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 10 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Intercepts + 8 on x axis {\em px}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Intercepts + 8 on y axis {\em py}:") + (text . "\newline\tab{2} ") + (bcStrings (6 9 px PI)) + (text . "\tab{34} ") + (bcStrings (6 10 py PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} \newline ") + (text . "Dimension of point {\it npoint}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 45 npoint PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e02zafSolve) + htShowPage() + +e02zafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + px := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'px) + objValUnwrap htpLabelSpadValue(htPage, 'px) + py := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'py) + objValUnwrap htpLabelSpadValue(htPage, 'py) + npoint := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'npoint) + objValUnwrap htpLabelSpadValue(htPage, 'npoint) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '10 and px = '9) and py = '10) => e02zafDefaultSolve(htPage,npoint,ifail) + labelList := + "append"/[fxy(i) for i in 1..m] where fxy(i) == + prefix := ('"\newline \tab{2} ") + middle := ('"\tab{32} ") + lnam := INTERN STRCONC ('"x",STRINGIMAGE i) + cnam := INTERN STRCONC ('"y",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, lnam, 'F]], + ['text,:middle],['bcStrings,[8, 0.0, cnam, 'F]]] + lamList := + "append"/[flam(i) for i in 5..(px-4)] where flam(i) == + lnam := INTERN STRCONC ('"l",STRINGIMAGE i) + [['bcStrings,[8, 0.0, lnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \lambda(5) to ") + prefix := STRCONC(prefix,"\lambda(px-4)}: \newline \tab{2} ") + lamList := [['text,:prefix],:lamList] + muList := + "append"/[fmu(i) for i in 5..(py-4)] where fmu(i) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE i) + [['bcStrings,[8, 0.0, mnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{} \tab{2} {\it \mu(5) to \mu(py-4)}: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + muList := [['text,:prefix],:muList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:lamList,:muList] + page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htSay '"\menuitemstyle{}\tab{2} {\it x(m)}: " + htSay '"\tab{30} \menuitemstyle{}\tab{32} {\it y(m)}: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'e02zafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e02zafDefaultSolve (htPage,npoint,ifail) == + m := '10 + px := '9 + py := '10 + page := htInitPage('"E02ZAF - Sort 2-D sata into panels for fitting bicubic splines",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} {\it x(m)}:") + (text . "\tab{30} \menuitemstyle{} \tab{32} {\it y(m)}:") + (text . "\newline \tab{2} ") + (bcStrings (8 "0.00" x1 F)) + (text . "\tab{32}") + (bcStrings (8 "0.77" y1 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.70" x2 F)) + (text . "\tab{32}") + (bcStrings (8 "1.06" y2 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.44" x3 F)) + (text . "\tab{32}") + (bcStrings (8 "0.33" y3 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.21" x4 F)) + (text . "\tab{32}") + (bcStrings (8 "0.44" y4 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.01" x5 F)) + (text . "\tab{32}") + (bcStrings (8 "0.50" y5 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.84" x6 F)) + (text . "\tab{32}") + (bcStrings (8 "0.02" y6 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.71" x7 F)) + (text . "\tab{32}") + (bcStrings (8 "1.95" y7 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.00" x8 F)) + (text . "\tab{32}") + (bcStrings (8 "1.20" y8 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "0.54" x9 F)) + (text . "\tab{32}") + (bcStrings (8 "0.04" y9 F)) + (text . "\newline \tab{2} ") + (bcStrings (8 "1.531" x10 F)) + (text . "\tab{32}") + (bcStrings (8 "0.18" y10 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \lambda(5) to \lambda(px-4)}:") + (text . "\newline \tab{2}") + (bcStrings (8 "1.00" l5 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it \mu(5) to \mu(py-4)}:") + (text . "\newline \tab{2}") + (bcStrings (8 "0.80" mu5 F)) + (bcStrings (8 "1.20" mu6 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'e02zafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'px,px) + htpSetProperty(page,'py,py) + htpSetProperty(page,'npoint,npoint) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e02zafGen htPage == + m := htpProperty(htPage,'m) + px := htpProperty(htPage,'px) + py := htpProperty(htPage,'py) + npoint := htpProperty(htPage,'npoint) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + nadres := (px-7)*(py-7) + -- mu + for i in 1..4 repeat + muList := ['"0 ",:muList] + for i in 5..(py-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + muList := [right,:muList] + for i in (py-3)..py repeat + muList := ['"0 ",:muList] + mustring := bcwords2liststring muList + -- lamda + for i in 1..4 repeat + lamList := ['"0 ",:lamList] + for i in 5..(px-4) repeat + right := STRCONC ((first y).1," ") + y := rest y + lamList := [right,:lamList] + for i in (px-3)..px repeat + lamList := ['"0 ",:lamList] + lamstring := bcwords2liststring lamList + -- x & y + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + left := STRCONC ((first y).1," ") + y := rest y + xlist := [left,:xlist] + ylist := [right,:ylist] + xstring := bcwords2liststring xlist + ystring := bcwords2liststring ylist + prefix := STRCONC('"e02zaf(",STRINGIMAGE px,", ",STRINGIMAGE py,",[") + prefix := STRCONC(prefix,lamstring,"],[",mustring,"], ",STRINGIMAGE m,", [") + prefix := STRCONC(prefix,xstring,"],[",ystring,"], ",STRINGIMAGE npoint,", ") + prefix := STRCONC(prefix,STRINGIMAGE nadres,", ",STRINGIMAGE ifail,")") + linkGen prefix + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-e04.boot b/src/interp/nag-e04.boot deleted file mode 100644 index a3553cdf..00000000 --- a/src/interp/nag-e04.boot +++ /dev/null @@ -1,2498 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -e04dgf() == - htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXe04dgf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04dgf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "E04DGF minimizes {\it F(x)}, an unconstrained nonlinear function") - (text . " of {\it n} variables, using a pre-conditioned quasi-Newton ") - (text . "conjugate gradient method. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the number of variables, {\it n}: ") - (text . "\newline ") - (bcStrings (5 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Change optional parameters:") - (radioButtons optional - ("" " No" no) - ("" " Yes" yes)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04dgfSolve) - htShowPage() - - -e04dgfSolve(htPage) == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - param := htpButtonValue(htPage,'optional) - optional := - param = 'no => '0 - '1 - (n = '2 and optional = 0) => e04dgfDefaultSolve(htPage,ifail,n,optional) - funcList := [['bcStrings,[55, '"exp(X[1])*(4*X[1]**2+2*X[2]**2+4*X[1]*X[2]+2*X[2]+1)", 'f, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - middle := cons('text,middle) - vecList := - n='2 => - [['bcStrings,[8,-1.0,'x1,'F]],['bcStrings,[8,1.0,'x2,'F]]] - [fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ['bcStrings,[8, -1.0, xnam, 'F]] - funcList := [:funcList,middle,:vecList] - if optional = 1 then - opt1Text := '"\blankline \menuitemstyle{}\tab{2} " - opt1Text := STRCONC(opt1Text,'"Estimated optimal function values, {\it es}: \newline ") - optList := [['text,:opt1Text],['bcStrings,[20, 1.0, 'es, 'F]]] - opt2Text := '"\blankline \menuitemstyle{}\tab{2} " - opt2Text := STRCONC(opt2Text,'"Function precision, {\it fu}: \newline ") - optList := [:optList,:[['text,:opt2Text],['bcStrings,[20,"0.4373903597E-14",'fu,'F]]]] - opt3Text := '"\blankline \menuitemstyle{}\tab{2} " - opt3Text := STRCONC(opt3Text,'"Iteration limit, {\it it}: \newline ") - optList := [:optList,:[['text,:opt3Text],['bcStrings,[5,50,'it,'PI]]]] - opt4Text := '"\blankline \menuitemstyle{}\tab{2} " - opt4Text := STRCONC(opt4Text,'"Linesearch tolerance, {\it lin}: \newline ") - optList := [:optList,:[['text,:opt4Text],['bcStrings,[20,"0.9",'lin,'F]]]] - opt5Text := '"\blankline \menuitemstyle{}\tab{2} " - opt5Text := STRCONC(opt5Text,'"List parameters:") - optList := [:optList,:[['text,:opt5Text],['radioButtons,'lis,:[[""," Yes",'true],[""," No",'false]]]]] - opt6Text := '"\blankline \menuitemstyle{}\tab{2} " - opt6Text := STRCONC(opt6Text,'"Maximum step length, {\it ma}: \newline ") - optList := [:optList,:[['text,:opt6Text],['bcStrings,[20,"1.0E+20",'ma,'F]]]] - opt7Text := '"\blankline \menuitemstyle{}\tab{2} " - opt7Text := STRCONC(opt7Text,'"Optimality tolerance, {\it op}: \newline ") - optList := [:optList,:[['text,:opt7Text],['bcStrings,[20,"3.26E-12",'op,'F]]]] - opt9Text := '"\blankline \menuitemstyle{}\tab{2} " - opt9Text := STRCONC(opt9Text,'"Print level, {\it pr}: \newline ") - optList := [:optList,:[['text,:opt9Text],['bcStrings,[5,10,'pr,'PI]]]] - opt10Text := '"\blankline \menuitemstyle{}\tab{2} " - opt10Text := STRCONC(opt10Text,'"Start objective check at variable, {\it sta}: \newline ") - optList := [:optList,:[['text,:opt10Text],['bcStrings,[5,1,'sta,'PI]]]] - opt11Text := '"\blankline \menuitemstyle{}\tab{2} " - opt11Text := STRCONC(opt11Text,'"Stop objective check at variable, {\it sto}: \newline ") - optList := [:optList,:[['text,:opt11Text],['bcStrings,[5,2,'sto,'PI]]]] - opt12Text := '"\blankline \menuitemstyle{}\tab{2} " - opt12Text := STRCONC(opt12Text,'"Verify level, {\it ver}: \newline ") - optList := [:optList,:[['text,:opt12Text],['bcStrings,[5,0,'ver,'PI]]]] - --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "List parameters:") --- (radioButtons lis --- ("" " Yes" true) --- ("" " No" false)) - else - optList := [] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList, - :optList] - page := htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the objective function, {\it F(x)} in terms of X[1]...X[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04dgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'optional,optional) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04dgfDefaultSolve(htPage,ifail,n,optional) == - page := htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the objective function, {\it F(x)} in terms of X[1]...X[n]: ") - (text . "\newline ") - (bcStrings (55 "exp(X[1])*(4*X[1]**2+2*X[2]**2+4*X[1]*X[2]+2*X[2]+1)" f EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector, {\it x(n)}: \newline") - (bcStrings (8 "-1.0" x1 F)) - (bcStrings (8 "1.0" x2 F))) - htMakeDoneButton('"Continue",'e04dgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'optional,optional) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04dgfGen htPage == - n := htpProperty(htPage,'n) - optional := htpProperty(htPage,'optional) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - if (optional = '0) then - es := '"1.0" - ma := '"1.0E+20" - op := '"3.26E-12" - lin := '"0.9" - fu := '"0.4373903597E-14" - it := 50 - pr := 10 - sta := 1 - sto := 2 - ver := 0 - lis := '"true" - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - f := (first y).1 - else - ver := STRCONC((first y).1," ") - y := rest y - sto := STRCONC((first y).1," ") - y := rest y - sta := STRCONC((first y).1," ") - y := rest y - pr := STRCONC((first y).1," ") - y := rest y - op := STRCONC((first y).1," ") - y := rest y - ma := STRCONC((first y).1," ") - y := rest y - nolist := (first y).1 - lis := - nolist = '" t" => '"false" - '"true" - y := rest y - dummy := first y - y := rest y - lin := STRCONC((first y).1," ") - y := rest y - it := STRCONC((first y).1," ") - y := rest y - fu := STRCONC((first y).1," ") - y := rest y - es := STRCONC((first y).1," ") - y := rest y - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - f := (first y).1 - prefix := STRCONC("e04dgf(",STRINGIMAGE n,", ",es,", ",fu,",") - prefix := STRCONC(prefix,STRINGIMAGE it,", ",lin,", ",lis,", ",ma,", ",op) - prefix := STRCONC(prefix,",",STRINGIMAGE pr,", ",STRINGIMAGE sta,", ") - middle := STRCONC(STRINGIMAGE sto,", ",STRINGIMAGE ver,", [",xstring,"] ,") - middle := STRCONC(middle,STRINGIMAGE ifail," ,") - linkGen STRCONC (prefix,middle,"((",f,")::Expression(Float))::ASP49(OBJFUN))") - -e04fdf() == - htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe04fdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04fdf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04FDF is an easy to use routine for finding an unconstrained ") - (text . "minimum of a sum of squares of {\it m} nonlinear functions in ") - (text . "{\it n} variables ({\it m} \htbitmap{great=} {\it n}), i.e., it ") - (text . "is applicable to problems of the form ") - (text . "\center{\htbitmap{e04fdf}} where \center{\htbitmap{e04fdf1}}") - (text . "No derivatives are required. The routine is intended for ") - (text . "functions which have continous first and second derivatives, ") - (text . "though it will usually work if the derivatives have occasional ") - (text . "discontinuities. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of functions {\it \htbitmap{fi}(x)}, {\it m}:") - (text . "\newline\tab{2} ") - (bcStrings (5 15 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables \htbitmap{xj}, {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it iw}, {\it liw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 1 liw F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it w}, {\it lw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 171 lw F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04fdfSolve) - htShowPage() - -e04fdfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - liw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) - objValUnwrap htpLabelSpadValue(htPage, 'liw) - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '15 and n = '3) => e04fdfDefaultSolve(htPage,liw,lw,ifail) - funcList := - "append"/[fa(i) for i in 1..m] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := ('"XC[1] + 1") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - middle := cons('text,middle) - vecList := - [fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ['bcStrings,[4, '"0.0", xnam, 'F]] - funcList := [:funcList,middle,:vecList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList] - page:= htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions \htbitmap{fi} below in terms XC[1]...XC[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04fdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04fdfDefaultSolve (htPage,liw,lw,ifail) == - n := '3 - m := '15 - page:= htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{fi} below ") - (text . "in terms of XC[1]...XC[n]: ") - (text . "\newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (42 "(XC[3]+15*XC[2])**(-1)+XC[1]-0.14" n1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (42 "2*(2*XC[3]+14*XC[2])**(-1)+XC[1]-0.18" n2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (42 "3*(3*XC[3]+13*XC[2])**(-1)+XC[1]-0.22" n3 EM)) - (text . "\newline {\em Function 4:} \space{1}") - (bcStrings (42 "4*(4*XC[3]+12*XC[2])**(-1)+XC[1]-0.25" n4 EM)) - (text . "\newline {\em Function 5:} \space{1}") - (bcStrings (42 "5*(5*XC[3]+11*XC[2])**(-1)+XC[1]-0.29" n5 EM)) - (text . "\newline {\em Function 6:} \space{1}") - (bcStrings (42 "6*(6*XC[3]+10*XC[2])**(-1)+XC[1]-0.32" n6 EM)) - (text . "\newline {\em Function 7:} \space{1}") - (bcStrings (42 "7*(7*XC[3]+9*XC[2])**(-1)+XC[1]-0.35" n7 EM)) - (text . "\newline {\em Function 8:} \space{1}") - (bcStrings (42 "8*(8*XC[3]+8*XC[2])**(-1)+XC[1]-0.39" n8 EM)) - (text . "\newline {\em Function 9:} \space{1}") - (bcStrings (42 "9*(7*XC[3]+7*XC[2])**(-1)+XC[1]-0.37" n9 EM)) - (text . "\newline {\em Function 10:} \space{1}") - (bcStrings (42 "10*(6*XC[3]+6*XC[2])**(-1)+XC[1]-0.58" n10 EM)) - (text . "\newline {\em Function 11:} \space{1}") - (bcStrings (42 "11*(5*XC[3]+5*XC[2])**(-1)+XC[1]-0.73" n11 EM)) - (text . "\newline {\em Function 12:} \space{1}") - (bcStrings (42 "12*(4*XC[3]+4*XC[2])**(-1)+XC[1]-0.96" n12 EM)) - (text . "\newline {\em Function 13:} \space{1}") - (bcStrings (42 "13*(3*XC[3]+3*XC[2])**(-1)+XC[1]-1.34" n13 EM)) - (text . "\newline {\em Function 14:} \space{1}") - (bcStrings (42 "14*(2*XC[3]+2*XC[2])**(-1)+XC[1]-2.1" n14 EM)) - (text . "\newline {\em Function 15:} \space{1}") - (bcStrings (42 "15*(XC[3]+XC[2])**(-1)+XC[1]-4.39" n15 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") - (bcStrings (4 "0.5" x1 F)) - (bcStrings (4 "1.0" x2 F)) - (bcStrings (4 "1.5" x3 F))) - htMakeDoneButton('"Continue",'e04fdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04fdfGen htPage == - n := htpProperty(htPage, 'n) - m := htpProperty(htPage, 'm) - liw := htpProperty(htPage,'liw) - lw := htpProperty(htPage,'lw) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - for i in 1..m repeat - temp := STRCONC ((first y).1," ") - ulist := [temp,:ulist] - y := rest y - ustring := bcwords2liststring ulist - prefix := STRCONC("e04fdf(",STRINGIMAGE m,",",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") - middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",") - linkGen STRCONC(prefix,middle,"(",ustring,"::Vector Expression(Float))::ASP50(LSFUN1))") - - -e04gcf() == - htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe04gcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04gcf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04GCF is an easy to use quasi-Newton routine for finding an unconstrained ") - (text . "minimum of a sum of squares of {\it m} nonlinear functions in ") - (text . "{\it n} variables ({\it m} \htbitmap{great=} {\it n}), i.e., it ") - (text . "is applicable to problems of the form ") - (text . "\center{\htbitmap{e04fdf}} where \center{\htbitmap{e04fdf1}}") - (text . "The routine is intended for ") - (text . "functions which have continous first and second derivatives, ") - (text . "though it will usually work if the derivatives have occasional ") - (text . "discontinuities. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of functions {\it \htbitmap{fi}(x)}, {\it m}:") - (text . "\newline\tab{2} ") - (bcStrings (5 15 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables \htbitmap{xj}, {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 3 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it iw}, {\it liw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 1 liw F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it w}, {\it lw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 177 lw F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04gcfSolve) - htShowPage() - -e04gcfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - liw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) - objValUnwrap htpLabelSpadValue(htPage, 'liw) - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '15 and n = '3) => e04gcfDefaultSolve(htPage,liw,lw,ifail) - funcList := - "append"/[fa(i) for i in 1..m] where fa(i) == - prefix := ('"\newline {\em Function ") - prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") - funct := ('"XC[1] + 1") - nam := INTERN STRCONC ('"n",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - middle := cons('text,middle) - vecList := - [fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - ['bcStrings,[4, '"0.0", xnam, 'F]] - funcList := [:funcList,middle,:vecList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList] - page:= htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the functions \htbitmap{fi} below in terms of XC[1]...XC[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04gcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04gcfDefaultSolve (htPage,liw,lw,ifail) == - n := '3 - m := '15 - page:= htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the functions \htbitmap{fi} below ") - (text . "in terms of XC[1]...XC[n]: ") - (text . "\newline ") - (text . "\newline {\em Function 1:} \space{1}") - (bcStrings (42 "(XC[3]+15*XC[2])**(-1)+XC[1]-0.14" n1 EM)) - (text . "\newline {\em Function 2:} \space{1}") - (bcStrings (42 "2*(2*XC[3]+14*XC[2])**(-1)+XC[1]-0.18" n2 EM)) - (text . "\newline {\em Function 3:} \space{1}") - (bcStrings (42 "3*(3*XC[3]+13*XC[2])**(-1)+XC[1]-0.22" n3 EM)) - (text . "\newline {\em Function 4:} \space{1}") - (bcStrings (42 "4*(4*XC[3]+12*XC[2])**(-1)+XC[1]-0.25" n4 EM)) - (text . "\newline {\em Function 5:} \space{1}") - (bcStrings (42 "5*(5*XC[3]+11*XC[2])**(-1)+XC[1]-0.29" n5 EM)) - (text . "\newline {\em Function 6:} \space{1}") - (bcStrings (42 "6*(6*XC[3]+10*XC[2])**(-1)+XC[1]-0.32" n6 EM)) - (text . "\newline {\em Function 7:} \space{1}") - (bcStrings (42 "7*(7*XC[3]+9*XC[2])**(-1)+XC[1]-0.35" n7 EM)) - (text . "\newline {\em Function 8:} \space{1}") - (bcStrings (42 "8*(8*XC[3]+8*XC[2])**(-1)+XC[1]-0.39" n8 EM)) - (text . "\newline {\em Function 9:} \space{1}") - (bcStrings (42 "9*(7*XC[3]+7*XC[2])**(-1)+XC[1]-0.37" n9 EM)) - (text . "\newline {\em Function 10:} \space{1}") - (bcStrings (42 "10*(6*XC[3]+6*XC[2])**(-1)+XC[1]-0.58" n10 EM)) - (text . "\newline {\em Function 11:} \space{1}") - (bcStrings (42 "11*(5*XC[3]+5*XC[2])**(-1)+XC[1]-0.73" n11 EM)) - (text . "\newline {\em Function 12:} \space{1}") - (bcStrings (42 "12*(4*XC[3]+4*XC[2])**(-1)+XC[1]-0.96" n12 EM)) - (text . "\newline {\em Function 13:} \space{1}") - (bcStrings (42 "13*(3*XC[3]+3*XC[2])**(-1)+XC[1]-1.34" n13 EM)) - (text . "\newline {\em Function 14:} \space{1}") - (bcStrings (42 "14*(2*XC[3]+2*XC[2])**(-1)+XC[1]-2.1" n14 EM)) - (text . "\newline {\em Function 15:} \space{1}") - (bcStrings (42 "15*(XC[3]+XC[2])**(-1)+XC[1]-4.39" n15 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") - (bcStrings (4 "0.5" x1 F)) - (bcStrings (4 "1.0" x2 F)) - (bcStrings (4 "1.5" x3 F))) - htMakeDoneButton('"Continue",'e04gcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04gcfGen htPage == - n := htpProperty(htPage, 'n) - m := htpProperty(htPage, 'm) - liw := htpProperty(htPage,'liw) - lw := htpProperty(htPage,'lw) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - for i in 1..m repeat - temp := STRCONC ((first y).1," ") - ulist := [temp,:ulist] - y := rest y - ustring := bcwords2liststring ulist - prefix := STRCONC("e04gcf(",STRINGIMAGE m,",",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") - middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",") - linkGen STRCONC(prefix,middle,"(",ustring,"::Vector Expression(Float))::ASP19(LSFUN2))") - - -e04jaf() == - htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXe04jaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04jaf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04JAF is an easy to use quasi-Newton routine for finding a ") - (text . "minimum of a nonlinear function {\it F(x)} of {\it n} variables ") - (text . "\center{\htbitmap{e04fdf1}} possibly subject to fixed upper ") - (text . "and lower bounds on the variables, i.e., it is applicable to ") - (text . "problems of the form \blankline Minimize {\it F(x)}, subject to ") - (text . "\htbitmap{lj} \htbitmap{great=} \htbitmap{xj} \htbitmap{great=} ") - (text . "\htbitmap{uj} for {\it j} = 1,2,...,n. \blankline ") - (text . "Function values only are required. The routine is intended for ") - (text . "functions which have continuous first and second derivatives, ") - (text . "though it will usually work if the derivatives have occasional ") - (text . "discontinuities. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables \htbitmap{xj}, {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 4 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Specify the use of bounds, {\it ibound}:") - (radioButtons ibound - (" 0" " All \htbitmap{lj} and \htbitmap{uj} are given individually" iZero) - (" 1" " No bounds on any of the \htbitmap{xj}" iOne) - (" 2" " All bounds are of the form 0 \htbitmap{great=} \htbitmap{xj}" iTwo) - (" 3" " All \htbitmap{lj} are equal and all \htbitmap{uj} are equal" iThree)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it iw}, {\it liw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 6 liw F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it w}, {\it lw}:") - (text . "\newline\tab{2} ") - (bcStrings (5 54 lw F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04jafSolve) - htShowPage() - -e04jafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - boun := htpButtonValue(htPage,'ibound) - ibound := - boun = 'iZero => '0 - boun = 'iOne => '1 - boun = 'iTwo => '2 - '3 - liw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) - objValUnwrap htpLabelSpadValue(htPage, 'liw) - lw := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) - objValUnwrap htpLabelSpadValue(htPage, 'lw) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => e04jafDefaultSolve(htPage,ibound,liw,lw,ifail) - funcList := [['bcStrings,[50, '"XC[1]", 'f, 'EM]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary conditions ") - middle := STRCONC(middle,'"{\it bl(n)}: \newline ") - blList := - "append"/[fa(i) for i in 1..n] where fa(i) == - xnam := INTERN STRCONC ('"bl",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - blList := [['text,:middle],:blList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") - middle := STRCONC(middle,'"conditions {\it bu(n)}: \newline ") - buList := - "append"/[fb(i) for i in 1..n] where fb(i) == - xnam := INTERN STRCONC ('"bu",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - buList := [['text,:middle],:buList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - xList := - "append"/[fc(i) for i in 1..n] where fc(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - xList := [['text,:middle],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :funcList,:blList,:buList,:xList] - page:= htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the function {\it F(x)} below in terms of XC[1]...XC[n]: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04jafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ibound,ibound) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04jafDefaultSolve (htPage,ibound,liw,lw,ifail) == - n := '4 - page:= htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the function {\it F(x)} below in terms of XC[1]...XC[n]: ") - (text . "\newline ") - (bcStrings (60 "(XC[1]+10*XC[2])**2+5*(XC[3]-XC[4])**2+(XC[2]-2*XC[3])**4+10*(XC[1]-XC[4])**4" n1 EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter lower boundary conditions {\it bl(n)}: \newline ") - (bcStrings (8 "1" bl1 F)) - (bcStrings (8 "-2" bl2 F)) - (bcStrings (8 "-1.0e-6" bl3 F)) - (bcStrings (8 "1" bl4 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter upper boundary conditions {\it bu(n)}: \newline ") - (bcStrings (8 "3" bu1 F)) - (bcStrings (8 "0" bu2 F)) - (bcStrings (8 "1.0e6" bu3 F)) - (bcStrings (8 "3" bu4 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") - (bcStrings (8 "3" x1 F)) - (bcStrings (8 "-1" x2 F)) - (bcStrings (8 "0" x3 F)) - (bcStrings (8 "1" x4 F))) - htMakeDoneButton('"Continue",'e04jafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'ibound,ibound) - htpSetProperty(page,'liw,liw) - htpSetProperty(page,'lw,lw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04jafGen htPage == - n := htpProperty(htPage, 'n) - ibound := htpProperty(htPage, 'ibound) - liw := htpProperty(htPage,'liw) - lw := htpProperty(htPage,'lw) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - bulist := [temp,:bulist] - y := rest y - bustring := bcwords2liststring bulist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - bllist := [temp,:bllist] - y := rest y - blstring := bcwords2liststring bllist - f := (first y).1 - prefix := STRCONC("e04jaf(",STRINGIMAGE n,",",STRINGIMAGE ibound,", ") - prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") - prefix := STRCONC(prefix,blstring,"],[",bustring,"],[") - middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",(") - linkGen STRCONC(prefix,middle,f,"::Expression(Float))::ASP24(FUNCT1))") - - -e04mbf() == - htInitPage('"E04MBF - Linear programming problem",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXe04mbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04mbf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04MBF is an easy to use routine to solve linear programming ") - (text . "(LP) problems of the form \center{\htbitmap{e04mbf}} \newline ") - (text . "where {\it c} is an {\it n} element vector and {\it A} is an ") - (text . "{\it m} by {\it n} matrix, i.e., there are {\it n} variables ") - (text . "and {\it m} linear constraints. {\it m} may be zero in which ") - (text . "case the LP problem is subject only to bounds on the variables. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Upper bound on number of iterations, {\it itmax}:") - (text . "\newline\tab{2} ") - (bcStrings (6 20 itmax PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Type of output messages required, {\it msglvl}: ") - (radioButtons msglvl - (" = 1 " " Printing occurs at the solution " mOne) - (" = 0 " " Printing only if an input parameter is incorrect " mZero) - (" < 0 " " No printing " mMinus)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables, {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of general linear constraints, {\it nclin}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 nclin PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "First dimension of array {\it a}, {\it nrowa}:") - (text . "\newline\tab{2} ") - (bcStrings (6 7 nrowa PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Specifies whether or not a linear objective function is present, {\it linobj}:") - (radioButtons linobj - ("" " true - full LP problem is solved" true) - ("" " false - only a feasible problem is found" false)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Dimension of {\it iwork}, {\it liwork}:") - (text . "\newline\tab{2} ") - (bcStrings (5 14 liwork F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it work}, {\it lwork}:") - (text . "\newline\tab{2} ") - (bcStrings (5 182 lwork F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04mbfSolve) - htShowPage() - -e04mbfSolve htPage == - itmax := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itmax) - objValUnwrap htpLabelSpadValue(htPage, 'itmax) - msg := htpButtonValue(htPage,'msglvl) - msglvl := - msg = 'mMinus => '-1 - msg = 'mZero => '0 - '1 - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nclin := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) - objValUnwrap htpLabelSpadValue(htPage, 'nclin) - nrowa := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowa) - objValUnwrap htpLabelSpadValue(htPage, 'nrowa) - lin := htpButtonValue(htPage,'linobj) - linobj := - lin = 'true => '"true" - '"false" - liwork := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liwork) - objValUnwrap htpLabelSpadValue(htPage, 'liwork) - lwork := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) - objValUnwrap htpLabelSpadValue(htPage, 'lwork) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((nrowa = '7 and n = 7) and nclin = 7) => e04mbfDefaultSolve(htPage,itmax,msglvl,linobj,liwork,lwork,ifail) - aList := - "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[8, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") - middle := STRCONC(middle,'"conditions {\it bl(n + nclin)}: \newline ") - blList := - "append"/[fc(i) for i in 1..(n+nclin)] where fc(i) == - blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", blnam, 'F]]] - blList := [['text,:middle],:blList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") - middle := STRCONC(middle,'"conditions {\it bu(n+nclin)}: \newline ") - buList := - "append"/[fd(i) for i in 1..(n+nclin)] where fd(i) == - bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", bunam, 'F]]] - buList := [['text,:middle],:buList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter coefficients of the ") - middle := STRCONC(middle,'"objective function {\it cvec(n)}: \newline ") - cList := - "append"/[fe(i) for i in 1..n] where fe(i) == - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", cnam, 'F]]] - cList := [['text,:middle],:cList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - xList := - "append"/[fg(i) for i in 1..n] where fg(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - xList := [['text,:middle],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList,:blList,:buList,:cList,:xList] - page:= htInitPage('"E04MBF - Linear programming problem",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the elements of the array {\it a(nrowa,n)}: \newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04mbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'itmax,itmax) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'linobj,linobj) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04mbfDefaultSolve(htPage,itmax,msglvl,linobj,liwork,lwork,ifail) == - n := '7 - nclin := '7 - nrowa := '7 - page:= htInitPage('"E04MBF - Linear programming problem",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of array {\it a(nrowa,n)}: \newline ") - (bcStrings (5 "1" a11 F)) - (bcStrings (5 "1" a12 F)) - (bcStrings (5 "1" a13 F)) - (bcStrings (5 "1" a14 F)) - (bcStrings (5 "1" a15 F)) - (bcStrings (5 "1" a16 F)) - (bcStrings (5 "1" a17 F)) - (text . "\newline ") - (bcStrings (5 "0.15" a21 F)) - (bcStrings (5 "0.04" a22 F)) - (bcStrings (5 "0.02" a23 F)) - (bcStrings (5 "0.04" a24 F)) - (bcStrings (5 "0.02" a25 F)) - (bcStrings (5 "0.01" a26 F)) - (bcStrings (5 "0.03" a27 F)) - (text . "\newline ") - (bcStrings (5 "0.03" a31 F)) - (bcStrings (5 "0.05" a32 F)) - (bcStrings (5 "0.08" a33 F)) - (bcStrings (5 "0.02" a34 F)) - (bcStrings (5 "0.06" a35 F)) - (bcStrings (5 "0.01" a36 F)) - (bcStrings (5 "0" a37 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a41 F)) - (bcStrings (5 "0.04" a42 F)) - (bcStrings (5 "0.01" a43 F)) - (bcStrings (5 "0.02" a44 F)) - (bcStrings (5 "0.02" a45 F)) - (bcStrings (5 "0" a46 F)) - (bcStrings (5 "0" a47 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a51 F)) - (bcStrings (5 "0.03" a52 F)) - (bcStrings (5 "0" a53 F)) - (bcStrings (5 "0" a54 F)) - (bcStrings (5 "0.01" a55 F)) - (bcStrings (5 "0" a56 F)) - (bcStrings (5 "0" a57 F)) - (text . "\newline ") - (bcStrings (5 "0.7" a61 F)) - (bcStrings (5 "0.75" a62 F)) - (bcStrings (5 "0.8" a63 F)) - (bcStrings (5 "0.75" a64 F)) - (bcStrings (5 "0.8" a65 F)) - (bcStrings (5 "0.97" a66 F)) - (bcStrings (5 "0" a67 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a71 F)) - (bcStrings (5 "0.06" a72 F)) - (bcStrings (5 "0.08" a73 F)) - (bcStrings (5 "0.12" a74 F)) - (bcStrings (5 "0.02" a75 F)) - (bcStrings (5 "0.01" a76 F)) - (bcStrings (5 "0.97" a77 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter lower boundary conditions {\it bl(n+nclin)}: \newline ") - (bcStrings (8 "-0.01" bl1 F)) - (bcStrings (8 "-0.1" bl2 F)) - (bcStrings (8 "-0.01" bl3 F)) - (bcStrings (8 "-0.04" bl4 F)) - (bcStrings (8 "-0.1" bl5 F)) - (bcStrings (8 "-0.01" bl6 F)) - (bcStrings (8 "-0.01" bl7 F)) - (bcStrings (8 "-0.13" bl8 F)) - (bcStrings (8 "-1.0e+21" bl9 F)) - (bcStrings (8 "-1.0e+21" bl10 F)) - (bcStrings (8 "-1.0e+21" bl11 F)) - (bcStrings (8 "-1.0e+21" bl12 F)) - (bcStrings (8 "-0.0992" bl13 F)) - (bcStrings (8 "-0.003" bl14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter upper boundary conditions {\it bu(n+nclin)}: \newline ") - (bcStrings (8 "0.01" bu1 F)) - (bcStrings (8 "0.15" bu2 F)) - (bcStrings (8 "0.03" bu3 F)) - (bcStrings (8 "0.02" bu4 F)) - (bcStrings (8 "0.05" bu5 F)) - (bcStrings (8 "1.0e+21" bu6 F)) - (bcStrings (8 "1.0e+21" bu7 F)) - (bcStrings (8 "-0.13" bu8 F)) - (bcStrings (8 "-0.0049" bu9 F)) - (bcStrings (8 "-0.0064" bu10 F)) - (bcStrings (8 "-0.0037" bu11 F)) - (bcStrings (8 "-0.0012" bu12 F)) - (bcStrings (8 "1.0e+21" bu13 F)) - (bcStrings (8 "0.002" bu14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter coefficients of the objective function, {\it cvec(n)}: ") - (text . "\newline ") - (bcStrings (8 "-0.02" c1 F)) - (bcStrings (8 "-0.2" c2 F)) - (bcStrings (8 "-0.2" c3 F)) - (bcStrings (8 "-0.2" c4 F)) - (bcStrings (8 "-0.2" c5 F)) - (bcStrings (8 "0.04" c6 F)) - (bcStrings (8 "0.04" c7 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector, {\it x(n)}: ") - (text . "\newline ") - (bcStrings (8 "-0.01" x1 F)) - (bcStrings (8 "-0.03" x2 F)) - (bcStrings (8 "0.0" x3 F)) - (bcStrings (8 "-0.01" x4 F)) - (bcStrings (8 "-0.1" x5 F)) - (bcStrings (8 "0.02" x6 F)) - (bcStrings (8 "0.01" x7 F))) - htMakeDoneButton('"Continue",'e04mbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'itmax,itmax) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'linobj,linobj) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04mbfGen htPage == - n := htpProperty(htPage, 'n) - nclin := htpProperty(htPage, 'nclin) - nrowa := htpProperty(htPage, 'nrowa) - itmax := htpProperty(htPage, 'itmax) - msglvl := htpProperty(htPage, 'msglvl) - linobj := htpProperty(htPage, 'linobj) - liwork := htpProperty(htPage,'liwork) - lwork := htpProperty(htPage,'lwork) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - clist := [temp,:clist] - y := rest y - cstring := bcwords2liststring clist - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - bulist := [temp,:bulist] - y := rest y - bustring := bcwords2liststring bulist - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - bllist := [temp,:bllist] - y := rest y - blstring := bcwords2liststring bllist - for i in 1..nrowa repeat -- matrix A - for j in 1..n repeat - a := STRCONC((first y).1," ") - arrlist := [a,:arrlist] - y := rest y - amatlist := [:amatlist,arrlist] - arrlist := [] - amatlist := reverse amatlist - amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] - nctotl := n + nclin - prefix := STRCONC("e04mbf(",STRINGIMAGE itmax,",", STRINGIMAGE msglvl,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,",",STRINGIMAGE nclin,", ") - prefix := STRCONC(prefix,STRINGIMAGE nctotl,",",STRINGIMAGE nrowa,", ") - middle := STRCONC(amatstr,",[") - middle := STRCONC(middle,blstring,"],[",bustring,"],[",cstring) - middle := STRCONC(middle,"],",linobj,", ",STRINGIMAGE liwork) - middle := STRCONC(middle,",",STRINGIMAGE lwork,",[") - middle := STRCONC(middle,xstring,"],",STRINGIMAGE ifail,")") - linkGen STRCONC(prefix,middle) - - - -e04naf() == - htInitPage('"E04NAF - Quadratic programming problem",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXe04naf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04naf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04NAF is a comprehensive routine to solve quadratic problems ") - (text . "(QP) of the form \center{\htbitmap{e04naf}} \newline ") - (text . "where {\it c} is a constant {\it n} element vector, {\it H} is a") - (text . " constant {\it n} by {\it n} symmetric matrix, and the matrix ") - (text . "{\it A} is {\it m} by {\it n}, i.e. there are {\it n} variables ") - (text . "and {\it m} general linear constraints. {\it m} may be zero in ") - (text . "which case the LP problem is subject only to bounds on the ") - (text . "variables. \blankline If {\it H} = 0 a flag can be set so that ") - (text . "the problem is treated as a linear programming (LP) problem. ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Upper bound on number of iterations, {\it itmax}:") - (text . "\newline\tab{2} ") - (bcStrings (6 20 itmax PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Type of output messages required, {\it msglvl}: ") - (radioButtons msglvl - (" < 0 " " No printing " mMinus) - (" = 0 " " Printing only if an input parameter is incorrect or overflow is likely" mZero) - (" = 1" " Printing occurs at the solution " mOne) - (" = 5" " One line of output for each constraint addition or deletion, no printout" mFive) - (" \htbitmap{great=} 10" " As above with printout of the solution" mTen) - (" \htbitmap{great=} 15" " As above with X, ISTATE and indices of free variables at each iteration" mFifteen) - (" \htbitmap{great=} 20" " As above with the Lagrange multiplier estimates and the free variables at each iteration" mTwenty) - (" \htbitmap{great=} 30" " As above with the diagonal elements of the matrix {\it T} associated with the {\it TQ} factorization of the working set, and the diagonal elements of the Cholesky factor {\it R} of the projected Hessian" mThirty) - (" \htbitmap{great=} 80" " As above with debug printout" mEighty) - (" = 99" " As above with arrays {\it cvec} and {\it hess}" mNinetyNine)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables, {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of general linear constraints, {\it nclin}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 7 nclin PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "First dimension of array {\it a}, {\it nrowa}:") - (text . "\newline\tab{2} ") - (bcStrings (6 7 nrowa PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "First dimension of array {\it hess}, {\it nrowh}:") - (text . "\newline\tab{2} ") - (bcStrings (6 7 nrowh PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Second dimension of array {\it hess}, {\it ncolh}:") - (text . "\newline\tab{2} ") - (bcStrings (6 7 ncolh PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Size above which a bound is regarded as infinite, {\it bigbnd}:") - (text . "\newline\tab{2} ") - (bcStrings (10 "1.0e10" bigbnd F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Specifies whether or not an initial estimate of the active constraints is present, {\it cold}:") - (radioButtons cold - ("" " true - E04NAF determines the initial working set" cTrue) - ("" " false - user defined contents of array {\it istate}" cFalse)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Specifies whether or not {\it h} is a zero matrix, {\it lp}:") - (radioButtons lp - ("" " false - QP problem " lFalse) - ("" " true - LP problem, {\it hess} and {\it qphess} are not referenced " lTrue)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Specifies whether or not orthogonal transformations are to be used in computing and updating the working set, {\it orthog}:") - (radioButtons orthog - ("" " true " oTrue) - ("" " false " oFalse)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Dimension of {\it iwork}, {\it liwork}:") - (text . "\newline\tab{2} ") - (bcStrings (5 14 liwork F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of {\it work}, {\it lwork}:") - (text . "\newline\tab{2} ") - (bcStrings (5 238 lwork F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04nafSolve) - htShowPage() - -e04nafSolve htPage == - itmax := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itmax) - objValUnwrap htpLabelSpadValue(htPage, 'itmax) - msg := htpButtonValue(htPage,'msglvl) - msglvl := - msg = 'mMinus => '-1 - msg = 'mZero => '0 - msg = 'mOne => '1 - msg = 'mFive => '5 - msg = 'mTen => '10 - msg = 'mFifteen => '15 - msg = 'mTwenty => '20 - msg = 'mThirty => '30 - msg = 'mEighty => '80 - '99 - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nclin := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) - objValUnwrap htpLabelSpadValue(htPage, 'nclin) - nrowa := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowa) - objValUnwrap htpLabelSpadValue(htPage, 'nrowa) - nrowh := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowh) - objValUnwrap htpLabelSpadValue(htPage, 'nrowh) - ncolh := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolh) - objValUnwrap htpLabelSpadValue(htPage, 'ncolh) - bigbnd := htpLabelInputString(htPage,'bigbnd) - col := htpButtonValue(htPage,'cold) - cold := - col = 'cTrue => '"true" - '"false" - linear := htpButtonValue(htPage,'lp) - lp := - linear = 'lTrue => '"true" - '"false" - ortho := htpButtonValue(htPage,'orthog) - orthog := - ortho = 'oTrue => '"true" - '"false" - liwork := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liwork) - objValUnwrap htpLabelSpadValue(htPage, 'liwork) - lwork := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) - objValUnwrap htpLabelSpadValue(htPage, 'lwork) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (((nrowa = '7 and n = '7) and (nrowh = '7 and ncolh ='7)) and nclin = '7) => - e04nafDefaultSolve(htPage,itmax,msglvl,bigbnd,cold,lp,orthog,liwork,lwork,ifail) - aList := - "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[8, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") - middle := STRCONC(middle,'"conditions {\it bl(n + nclin)}: \newline ") - blList := - "append"/[fc(i) for i in 1..(n+nclin)] where fc(i) == - blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", blnam, 'F]]] - blList := [['text,:middle],:blList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") - middle := STRCONC(middle,'"conditions {\it bu(n+nclin)}: \newline ") - buList := - "append"/[fd(i) for i in 1..(n+nclin)] where fd(i) == - bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", bunam, 'F]]] - buList := [['text,:middle],:buList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter coefficients of the ") - middle := STRCONC(middle,'"objective function {\it cvec(n)}: \newline ") - cList := - "append"/[fe(i) for i in 1..n] where fe(i) == - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", cnam, 'F]]] - cList := [['text,:middle],:cList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter set of positive ") - middle := STRCONC(middle,'"tolerances {\it featol(n+nclin)}: \newline ") - fList := - "append"/[ff(i) for i in 1..(n+nclin)] where ff(i) == - fnam := INTERN STRCONC ('"f",STRINGIMAGE i) - [['bcStrings,[9, '"0.1053e-7", fnam, 'F]]] - fList := [['text,:middle],:fList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the elements of ") - middle := STRCONC(middle,'"array {\it hess(nrowh,ncolh)}: \newline ") - hList := - "append"/[fh(i,n) for i in 1..nrowh] where fh(i,n) == - labelList := - "append"/[fi(i,j) for j in 1..n] where fi(i,j) == - hnam := INTERN STRCONC ('"h",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[8, 0, hnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - hList := [['text,:middle],:hList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - xList := - "append"/[fg(i) for i in 1..n] where fg(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - xList := [['text,:middle],:xList] - middle := ('"\blankline \menuitemstyle{}\tab{2} If {\it cold} = false ") - middle := STRCONC(middle,'"enter {\it istate(n+nclin)} values: \newline ") - iList := - "append"/[fj(i) for i in 1..(n+nclin)] where fj(i) == - inam := INTERN STRCONC ('"i",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", inam, 'F]]] - iList := [['text,:middle],:iList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList,:blList,:buList,:cList,:fList,:hList,:xList,:iList] - page:= htInitPage('"E04NAF - Quadratic programming problem",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the elements of the array {\it a(nrowa,n)}: \newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04nafGen) - htpSetProperty(page,'itmax,itmax) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'nrowh,nrowh) - htpSetProperty(page,'ncolh,ncolh) - htpSetProperty(page,'bigbnd,bigbnd) - htpSetProperty(page,'cold,cold) - htpSetProperty(page,'lp,lp) - htpSetProperty(page,'orthog,orthog) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04nafDefaultSolve(htPage,itmax,msglvl,bigbnd,cold,lp,orthog,liwork,lwork,ifail) == - n := '7 - nclin := '7 - nrowa := '7 - nrowh := '7 - ncolh := '7 - page:= htInitPage('"E04NAF - Quadratic programming problem",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of array {\it a(nrowa,n)}: \newline ") - (bcStrings (5 "1" a11 F)) - (bcStrings (5 "1" a12 F)) - (bcStrings (5 "1" a13 F)) - (bcStrings (5 "1" a14 F)) - (bcStrings (5 "1" a15 F)) - (bcStrings (5 "1" a16 F)) - (bcStrings (5 "1" a17 F)) - (text . "\newline ") - (bcStrings (5 "0.15" a21 F)) - (bcStrings (5 "0.04" a22 F)) - (bcStrings (5 "0.02" a23 F)) - (bcStrings (5 "0.04" a24 F)) - (bcStrings (5 "0.02" a25 F)) - (bcStrings (5 "0.01" a26 F)) - (bcStrings (5 "0.03" a27 F)) - (text . "\newline ") - (bcStrings (5 "0.03" a31 F)) - (bcStrings (5 "0.05" a32 F)) - (bcStrings (5 "0.08" a33 F)) - (bcStrings (5 "0.02" a34 F)) - (bcStrings (5 "0.06" a35 F)) - (bcStrings (5 "0.01" a36 F)) - (bcStrings (5 "0" a37 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a41 F)) - (bcStrings (5 "0.04" a42 F)) - (bcStrings (5 "0.01" a43 F)) - (bcStrings (5 "0.02" a44 F)) - (bcStrings (5 "0.02" a45 F)) - (bcStrings (5 "0" a46 F)) - (bcStrings (5 "0" a47 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a51 F)) - (bcStrings (5 "0.03" a52 F)) - (bcStrings (5 "0" a53 F)) - (bcStrings (5 "0" a54 F)) - (bcStrings (5 "0.01" a55 F)) - (bcStrings (5 "0" a56 F)) - (bcStrings (5 "0" a57 F)) - (text . "\newline ") - (bcStrings (5 "0.7" a61 F)) - (bcStrings (5 "0.75" a62 F)) - (bcStrings (5 "0.8" a63 F)) - (bcStrings (5 "0.75" a64 F)) - (bcStrings (5 "0.8" a65 F)) - (bcStrings (5 "0.97" a66 F)) - (bcStrings (5 "0" a67 F)) - (text . "\newline ") - (bcStrings (5 "0.02" a71 F)) - (bcStrings (5 "0.06" a72 F)) - (bcStrings (5 "0.08" a73 F)) - (bcStrings (5 "0.12" a74 F)) - (bcStrings (5 "0.02" a75 F)) - (bcStrings (5 "0.01" a76 F)) - (bcStrings (5 "0.97" a77 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter lower boundary conditions {\it bl(n+nclin)}: \newline ") - (bcStrings (8 "-0.01" bl1 F)) - (bcStrings (8 "-0.1" bl2 F)) - (bcStrings (8 "-0.01" bl3 F)) - (bcStrings (8 "-0.04" bl4 F)) - (bcStrings (8 "-0.1" bl5 F)) - (bcStrings (8 "-0.01" bl6 F)) - (bcStrings (8 "-0.01" bl7 F)) - (bcStrings (8 "-0.13" bl8 F)) - (bcStrings (8 "-1.0e+21" bl9 F)) - (bcStrings (8 "-1.0e+21" bl10 F)) - (bcStrings (8 "-1.0e+21" bl11 F)) - (bcStrings (8 "-1.0e+21" bl12 F)) - (bcStrings (8 "-0.0992" bl13 F)) - (bcStrings (8 "-0.003" bl14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter upper boundary conditions {\it bu(n+nclin)}: \newline ") - (bcStrings (8 "0.01" bu1 F)) - (bcStrings (8 "0.15" bu2 F)) - (bcStrings (8 "0.03" bu3 F)) - (bcStrings (8 "0.02" bu4 F)) - (bcStrings (8 "0.05" bu5 F)) - (bcStrings (8 "1.0e+21" bu6 F)) - (bcStrings (8 "1.0e+21" bu7 F)) - (bcStrings (8 "-0.13" bu8 F)) - (bcStrings (8 "-0.0049" bu9 F)) - (bcStrings (8 "-0.0064" bu10 F)) - (bcStrings (8 "-0.0037" bu11 F)) - (bcStrings (8 "-0.0012" bu12 F)) - (bcStrings (8 "1.0e+21" bu13 F)) - (bcStrings (8 "0.002" bu14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter coefficients of the objective function, {\it cvec(n)}: ") - (text . "\newline ") - (bcStrings (8 "-0.02" c1 F)) - (bcStrings (8 "-0.2" c2 F)) - (bcStrings (8 "-0.2" c3 F)) - (bcStrings (8 "-0.2" c4 F)) - (bcStrings (8 "-0.2" c5 F)) - (bcStrings (8 "0.04" c6 F)) - (bcStrings (8 "0.04" c7 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter set of positive tolerances {\it featol(n+nclin)}:\newline ") - (bcStrings (9 "0.1053e-7" f1 F)) - (bcStrings (9 "0.1053e-7" f2 F)) - (bcStrings (9 "0.1053e-7" f3 F)) - (bcStrings (9 "0.1053e-7" f4 F)) - (bcStrings (9 "0.1053e-7" f5 F)) - (bcStrings (9 "0.1053e-7" f6 F)) - (bcStrings (9 "0.1053e-7" f7 F)) - (bcStrings (9 "0.1053e-7" f8 F)) - (bcStrings (9 "0.1053e-7" f9 F)) - (bcStrings (9 "0.1053e-7" f10 F)) - (bcStrings (9 "0.1053e-7" f11 F)) - (bcStrings (9 "0.1053e-7" f12 F)) - (bcStrings (9 "0.1053e-7" f13 F)) - (bcStrings (9 "0.1053e-7" f14 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of array {\it hess(nrowh,ncolh)}: \newline ") - (bcStrings (5 "2" h11 F)) - (bcStrings (5 "0" h12 F)) - (bcStrings (5 "0" h13 F)) - (bcStrings (5 "0" h14 F)) - (bcStrings (5 "0" h15 F)) - (bcStrings (5 "0" h16 F)) - (bcStrings (5 "0" h17 F)) - (text . "\newline ") - (bcStrings (5 "0" h21 F)) - (bcStrings (5 "2" h22 F)) - (bcStrings (5 "0" h23 F)) - (bcStrings (5 "0" h24 F)) - (bcStrings (5 "0" h25 F)) - (bcStrings (5 "0" h26 F)) - (bcStrings (5 "0" h27 F)) - (text . "\newline ") - (bcStrings (5 "0" h31 F)) - (bcStrings (5 "0" h32 F)) - (bcStrings (5 "2" h33 F)) - (bcStrings (5 "2" h34 F)) - (bcStrings (5 "0" h35 F)) - (bcStrings (5 "0" h36 F)) - (bcStrings (5 "0" h37 F)) - (text . "\newline ") - (bcStrings (5 "0" h41 F)) - (bcStrings (5 "0" h42 F)) - (bcStrings (5 "2" h43 F)) - (bcStrings (5 "2" h44 F)) - (bcStrings (5 "0" h45 F)) - (bcStrings (5 "0" h46 F)) - (bcStrings (5 "0" h47 F)) - (text . "\newline ") - (bcStrings (5 "0" h51 F)) - (bcStrings (5 "0" h52 F)) - (bcStrings (5 "0" h53 F)) - (bcStrings (5 "0" h54 F)) - (bcStrings (5 "2" h55 F)) - (bcStrings (5 "0" h56 F)) - (bcStrings (5 "0" h57 F)) - (text . "\newline ") - (bcStrings (5 "0" h61 F)) - (bcStrings (5 "0" h62 F)) - (bcStrings (5 "0" h63 F)) - (bcStrings (5 "0" h64 F)) - (bcStrings (5 "0" h65 F)) - (bcStrings (5 "-2" h66 F)) - (bcStrings (5 "-2" h67 F)) - (text . "\newline ") - (bcStrings (5 "0" h71 F)) - (bcStrings (5 "0" h72 F)) - (bcStrings (5 "0" h73 F)) - (bcStrings (5 "0" h74 F)) - (bcStrings (5 "0" h75 F)) - (bcStrings (5 "-2" h76 F)) - (bcStrings (5 "-2" h77 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector, {\it x(n)}: ") - (text . "\newline ") - (bcStrings (8 "-0.01" x1 F)) - (bcStrings (8 "-0.03" x2 F)) - (bcStrings (8 "0.0" x3 F)) - (bcStrings (8 "-0.01" x4 F)) - (bcStrings (8 "-0.1" x5 F)) - (bcStrings (8 "0.02" x6 F)) - (bcStrings (8 "0.01" x7 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "If {\it cold} = false enter {\it istate(n+nclin)} values: ") - (text . "\newline ") - (bcStrings (8 "0" i1 F)) - (bcStrings (8 "0" i2 F)) - (bcStrings (8 "0" i3 F)) - (bcStrings (8 "0" i4 F)) - (bcStrings (8 "0" i5 F)) - (bcStrings (8 "0" i6 F)) - (bcStrings (8 "0" i7 F)) - (bcStrings (8 "0" i8 F)) - (bcStrings (8 "0" i9 F)) - (bcStrings (8 "0" i10 F)) - (bcStrings (8 "0" i11 F)) - (bcStrings (8 "0" i12 F)) - (bcStrings (8 "0" i13 F)) - (bcStrings (8 "0" i14 F))) - htMakeDoneButton('"Continue",'e04nafGen) - htpSetProperty(page,'itmax,itmax) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'nrowh,nrowh) - htpSetProperty(page,'ncolh,ncolh) - htpSetProperty(page,'bigbnd,bigbnd) - htpSetProperty(page,'cold,cold) - htpSetProperty(page,'lp,lp) - htpSetProperty(page,'orthog,orthog) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04nafGen htPage == - itmax := htpProperty(htPage, 'itmax) - msglvl := htpProperty(htPage, 'msglvl) - n := htpProperty(htPage, 'n) - nclin := htpProperty(htPage, 'nclin) - nrowa := htpProperty(htPage, 'nrowa) - nrowh := htpProperty(htPage, 'nrowh) - ncolh := htpProperty(htPage, 'ncolh) - bigbnd := htpProperty(htPage, 'bigbnd) - cold := htpProperty(htPage, 'cold) - lp := htpProperty(htPage, 'lp) - orthog := htpProperty(htPage, 'orthog) - liwork := htpProperty(htPage,'liwork) - lwork := htpProperty(htPage,'lwork) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - ilist := [temp,:ilist] - y := rest y - istring := bcwords2liststring ilist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - for i in 1..nrowh repeat -- matrix H - for j in 1..ncolh repeat - h := STRCONC((first y).1," ") - hlist := [h,:hlist] - y := rest y - hmatlist := [:hmatlist,hlist] - hlist := [] - hmatlist := reverse hmatlist - hmatstr := bcwords2liststring [bcwords2liststring x for x in hmatlist] - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - flist := [temp,:flist] - y := rest y - fstring := bcwords2liststring flist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - clist := [temp,:clist] - y := rest y - cstring := bcwords2liststring clist - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - bulist := [temp,:bulist] - y := rest y - bustring := bcwords2liststring bulist - for i in 1..(n+nclin) repeat - temp := STRCONC ((first y).1," ") - bllist := [temp,:bllist] - y := rest y - blstring := bcwords2liststring bllist - for i in 1..nrowa repeat -- matrix A - for j in 1..n repeat - a := STRCONC((first y).1," ") - arrlist := [a,:arrlist] - y := rest y - amatlist := [:amatlist,arrlist] - arrlist := [] - amatlist := reverse amatlist - amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] - nctotl := n + nclin - prefix := STRCONC("e04naf(",STRINGIMAGE itmax,",", STRINGIMAGE msglvl,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,",",STRINGIMAGE nclin,", ") - prefix := STRCONC(prefix,STRINGIMAGE nctotl,",",STRINGIMAGE nrowa,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrowh,",",STRINGIMAGE ncolh,", ",bigbnd) - middle := STRCONC(", ",amatstr,",[") - middle := STRCONC(middle,blstring,"],[",bustring,"],[",cstring) - middle := STRCONC(middle,"],[",fstring,"],",hmatstr,",",STRINGIMAGE cold,",") - middle := STRCONC(middle,STRINGIMAGE lp,", ",STRINGIMAGE orthog,", ") - middle := STRCONC(middle,STRINGIMAGE liwork,",",STRINGIMAGE lwork,",[") - middle := STRCONC(middle,xstring,"],[",istring,"]::Matrix Integer,") - middle := STRCONC(middle,STRINGIMAGE ifail) - end := STRCONC(",((",hmatstr,")::Matrix Expression Float)::ASP20('QPHESS))") - linkGen STRCONC(prefix,middle,end) - -e04ucf() == - htInitPage('"E04UCF - Minimum, function of several variables, sequential QP method, nonlinear constraints, using function values and optionally 1st derivatives", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXe04ucf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04ucf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04UCF minimizes an arbitrary smooth function subject to ") - (text . "constraints which may include simple bounds on the variables, ") - (text . "linear constraints and smooth nonlinear constraints. As many ") - (text . "first partial derivatives as possible should be supplied by the ") - (text . "user, unspecified derivatives being estimated by finite ") - (text . "differences. \newline The routine solves problems of the form") - (text . "\center{\htbitmap{e04ucf}}\newline where the objective function ") - (text . "{\it F(x)} is nonlinear, \htbitmap{Al} is an \htbitmap{nl} by n ") - (text . "constant matrix and {\it c(x)} is an \htbitmap{nn} element ") - (text . "vector of nonlinear constraint functions. The objective function") - (text . " and constraint functions are assumed to be smooth (i.e. at ") - (text . "least twice continuously differentiable), although the method ") - (text . "will usually work if there are discontinuities away from the ") - (text . "solution. \blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the number of variables, {\it n}: ") - (text . "\newline ") - (bcStrings (5 4 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the number of general linear constraints, {\it nclin}: ") - (text . "\newline ") - (bcStrings (5 1 nclin PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the number of nonlinear constraints, {\it ncnln}: ") - (text . "\newline ") - (bcStrings (5 2 ncnln PI)) - (text . "\blankline ") - (text . "Change optional parameters:") - (radioButtons optional - ("" " No" no) - ("" " Yes" yes)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Start value:") - (radioButtons start - ("" " Cold start" false) - ("" " Warm start" true)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04ucfSolve) - htShowPage() - - -e04ucfSolve(htPage) == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nclin := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) - objValUnwrap htpLabelSpadValue(htPage, 'nclin) - ncnln := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncnln) - objValUnwrap htpLabelSpadValue(htPage, 'ncnln) - nrowa := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) - objValUnwrap htpLabelSpadValue(htPage, 'nrowa) - nrowj := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncnln) - objValUnwrap htpLabelSpadValue(htPage, 'nrowj) - nrowr := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'nrowr) - liwork := 3*n+nclin+2*ncnln - lwork := - (ncnln = '0 and nclin = '0) => 20*n - (ncnln = '0 and nclin > '0) => 2*n*n + 20*n + 11*nclin - (ncnln > '0 and nclin >= '0) => 2*n*n + n*nclin +2*n*ncnln + 20*n + 11*nclin + 21*ncnln - '1 - initial := htpButtonValue(htPage,'start) - start := - initial = 'true => '1 - '0 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - param := htpButtonValue(htPage,'optional) - optional := - param = 'no => '0 - '1 - ((n = '4 and optional = '0 and nclin=1 and ncnln=2) and (start = '0)) => - e04ucfDefaultSolve(htPage,nclin,ncnln,nrowa,nrowj,nrowr,liwork,lwork,ifail) - start = '1 => e04ucfCopOut() - optional := '1 - aList := - "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[8, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") - middle := STRCONC(middle,'"conditions {\it bl(n+nclin+ncnln)}: \newline ") - blList := - "append"/[fc(i) for i in 1..(n+nclin+ncnln)] where fc(i) == - blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) - [['bcStrings,[8, '"-1.E25", blnam, 'F]]] - blList := [['text,:middle],:blList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") - middle := STRCONC(middle,'"conditions {\it bu(n+nclin+ncnln)}: \newline ") - buList := - "append"/[fd(i) for i in 1..(n+nclin+ncnln)] where fd(i) == - bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) - [['bcStrings,[8, '"1.E25", bunam, 'F]]] - buList := [['text,:middle],:buList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the nonlinear ") - middle := STRCONC(middle,'"constraint functions {\it c(ncnln)} ") - middle := STRCONC(middle,'"in terms of X[1]...X[n]: \newline ") - cList := - "append"/[fe(i) for i in 1..ncnln] where fe(i) == - lineEnd := ('"\newline \tab{2} ") - cnam := INTERN STRCONC ('"c",STRINGIMAGE i) - [['text,:lineEnd],['bcStrings,[55, '"X[1]", cnam, 'F]]] - cList := [['text,:middle],:cList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the objective ") - middle := STRCONC(middle,'"function, {\it F(x)} ") - middle := STRCONC(middle,'"in terms of X[1]...X[n]: \newline ") - funcList := [['bcStrings,[55, '"X[1]", 'f, 'EM]]] - funcList := [['text,:middle],:funcList] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") - middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") - xList := - "append"/[fg(i) for i in 1..n] where fg(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[8, '"0.0", xnam, 'F]]] - xList := [['text,:middle],:xList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList,:blList,:buList,:cList,:funcList,:xList, - :'( - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Crash tolerance, {\it cra}: ") - (text . "\newline ") - (bcStrings (20 "0.01" cra F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Derivative level, {\it der}: ") - (text . "\newline ") - (bcStrings (5 3 der PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Feasibility tolerance, {\it fea}: ") - (text . "\newline ") - (bcStrings (20 "0.1053671201E-7" fea F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Function Precision, {\it fun}: ") - (text . "\newline ") - (bcStrings (20 "0.4373903510E-14" fun F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it r} is a Hessian matrix :") - (radioButtons hess - ("" " No" hFalse) - ("" " Yes" hTrue)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Infinite bound size, {\it infb}: ") - (text . "\newline ") - (bcStrings (20 "1.00E+15" infb F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Infinite step size, {\it infs}: ") - (text . "\newline ") - (bcStrings (20 "1.00E+15" infs F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Linear feasibility tolerance, {\it linf}: ") - (text . "\newline ") - (bcStrings (20 "0.1053671201E-7" linf F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Linesearch tolerance, {\it lint}: ") - (text . "\newline ") - (bcStrings (20 "0.9" lint F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "List parameters:") - (radioButtons list - ("" " No" false) - ("" " Yes" true)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Major iteration limit, {\it maji}: ") - (text . "\newline ") - (bcStrings (5 30 maji PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Major print level, {\it majp}: ") - (text . "\newline ") - (bcStrings (5 1 majp PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Minor iteration limit, {\it mini}: ") - (text . "\newline ") - (bcStrings (5 81 mini PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Minor print level, {\it minp}: ") - (text . "\newline ") - (bcStrings (5 0 minp PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Monitoring channel, {\it mon}. ") - (text . "(Ignored in Foundation Library version.) ") - (text . "\newline ") - (bcStrings (5 "-1" mon F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Nonlinear feasibiltity tolerance, {\it nonf}: ") - (text . "\newline ") - (bcStrings (20 "1.05E-08" nonf F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Optimality tolerance, {\it opt}: ") - (text . "\newline ") - (bcStrings (20 "3.26E-08" opt F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Step limit, {\it ste}: ") - (text . "\newline ") - (bcStrings (5 "2.0" ste F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Start objective check at variable, {\it stao}: ") - (text . "\newline ") - (bcStrings (5 1 stao PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Start constraint check at variable, {\it stac}: ") - (text . "\newline ") - (bcStrings (5 1 stac PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Stop objective check at variable, {\it stoo}: ") - (text . "\newline ") - (bcStrings (5 9 stoo PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Stop objective check at variable, {\it stoc}: ") - (text . "\newline ") - (bcStrings (5 9 stoc PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Verify level, {\it ver}: ") - (text . "\newline ") - (bcStrings (5 3 ver PI)))] - page := htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the elements of the array, {\it A(nrowa,n)}: " - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04ucfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'ncnln,ncnln) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'nrowj,nrowj) - htpSetProperty(page,'nrowr,nrowr) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'optional,optional) - htpSetProperty(page,'start,start) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04ucfDefaultSolve(htPage,nclin,ncnln,nrowa,nrowj,nrowr,liwork,lwork,ifail) == - n := '4 - optional := '0 - start := '0 - page := htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of the array {\it A(nrowa,n)}: ") - (text . "\newline ") - (bcStrings (4 "1.0" a11 F)) - (bcStrings (4 "1.0" a12 F)) - (bcStrings (4 "1.0" a13 F)) - (bcStrings (4 "1.0" a14 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the lower boundary conditions {\it bl(n+nclin+ncnln)}: ") - (text . "\newline ") - (bcStrings (8 "1.0" bl1 F)) - (bcStrings (8 "1.0" bl2 F)) - (bcStrings (8 "1.0" bl3 F)) - (bcStrings (8 "1.0" bl4 F)) - (bcStrings (8 "-1.E25" bl5 F)) - (bcStrings (8 "-1.E25" bl6 F)) - (bcStrings (8 "25.0" bl7 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the upper boundary conditions {\it bu(n+nclin+ncnln)}: ") - (text . "\newline ") - (bcStrings (8 "5.0" bu1 F)) - (bcStrings (8 "5.0" bu2 F)) - (bcStrings (8 "5.0" bu3 F)) - (bcStrings (8 "5.0" bu4 F)) - (bcStrings (8 "20.0" bu5 F)) - (bcStrings (8 "40.0" bu6 F)) - (bcStrings (8 "1.E25" bu7 F)) - -- no istate or clamda or r as default condition is cold - -- what about cjac when der = 3 ? - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the nonlinear constraint functions, {\it c(ncnln)} ") - (text . "in terms of X[1]...X[n]: ") - (text . "\newline ") - (bcStrings (55 "X[1]**2 + X[2]**2 + X[3]**2 + X[4]**2" cx1 EM)) - (text . "\newline ") - (bcStrings (55 "X[1]*X[2]*X[3]*X[4]" cx2 EM)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the objective function, {\it F(x)} ") - (text . "in terms of X[1]...X[n]: ") - (text . "\newline ") - (bcStrings (55 "X[1]*X[4]*(X[1] + X[2] + X[3]) + X[3]" of EM)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter initial guess of the solution vector, {\it x(n)}: \newline") - (bcStrings (8 "1.0" x1 F)) - (bcStrings (8 "5.0" x2 F)) - (bcStrings (8 "5.0" x3 F)) - (bcStrings (8 "1.0" x4 F))) - htMakeDoneButton('"Continue",'e04ucfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nclin,nclin) - htpSetProperty(page,'ncnln,ncnln) - htpSetProperty(page,'nrowa,nrowa) - htpSetProperty(page,'nrowj,nrowj) - htpSetProperty(page,'nrowr,nrowr) - htpSetProperty(page,'liwork,liwork) - htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'start,start) - htpSetProperty(page,'optional,optional) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -e04ucfGen htPage == - n := htpProperty(htPage,'n) - nclin := htpProperty(htPage,'nclin) - ncnln := htpProperty(htPage,'ncnln) - nrowa := htpProperty(htPage,'nrowa) - nrowj := htpProperty(htPage,'nrowj) - nrowr := htpProperty(htPage,'nrowr) - liwork := htpProperty(htPage,'liwork) - lwork := htpProperty(htPage,'lwork) - optional := htpProperty(htPage,'optional) - start := htpProperty(htPage,'start) - ifail := htpProperty(htPage,'ifail) - sta := 'false -- no warm start in HD - alist := htpInputAreaAlist htPage - y := alist - if (optional = '0) then - cra := '"0.01" - der := 3 - fea := '"0.1053671201E-7" - fun := '"0.4373903510E-14" - hes := 'true - infb := '"1.00E+15" - infs := '"1.00E+15" - linf := '"0.1053671201E-7" - lint := '"0.9" - lis := 'true - maji := 30 - majp := 1 - mini := 81 - minp := 0 - mon := '"-1" - nonf := '"1.05E-08" - opt := '"3.26E-08" - ste := '"2.0" - stao := 1 - stac := 1 - stoo := n - stoc := n - ver := 3 - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - f := (first y).1 - y := rest y - for i in 1..ncnln repeat - temp := STRCONC ((first y).1," ") - cxlist := [temp,:cxlist] - y := rest y - cxstring := bcwords2liststring cxlist - for i in 1..(n+nclin+ncnln) repeat - temp := STRCONC ((first y).1," ") - bulist := [temp,:bulist] - y := rest y - buu := bcwords2liststring bulist - for i in 1..(n+nclin+ncnln) repeat - temp := STRCONC ((first y).1," ") - bllist := [temp,:bllist] - y := rest y - bll := bcwords2liststring bllist - for i in 1..nrowa repeat -- matrix A - for j in 1..n repeat - a := STRCONC((first y).1," ") - arrlist := [a,:arrlist] - y := rest y - amatlist := [:amatlist,arrlist] - arrlist := [] - amatlist := reverse amatlist - amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] - else - ver := STRCONC((first y).1," ") - y := rest y - stoc := STRCONC((first y).1," ") - y := rest y - stoo := STRCONC((first y).1," ") - y := rest y - stac := STRCONC((first y).1," ") - y := rest y - stao := STRCONC((first y).1," ") - y := rest y - ste := STRCONC((first y).1," ") - y := rest y - opt := STRCONC((first y).1," ") - y := rest y - nonf := STRCONC((first y).1," ") - y := rest y - mon := STRCONC((first y).1," ") - y := rest y - minp := STRCONC((first y).1," ") - y := rest y - mini := STRCONC((first y).1," ") - y := rest y - majp := STRCONC((first y).1," ") - y := rest y - maji := STRCONC((first y).1," ") - y := rest y - nolist := (first y).1 - lis := - nolist = '" nil" => '"false" - '"true" - y := rest y - dummy1 := first y - y := rest y - lint := STRCONC((first y).1," ") - y := rest y - linf := STRCONC((first y).1," ") - y := rest y - infs := STRCONC((first y).1," ") - y := rest y - infb := STRCONC((first y).1," ") - y := rest y - noHess := (first y).1 - hes := - noHess = '" nil" => '"false" - '"true" - y := rest y - dummy2 := first y - y := rest y - fun := STRCONC((first y).1," ") - y := rest y - fea := STRCONC((first y).1," ") - y := rest y - der := STRCONC((first y).1," ") - y := rest y - cra := STRCONC((first y).1," ") - y := rest y - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - xlist := [temp,:xlist] - y := rest y - xstring := bcwords2liststring xlist - f := (first y).1 - y := rest y - for i in 1..ncnln repeat - temp := STRCONC ((first y).1," ") - cxlist := [temp,:cxlist] - y := rest y - cxstring := bcwords2liststring cxlist - for i in 1..(n+nclin+ncnln) repeat - temp := STRCONC ((first y).1," ") - bulist := [temp,:bulist] - y := rest y - buu := bcwords2liststring bulist - for i in 1..(n+nclin+ncnln) repeat - temp := STRCONC ((first y).1," ") - bllist := [temp,:bllist] - y := rest y - bll := bcwords2liststring bllist - for i in 1..nrowa repeat -- matrix A - for j in 1..n repeat - a := STRCONC((first y).1," ") - arrlist := [a,:arrlist] - y := rest y - amatlist := [:amatlist,arrlist] - arrlist := [] - amatlist := reverse amatlist - amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] - ntotl := n + nclin + ncnln - prefix := STRCONC("e04ucf(",STRINGIMAGE n,", ",STRINGIMAGE nclin,", ") - prefix := STRCONC(prefix,STRINGIMAGE ncnln,", ",STRINGIMAGE nrowa,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrowj,", ",STRINGIMAGE nrowr,", ") - prefix:= STRCONC(prefix,amatstr,",[",bll,"],[",buu,"],",STRINGIMAGE liwork) - prefix := STRCONC(prefix,", ",STRINGIMAGE lwork,", ",STRINGIMAGE sta,", ") - prefix := STRCONC(prefix,cra,", ",STRINGIMAGE der,", ",fea,", ") - prefix := STRCONC(prefix,fun,", ",hes,", ",infb,", ",infs,", ",linf,", ") - prefix := STRCONC(prefix,lint,", ",lis,", ",STRINGIMAGE maji,", ") - prefix := STRCONC(prefix,STRINGIMAGE majp,", ",STRINGIMAGE mini,", ") - prefix := STRCONC(prefix,STRINGIMAGE minp,", ",mon,", ",nonf,", ",opt,", ") - prefix := STRCONC(prefix,ste,", ",STRINGIMAGE stao,", ",STRINGIMAGE stac) - prefix := STRCONC(prefix,", ",STRINGIMAGE stoo,", ",STRINGIMAGE stoc,", ") - middle:= STRCONC(STRINGIMAGE ver,",[[0 for i in 1..",STRINGIMAGE ntotl,"]]") - middle:=STRCONC(middle,"::Matrix Integer,[[0.0 for i in 1..",STRINGIMAGE n) - middle:=STRCONC(middle,"] for j in 1..",STRINGIMAGE nrowj,"],[[0.0 for i in 1..") - middle := STRCONC(middle,STRINGIMAGE ntotl,"]],[[0.0 for i in 1..") - middle := STRCONC(middle,STRINGIMAGE n,"] for j in 1..",STRINGIMAGE nrowr) - middle := STRCONC(middle,"],[",xstring,"],",STRINGIMAGE ifail) - end:=STRCONC(",((",cxstring,")::Vector Expression(Float))::ASP55(CONFUN),") - end := STRCONC(end,"((",f,")::Expression(Float))::ASP49(OBJFUN))") - linkGen STRCONC(prefix,middle,end) - - -e04ucfCopOut() == - htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\blankline ") - (text . "{\center{\em Hyperdoc interface not available for warm start}}") - (text . "\newline ") - (text . "{\center{\em Please use the command line.}}")) - htMakeDoneButton('"Continue",'e04ucf) - htShowPage() - -e04ycf() == - htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXe04ycf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04ycf| '|NagOptimisationPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "E04YCF returns estimates of elements of the variance-covariance ") - (text . "matrix of the estimated regression coefficients for a nonlinear ") - (text . "least-squares problem. ") - (text . "\blankline ") - (text . "This routine may be used following any of the nonlinear ") - (text . "least-squares routines E04FDF, E04GCF. It ") - (text . "requires the parameters {\it fumsq, s} and {\it v} supplied ") - (text . "by those routines. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Elements of {\it c} returned, {\it job}: ") - (radioButtons job - (" 0" " The diagonal elements of {\it c} " jZero) - (" 1" " Elements of column {\it job} of {\it c} " jOne) - (" -1" " The whole {\it n} by {\it n} symmetric matrix " jMinus)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of observations, {\it m}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 15 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of variables, {\it n}: ") - (text . "\newline\tab{2} ") - (bcStrings (6 3 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Sum of the squares of the residuals, {\it fsumsq}: ") - (text . "\newline\tab{2} ") - (bcStrings (30 "0.0082148773065789729" fsumsq F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "First dimension of array {\it v}, {\it lv}:") - (text . "\newline\tab{2} ") - (bcStrings (6 3 lv PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'e04ycfSolve) - htShowPage() - -e04ycfSolve htPage == - temp := htpButtonValue(htPage,'job) - job := - temp = 'jMinus => '-1 - temp = 'jOne => '1 - '0 - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fsumsq := htpLabelInputString(htPage, 'fsumsq) - lv := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lv) - objValUnwrap htpLabelSpadValue(htPage, 'lv) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = 3 and lv = 3) => e04ycfDefaultSolve(htPage,job,m,fsumsq,ifail) - sList := - "append"/[fa(i) for i in 1..(n)] where fa(i) == - snam := INTERN STRCONC ('"s",STRINGIMAGE i) - [['bcStrings,[30, '"0.0", snam, 'F]]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the elements ") - middle := STRCONC(middle,'"of array {\it v(lv,n)}: \newline ") - vList := - "append"/[fb(i,n) for i in 1..lv] where fb(i,n) == - labelList := - "append"/[fc(i,j) for j in 1..n] where fc(i,j) == - vnam := INTERN STRCONC ('"v",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[15, 0, vnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - vList := [['text,:middle],:vList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))), - :sList,:vList] - page:= htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the elements of the array {\it s(n)}: \newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'e04ycfGen) - htpSetProperty(page,'job,job) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'fsumsq,fsumsq) - htpSetProperty(page,'lv,lv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04ycfDefaultSolve(htPage,job,m,fsumsq,ifail) == - n := '3 - lv := '3 - page:= htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of array {\it s(n)}: \newline ") - (bcStrings (30 "4.0965034571419325" s1 F)) - (bcStrings (30 "1.5949579400198182" s2 F)) - (bcStrings (30 "0.061258491120317927" s3 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the elements of array {\it v(lv,n)}: \newline ") - -- not the correct values yet ! - (bcStrings (8 "0.9354" v11 F)) - (bcStrings (8 "-0.2592" v12 F)) - (bcStrings (8 "-0.2405" v13 F)) - (text . "\newline ") - (bcStrings (8 "0.3530" v21 F)) - (bcStrings (8 "0.6432" v22 F)) - (bcStrings (8 "0.6795" v23 F)) - (text . "\newline ") - (bcStrings (8 "-0.0215" v31 F)) - (bcStrings (8 "-0.7205" v32 F)) - (bcStrings (8 "0.6932" v33 F))) - htMakeDoneButton('"Continue",'e04ycfGen) - htpSetProperty(page,'job,job) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'fsumsq,fsumsq) - htpSetProperty(page,'lv,lv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -e04ycfGen htPage == - job := htpProperty(htPage,'job) - n := htpProperty(htPage, 'n) - m := htpProperty(htPage, 'm) - fsumsq := htpProperty(htPage, 'fsumsq) - lv := htpProperty(htPage, 'lv) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..(lv*n) repeat - temp := STRCONC ((first y).1," ") - vlist := [temp,:vlist] - y := rest y - vstring := bcwords2liststring vlist - for i in 1..n repeat - temp := STRCONC ((first y).1," ") - slist := [temp,:slist] - y := rest y - sstring := bcwords2liststring slist - prefix := STRCONC("e04ycf(",STRINGIMAGE job,",", STRINGIMAGE m,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,",",fsumsq,", [") - prefix := STRCONC(prefix,sstring,"],", STRINGIMAGE lv,",[",vstring) - linkGen STRCONC(prefix,"],",STRINGIMAGE ifail,")") - - - - diff --git a/src/interp/nag-e04.boot.pamphlet b/src/interp/nag-e04.boot.pamphlet new file mode 100644 index 00000000..7a63d8e1 --- /dev/null +++ b/src/interp/nag-e04.boot.pamphlet @@ -0,0 +1,2520 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-e04.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +e04dgf() == + htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXe04dgf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04dgf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "E04DGF minimizes {\it F(x)}, an unconstrained nonlinear function") + (text . " of {\it n} variables, using a pre-conditioned quasi-Newton ") + (text . "conjugate gradient method. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the number of variables, {\it n}: ") + (text . "\newline ") + (bcStrings (5 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Change optional parameters:") + (radioButtons optional + ("" " No" no) + ("" " Yes" yes)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04dgfSolve) + htShowPage() + + +e04dgfSolve(htPage) == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + param := htpButtonValue(htPage,'optional) + optional := + param = 'no => '0 + '1 + (n = '2 and optional = 0) => e04dgfDefaultSolve(htPage,ifail,n,optional) + funcList := [['bcStrings,[55, '"exp(X[1])*(4*X[1]**2+2*X[2]**2+4*X[1]*X[2]+2*X[2]+1)", 'f, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + middle := cons('text,middle) + vecList := + n='2 => + [['bcStrings,[8,-1.0,'x1,'F]],['bcStrings,[8,1.0,'x2,'F]]] + [fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ['bcStrings,[8, -1.0, xnam, 'F]] + funcList := [:funcList,middle,:vecList] + if optional = 1 then + opt1Text := '"\blankline \menuitemstyle{}\tab{2} " + opt1Text := STRCONC(opt1Text,'"Estimated optimal function values, {\it es}: \newline ") + optList := [['text,:opt1Text],['bcStrings,[20, 1.0, 'es, 'F]]] + opt2Text := '"\blankline \menuitemstyle{}\tab{2} " + opt2Text := STRCONC(opt2Text,'"Function precision, {\it fu}: \newline ") + optList := [:optList,:[['text,:opt2Text],['bcStrings,[20,"0.4373903597E-14",'fu,'F]]]] + opt3Text := '"\blankline \menuitemstyle{}\tab{2} " + opt3Text := STRCONC(opt3Text,'"Iteration limit, {\it it}: \newline ") + optList := [:optList,:[['text,:opt3Text],['bcStrings,[5,50,'it,'PI]]]] + opt4Text := '"\blankline \menuitemstyle{}\tab{2} " + opt4Text := STRCONC(opt4Text,'"Linesearch tolerance, {\it lin}: \newline ") + optList := [:optList,:[['text,:opt4Text],['bcStrings,[20,"0.9",'lin,'F]]]] + opt5Text := '"\blankline \menuitemstyle{}\tab{2} " + opt5Text := STRCONC(opt5Text,'"List parameters:") + optList := [:optList,:[['text,:opt5Text],['radioButtons,'lis,:[[""," Yes",'true],[""," No",'false]]]]] + opt6Text := '"\blankline \menuitemstyle{}\tab{2} " + opt6Text := STRCONC(opt6Text,'"Maximum step length, {\it ma}: \newline ") + optList := [:optList,:[['text,:opt6Text],['bcStrings,[20,"1.0E+20",'ma,'F]]]] + opt7Text := '"\blankline \menuitemstyle{}\tab{2} " + opt7Text := STRCONC(opt7Text,'"Optimality tolerance, {\it op}: \newline ") + optList := [:optList,:[['text,:opt7Text],['bcStrings,[20,"3.26E-12",'op,'F]]]] + opt9Text := '"\blankline \menuitemstyle{}\tab{2} " + opt9Text := STRCONC(opt9Text,'"Print level, {\it pr}: \newline ") + optList := [:optList,:[['text,:opt9Text],['bcStrings,[5,10,'pr,'PI]]]] + opt10Text := '"\blankline \menuitemstyle{}\tab{2} " + opt10Text := STRCONC(opt10Text,'"Start objective check at variable, {\it sta}: \newline ") + optList := [:optList,:[['text,:opt10Text],['bcStrings,[5,1,'sta,'PI]]]] + opt11Text := '"\blankline \menuitemstyle{}\tab{2} " + opt11Text := STRCONC(opt11Text,'"Stop objective check at variable, {\it sto}: \newline ") + optList := [:optList,:[['text,:opt11Text],['bcStrings,[5,2,'sto,'PI]]]] + opt12Text := '"\blankline \menuitemstyle{}\tab{2} " + opt12Text := STRCONC(opt12Text,'"Verify level, {\it ver}: \newline ") + optList := [:optList,:[['text,:opt12Text],['bcStrings,[5,0,'ver,'PI]]]] + +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "List parameters:") +-- (radioButtons lis +-- ("" " Yes" true) +-- ("" " No" false)) + else + optList := [] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList, + :optList] + page := htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the objective function, {\it F(x)} in terms of X[1]...X[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04dgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'optional,optional) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04dgfDefaultSolve(htPage,ifail,n,optional) == + page := htInitPage('"E04DGF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the objective function, {\it F(x)} in terms of X[1]...X[n]: ") + (text . "\newline ") + (bcStrings (55 "exp(X[1])*(4*X[1]**2+2*X[2]**2+4*X[1]*X[2]+2*X[2]+1)" f EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector, {\it x(n)}: \newline") + (bcStrings (8 "-1.0" x1 F)) + (bcStrings (8 "1.0" x2 F))) + htMakeDoneButton('"Continue",'e04dgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'optional,optional) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04dgfGen htPage == + n := htpProperty(htPage,'n) + optional := htpProperty(htPage,'optional) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + if (optional = '0) then + es := '"1.0" + ma := '"1.0E+20" + op := '"3.26E-12" + lin := '"0.9" + fu := '"0.4373903597E-14" + it := 50 + pr := 10 + sta := 1 + sto := 2 + ver := 0 + lis := '"true" + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + f := (first y).1 + else + ver := STRCONC((first y).1," ") + y := rest y + sto := STRCONC((first y).1," ") + y := rest y + sta := STRCONC((first y).1," ") + y := rest y + pr := STRCONC((first y).1," ") + y := rest y + op := STRCONC((first y).1," ") + y := rest y + ma := STRCONC((first y).1," ") + y := rest y + nolist := (first y).1 + lis := + nolist = '" t" => '"false" + '"true" + y := rest y + dummy := first y + y := rest y + lin := STRCONC((first y).1," ") + y := rest y + it := STRCONC((first y).1," ") + y := rest y + fu := STRCONC((first y).1," ") + y := rest y + es := STRCONC((first y).1," ") + y := rest y + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + f := (first y).1 + prefix := STRCONC("e04dgf(",STRINGIMAGE n,", ",es,", ",fu,",") + prefix := STRCONC(prefix,STRINGIMAGE it,", ",lin,", ",lis,", ",ma,", ",op) + prefix := STRCONC(prefix,",",STRINGIMAGE pr,", ",STRINGIMAGE sta,", ") + middle := STRCONC(STRINGIMAGE sto,", ",STRINGIMAGE ver,", [",xstring,"] ,") + middle := STRCONC(middle,STRINGIMAGE ifail," ,") + linkGen STRCONC (prefix,middle,"((",f,")::Expression(Float))::ASP49(OBJFUN))") + +e04fdf() == + htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe04fdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04fdf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04FDF is an easy to use routine for finding an unconstrained ") + (text . "minimum of a sum of squares of {\it m} nonlinear functions in ") + (text . "{\it n} variables ({\it m} \htbitmap{great=} {\it n}), i.e., it ") + (text . "is applicable to problems of the form ") + (text . "\center{\htbitmap{e04fdf}} where \center{\htbitmap{e04fdf1}}") + (text . "No derivatives are required. The routine is intended for ") + (text . "functions which have continous first and second derivatives, ") + (text . "though it will usually work if the derivatives have occasional ") + (text . "discontinuities. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of functions {\it \htbitmap{fi}(x)}, {\it m}:") + (text . "\newline\tab{2} ") + (bcStrings (5 15 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables \htbitmap{xj}, {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it iw}, {\it liw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 1 liw F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it w}, {\it lw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 171 lw F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04fdfSolve) + htShowPage() + +e04fdfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + liw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) + objValUnwrap htpLabelSpadValue(htPage, 'liw) + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '15 and n = '3) => e04fdfDefaultSolve(htPage,liw,lw,ifail) + funcList := + "append"/[fa(i) for i in 1..m] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := ('"XC[1] + 1") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + middle := cons('text,middle) + vecList := + [fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ['bcStrings,[4, '"0.0", xnam, 'F]] + funcList := [:funcList,middle,:vecList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList] + page:= htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions \htbitmap{fi} below in terms XC[1]...XC[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04fdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04fdfDefaultSolve (htPage,liw,lw,ifail) == + n := '3 + m := '15 + page:= htInitPage('"E04FDF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using function values only",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{fi} below ") + (text . "in terms of XC[1]...XC[n]: ") + (text . "\newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (42 "(XC[3]+15*XC[2])**(-1)+XC[1]-0.14" n1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (42 "2*(2*XC[3]+14*XC[2])**(-1)+XC[1]-0.18" n2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (42 "3*(3*XC[3]+13*XC[2])**(-1)+XC[1]-0.22" n3 EM)) + (text . "\newline {\em Function 4:} \space{1}") + (bcStrings (42 "4*(4*XC[3]+12*XC[2])**(-1)+XC[1]-0.25" n4 EM)) + (text . "\newline {\em Function 5:} \space{1}") + (bcStrings (42 "5*(5*XC[3]+11*XC[2])**(-1)+XC[1]-0.29" n5 EM)) + (text . "\newline {\em Function 6:} \space{1}") + (bcStrings (42 "6*(6*XC[3]+10*XC[2])**(-1)+XC[1]-0.32" n6 EM)) + (text . "\newline {\em Function 7:} \space{1}") + (bcStrings (42 "7*(7*XC[3]+9*XC[2])**(-1)+XC[1]-0.35" n7 EM)) + (text . "\newline {\em Function 8:} \space{1}") + (bcStrings (42 "8*(8*XC[3]+8*XC[2])**(-1)+XC[1]-0.39" n8 EM)) + (text . "\newline {\em Function 9:} \space{1}") + (bcStrings (42 "9*(7*XC[3]+7*XC[2])**(-1)+XC[1]-0.37" n9 EM)) + (text . "\newline {\em Function 10:} \space{1}") + (bcStrings (42 "10*(6*XC[3]+6*XC[2])**(-1)+XC[1]-0.58" n10 EM)) + (text . "\newline {\em Function 11:} \space{1}") + (bcStrings (42 "11*(5*XC[3]+5*XC[2])**(-1)+XC[1]-0.73" n11 EM)) + (text . "\newline {\em Function 12:} \space{1}") + (bcStrings (42 "12*(4*XC[3]+4*XC[2])**(-1)+XC[1]-0.96" n12 EM)) + (text . "\newline {\em Function 13:} \space{1}") + (bcStrings (42 "13*(3*XC[3]+3*XC[2])**(-1)+XC[1]-1.34" n13 EM)) + (text . "\newline {\em Function 14:} \space{1}") + (bcStrings (42 "14*(2*XC[3]+2*XC[2])**(-1)+XC[1]-2.1" n14 EM)) + (text . "\newline {\em Function 15:} \space{1}") + (bcStrings (42 "15*(XC[3]+XC[2])**(-1)+XC[1]-4.39" n15 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") + (bcStrings (4 "0.5" x1 F)) + (bcStrings (4 "1.0" x2 F)) + (bcStrings (4 "1.5" x3 F))) + htMakeDoneButton('"Continue",'e04fdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04fdfGen htPage == + n := htpProperty(htPage, 'n) + m := htpProperty(htPage, 'm) + liw := htpProperty(htPage,'liw) + lw := htpProperty(htPage,'lw) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + for i in 1..m repeat + temp := STRCONC ((first y).1," ") + ulist := [temp,:ulist] + y := rest y + ustring := bcwords2liststring ulist + prefix := STRCONC("e04fdf(",STRINGIMAGE m,",",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") + middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",") + linkGen STRCONC(prefix,middle,"(",ustring,"::Vector Expression(Float))::ASP50(LSFUN1))") + + +e04gcf() == + htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe04gcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04gcf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04GCF is an easy to use quasi-Newton routine for finding an unconstrained ") + (text . "minimum of a sum of squares of {\it m} nonlinear functions in ") + (text . "{\it n} variables ({\it m} \htbitmap{great=} {\it n}), i.e., it ") + (text . "is applicable to problems of the form ") + (text . "\center{\htbitmap{e04fdf}} where \center{\htbitmap{e04fdf1}}") + (text . "The routine is intended for ") + (text . "functions which have continous first and second derivatives, ") + (text . "though it will usually work if the derivatives have occasional ") + (text . "discontinuities. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of functions {\it \htbitmap{fi}(x)}, {\it m}:") + (text . "\newline\tab{2} ") + (bcStrings (5 15 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables \htbitmap{xj}, {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 3 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it iw}, {\it liw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 1 liw F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it w}, {\it lw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 177 lw F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04gcfSolve) + htShowPage() + +e04gcfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + liw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) + objValUnwrap htpLabelSpadValue(htPage, 'liw) + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '15 and n = '3) => e04gcfDefaultSolve(htPage,liw,lw,ifail) + funcList := + "append"/[fa(i) for i in 1..m] where fa(i) == + prefix := ('"\newline {\em Function ") + prefix := STRCONC(prefix,STRINGIMAGE i,'":} \space{1}") + funct := ('"XC[1] + 1") + nam := INTERN STRCONC ('"n",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[42, funct, nam, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + middle := cons('text,middle) + vecList := + [fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + ['bcStrings,[4, '"0.0", xnam, 'F]] + funcList := [:funcList,middle,:vecList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList] + page:= htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the functions \htbitmap{fi} below in terms of XC[1]...XC[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04gcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04gcfDefaultSolve (htPage,liw,lw,ifail) == + n := '3 + m := '15 + page:= htInitPage('"E04GCF - Unconstrained minimum of a sum of squares, combined Gauss-Newton and modified Newton algorithm using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the functions \htbitmap{fi} below ") + (text . "in terms of XC[1]...XC[n]: ") + (text . "\newline ") + (text . "\newline {\em Function 1:} \space{1}") + (bcStrings (42 "(XC[3]+15*XC[2])**(-1)+XC[1]-0.14" n1 EM)) + (text . "\newline {\em Function 2:} \space{1}") + (bcStrings (42 "2*(2*XC[3]+14*XC[2])**(-1)+XC[1]-0.18" n2 EM)) + (text . "\newline {\em Function 3:} \space{1}") + (bcStrings (42 "3*(3*XC[3]+13*XC[2])**(-1)+XC[1]-0.22" n3 EM)) + (text . "\newline {\em Function 4:} \space{1}") + (bcStrings (42 "4*(4*XC[3]+12*XC[2])**(-1)+XC[1]-0.25" n4 EM)) + (text . "\newline {\em Function 5:} \space{1}") + (bcStrings (42 "5*(5*XC[3]+11*XC[2])**(-1)+XC[1]-0.29" n5 EM)) + (text . "\newline {\em Function 6:} \space{1}") + (bcStrings (42 "6*(6*XC[3]+10*XC[2])**(-1)+XC[1]-0.32" n6 EM)) + (text . "\newline {\em Function 7:} \space{1}") + (bcStrings (42 "7*(7*XC[3]+9*XC[2])**(-1)+XC[1]-0.35" n7 EM)) + (text . "\newline {\em Function 8:} \space{1}") + (bcStrings (42 "8*(8*XC[3]+8*XC[2])**(-1)+XC[1]-0.39" n8 EM)) + (text . "\newline {\em Function 9:} \space{1}") + (bcStrings (42 "9*(7*XC[3]+7*XC[2])**(-1)+XC[1]-0.37" n9 EM)) + (text . "\newline {\em Function 10:} \space{1}") + (bcStrings (42 "10*(6*XC[3]+6*XC[2])**(-1)+XC[1]-0.58" n10 EM)) + (text . "\newline {\em Function 11:} \space{1}") + (bcStrings (42 "11*(5*XC[3]+5*XC[2])**(-1)+XC[1]-0.73" n11 EM)) + (text . "\newline {\em Function 12:} \space{1}") + (bcStrings (42 "12*(4*XC[3]+4*XC[2])**(-1)+XC[1]-0.96" n12 EM)) + (text . "\newline {\em Function 13:} \space{1}") + (bcStrings (42 "13*(3*XC[3]+3*XC[2])**(-1)+XC[1]-1.34" n13 EM)) + (text . "\newline {\em Function 14:} \space{1}") + (bcStrings (42 "14*(2*XC[3]+2*XC[2])**(-1)+XC[1]-2.1" n14 EM)) + (text . "\newline {\em Function 15:} \space{1}") + (bcStrings (42 "15*(XC[3]+XC[2])**(-1)+XC[1]-4.39" n15 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") + (bcStrings (4 "0.5" x1 F)) + (bcStrings (4 "1.0" x2 F)) + (bcStrings (4 "1.5" x3 F))) + htMakeDoneButton('"Continue",'e04gcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04gcfGen htPage == + n := htpProperty(htPage, 'n) + m := htpProperty(htPage, 'm) + liw := htpProperty(htPage,'liw) + lw := htpProperty(htPage,'lw) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + for i in 1..m repeat + temp := STRCONC ((first y).1," ") + ulist := [temp,:ulist] + y := rest y + ustring := bcwords2liststring ulist + prefix := STRCONC("e04gcf(",STRINGIMAGE m,",",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") + middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",") + linkGen STRCONC(prefix,middle,"(",ustring,"::Vector Expression(Float))::ASP19(LSFUN2))") + + +e04jaf() == + htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXe04jaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04jaf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04JAF is an easy to use quasi-Newton routine for finding a ") + (text . "minimum of a nonlinear function {\it F(x)} of {\it n} variables ") + (text . "\center{\htbitmap{e04fdf1}} possibly subject to fixed upper ") + (text . "and lower bounds on the variables, i.e., it is applicable to ") + (text . "problems of the form \blankline Minimize {\it F(x)}, subject to ") + (text . "\htbitmap{lj} \htbitmap{great=} \htbitmap{xj} \htbitmap{great=} ") + (text . "\htbitmap{uj} for {\it j} = 1,2,...,n. \blankline ") + (text . "Function values only are required. The routine is intended for ") + (text . "functions which have continuous first and second derivatives, ") + (text . "though it will usually work if the derivatives have occasional ") + (text . "discontinuities. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables \htbitmap{xj}, {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 4 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Specify the use of bounds, {\it ibound}:") + (radioButtons ibound + (" 0" " All \htbitmap{lj} and \htbitmap{uj} are given individually" iZero) + (" 1" " No bounds on any of the \htbitmap{xj}" iOne) + (" 2" " All bounds are of the form 0 \htbitmap{great=} \htbitmap{xj}" iTwo) + (" 3" " All \htbitmap{lj} are equal and all \htbitmap{uj} are equal" iThree)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it iw}, {\it liw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 6 liw F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it w}, {\it lw}:") + (text . "\newline\tab{2} ") + (bcStrings (5 54 lw F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04jafSolve) + htShowPage() + +e04jafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + boun := htpButtonValue(htPage,'ibound) + ibound := + boun = 'iZero => '0 + boun = 'iOne => '1 + boun = 'iTwo => '2 + '3 + liw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liw) + objValUnwrap htpLabelSpadValue(htPage, 'liw) + lw := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lw) + objValUnwrap htpLabelSpadValue(htPage, 'lw) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => e04jafDefaultSolve(htPage,ibound,liw,lw,ifail) + funcList := [['bcStrings,[50, '"XC[1]", 'f, 'EM]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary conditions ") + middle := STRCONC(middle,'"{\it bl(n)}: \newline ") + blList := + "append"/[fa(i) for i in 1..n] where fa(i) == + xnam := INTERN STRCONC ('"bl",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + blList := [['text,:middle],:blList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") + middle := STRCONC(middle,'"conditions {\it bu(n)}: \newline ") + buList := + "append"/[fb(i) for i in 1..n] where fb(i) == + xnam := INTERN STRCONC ('"bu",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + buList := [['text,:middle],:buList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + xList := + "append"/[fc(i) for i in 1..n] where fc(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + xList := [['text,:middle],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :funcList,:blList,:buList,:xList] + page:= htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the function {\it F(x)} below in terms of XC[1]...XC[n]: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04jafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ibound,ibound) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04jafDefaultSolve (htPage,ibound,liw,lw,ifail) == + n := '4 + page:= htInitPage('"E04JAF - Minimum, function of several variables, quasi-Newton algorithm, simple bounds, using function values only",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the function {\it F(x)} below in terms of XC[1]...XC[n]: ") + (text . "\newline ") + (bcStrings (60 "(XC[1]+10*XC[2])**2+5*(XC[3]-XC[4])**2+(XC[2]-2*XC[3])**4+10*(XC[1]-XC[4])**4" n1 EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter lower boundary conditions {\it bl(n)}: \newline ") + (bcStrings (8 "1" bl1 F)) + (bcStrings (8 "-2" bl2 F)) + (bcStrings (8 "-1.0e-6" bl3 F)) + (bcStrings (8 "1" bl4 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter upper boundary conditions {\it bu(n)}: \newline ") + (bcStrings (8 "3" bu1 F)) + (bcStrings (8 "0" bu2 F)) + (bcStrings (8 "1.0e6" bu3 F)) + (bcStrings (8 "3" bu4 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector {\it x(n)}: \newline ") + (bcStrings (8 "3" x1 F)) + (bcStrings (8 "-1" x2 F)) + (bcStrings (8 "0" x3 F)) + (bcStrings (8 "1" x4 F))) + htMakeDoneButton('"Continue",'e04jafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'ibound,ibound) + htpSetProperty(page,'liw,liw) + htpSetProperty(page,'lw,lw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04jafGen htPage == + n := htpProperty(htPage, 'n) + ibound := htpProperty(htPage, 'ibound) + liw := htpProperty(htPage,'liw) + lw := htpProperty(htPage,'lw) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + bulist := [temp,:bulist] + y := rest y + bustring := bcwords2liststring bulist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + bllist := [temp,:bllist] + y := rest y + blstring := bcwords2liststring bllist + f := (first y).1 + prefix := STRCONC("e04jaf(",STRINGIMAGE n,",",STRINGIMAGE ibound,", ") + prefix := STRCONC(prefix,STRINGIMAGE liw,",",STRINGIMAGE lw,", [") + prefix := STRCONC(prefix,blstring,"],[",bustring,"],[") + middle := STRCONC(xstring,"],",STRINGIMAGE ifail,",(") + linkGen STRCONC(prefix,middle,f,"::Expression(Float))::ASP24(FUNCT1))") + + +e04mbf() == + htInitPage('"E04MBF - Linear programming problem",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXe04mbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04mbf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04MBF is an easy to use routine to solve linear programming ") + (text . "(LP) problems of the form \center{\htbitmap{e04mbf}} \newline ") + (text . "where {\it c} is an {\it n} element vector and {\it A} is an ") + (text . "{\it m} by {\it n} matrix, i.e., there are {\it n} variables ") + (text . "and {\it m} linear constraints. {\it m} may be zero in which ") + (text . "case the LP problem is subject only to bounds on the variables. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Upper bound on number of iterations, {\it itmax}:") + (text . "\newline\tab{2} ") + (bcStrings (6 20 itmax PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Type of output messages required, {\it msglvl}: ") + (radioButtons msglvl + (" = 1 " " Printing occurs at the solution " mOne) + (" = 0 " " Printing only if an input parameter is incorrect " mZero) + (" < 0 " " No printing " mMinus)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables, {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of general linear constraints, {\it nclin}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 nclin PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "First dimension of array {\it a}, {\it nrowa}:") + (text . "\newline\tab{2} ") + (bcStrings (6 7 nrowa PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Specifies whether or not a linear objective function is present, {\it linobj}:") + (radioButtons linobj + ("" " true - full LP problem is solved" true) + ("" " false - only a feasible problem is found" false)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Dimension of {\it iwork}, {\it liwork}:") + (text . "\newline\tab{2} ") + (bcStrings (5 14 liwork F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it work}, {\it lwork}:") + (text . "\newline\tab{2} ") + (bcStrings (5 182 lwork F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04mbfSolve) + htShowPage() + +e04mbfSolve htPage == + itmax := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itmax) + objValUnwrap htpLabelSpadValue(htPage, 'itmax) + msg := htpButtonValue(htPage,'msglvl) + msglvl := + msg = 'mMinus => '-1 + msg = 'mZero => '0 + '1 + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nclin := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) + objValUnwrap htpLabelSpadValue(htPage, 'nclin) + nrowa := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowa) + objValUnwrap htpLabelSpadValue(htPage, 'nrowa) + lin := htpButtonValue(htPage,'linobj) + linobj := + lin = 'true => '"true" + '"false" + liwork := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liwork) + objValUnwrap htpLabelSpadValue(htPage, 'liwork) + lwork := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) + objValUnwrap htpLabelSpadValue(htPage, 'lwork) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((nrowa = '7 and n = 7) and nclin = 7) => e04mbfDefaultSolve(htPage,itmax,msglvl,linobj,liwork,lwork,ifail) + aList := + "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[8, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") + middle := STRCONC(middle,'"conditions {\it bl(n + nclin)}: \newline ") + blList := + "append"/[fc(i) for i in 1..(n+nclin)] where fc(i) == + blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", blnam, 'F]]] + blList := [['text,:middle],:blList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") + middle := STRCONC(middle,'"conditions {\it bu(n+nclin)}: \newline ") + buList := + "append"/[fd(i) for i in 1..(n+nclin)] where fd(i) == + bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", bunam, 'F]]] + buList := [['text,:middle],:buList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter coefficients of the ") + middle := STRCONC(middle,'"objective function {\it cvec(n)}: \newline ") + cList := + "append"/[fe(i) for i in 1..n] where fe(i) == + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", cnam, 'F]]] + cList := [['text,:middle],:cList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + xList := + "append"/[fg(i) for i in 1..n] where fg(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + xList := [['text,:middle],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList,:blList,:buList,:cList,:xList] + page:= htInitPage('"E04MBF - Linear programming problem",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the elements of the array {\it a(nrowa,n)}: \newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04mbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'itmax,itmax) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'linobj,linobj) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04mbfDefaultSolve(htPage,itmax,msglvl,linobj,liwork,lwork,ifail) == + n := '7 + nclin := '7 + nrowa := '7 + page:= htInitPage('"E04MBF - Linear programming problem",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of array {\it a(nrowa,n)}: \newline ") + (bcStrings (5 "1" a11 F)) + (bcStrings (5 "1" a12 F)) + (bcStrings (5 "1" a13 F)) + (bcStrings (5 "1" a14 F)) + (bcStrings (5 "1" a15 F)) + (bcStrings (5 "1" a16 F)) + (bcStrings (5 "1" a17 F)) + (text . "\newline ") + (bcStrings (5 "0.15" a21 F)) + (bcStrings (5 "0.04" a22 F)) + (bcStrings (5 "0.02" a23 F)) + (bcStrings (5 "0.04" a24 F)) + (bcStrings (5 "0.02" a25 F)) + (bcStrings (5 "0.01" a26 F)) + (bcStrings (5 "0.03" a27 F)) + (text . "\newline ") + (bcStrings (5 "0.03" a31 F)) + (bcStrings (5 "0.05" a32 F)) + (bcStrings (5 "0.08" a33 F)) + (bcStrings (5 "0.02" a34 F)) + (bcStrings (5 "0.06" a35 F)) + (bcStrings (5 "0.01" a36 F)) + (bcStrings (5 "0" a37 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a41 F)) + (bcStrings (5 "0.04" a42 F)) + (bcStrings (5 "0.01" a43 F)) + (bcStrings (5 "0.02" a44 F)) + (bcStrings (5 "0.02" a45 F)) + (bcStrings (5 "0" a46 F)) + (bcStrings (5 "0" a47 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a51 F)) + (bcStrings (5 "0.03" a52 F)) + (bcStrings (5 "0" a53 F)) + (bcStrings (5 "0" a54 F)) + (bcStrings (5 "0.01" a55 F)) + (bcStrings (5 "0" a56 F)) + (bcStrings (5 "0" a57 F)) + (text . "\newline ") + (bcStrings (5 "0.7" a61 F)) + (bcStrings (5 "0.75" a62 F)) + (bcStrings (5 "0.8" a63 F)) + (bcStrings (5 "0.75" a64 F)) + (bcStrings (5 "0.8" a65 F)) + (bcStrings (5 "0.97" a66 F)) + (bcStrings (5 "0" a67 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a71 F)) + (bcStrings (5 "0.06" a72 F)) + (bcStrings (5 "0.08" a73 F)) + (bcStrings (5 "0.12" a74 F)) + (bcStrings (5 "0.02" a75 F)) + (bcStrings (5 "0.01" a76 F)) + (bcStrings (5 "0.97" a77 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter lower boundary conditions {\it bl(n+nclin)}: \newline ") + (bcStrings (8 "-0.01" bl1 F)) + (bcStrings (8 "-0.1" bl2 F)) + (bcStrings (8 "-0.01" bl3 F)) + (bcStrings (8 "-0.04" bl4 F)) + (bcStrings (8 "-0.1" bl5 F)) + (bcStrings (8 "-0.01" bl6 F)) + (bcStrings (8 "-0.01" bl7 F)) + (bcStrings (8 "-0.13" bl8 F)) + (bcStrings (8 "-1.0e+21" bl9 F)) + (bcStrings (8 "-1.0e+21" bl10 F)) + (bcStrings (8 "-1.0e+21" bl11 F)) + (bcStrings (8 "-1.0e+21" bl12 F)) + (bcStrings (8 "-0.0992" bl13 F)) + (bcStrings (8 "-0.003" bl14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter upper boundary conditions {\it bu(n+nclin)}: \newline ") + (bcStrings (8 "0.01" bu1 F)) + (bcStrings (8 "0.15" bu2 F)) + (bcStrings (8 "0.03" bu3 F)) + (bcStrings (8 "0.02" bu4 F)) + (bcStrings (8 "0.05" bu5 F)) + (bcStrings (8 "1.0e+21" bu6 F)) + (bcStrings (8 "1.0e+21" bu7 F)) + (bcStrings (8 "-0.13" bu8 F)) + (bcStrings (8 "-0.0049" bu9 F)) + (bcStrings (8 "-0.0064" bu10 F)) + (bcStrings (8 "-0.0037" bu11 F)) + (bcStrings (8 "-0.0012" bu12 F)) + (bcStrings (8 "1.0e+21" bu13 F)) + (bcStrings (8 "0.002" bu14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter coefficients of the objective function, {\it cvec(n)}: ") + (text . "\newline ") + (bcStrings (8 "-0.02" c1 F)) + (bcStrings (8 "-0.2" c2 F)) + (bcStrings (8 "-0.2" c3 F)) + (bcStrings (8 "-0.2" c4 F)) + (bcStrings (8 "-0.2" c5 F)) + (bcStrings (8 "0.04" c6 F)) + (bcStrings (8 "0.04" c7 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector, {\it x(n)}: ") + (text . "\newline ") + (bcStrings (8 "-0.01" x1 F)) + (bcStrings (8 "-0.03" x2 F)) + (bcStrings (8 "0.0" x3 F)) + (bcStrings (8 "-0.01" x4 F)) + (bcStrings (8 "-0.1" x5 F)) + (bcStrings (8 "0.02" x6 F)) + (bcStrings (8 "0.01" x7 F))) + htMakeDoneButton('"Continue",'e04mbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'itmax,itmax) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'linobj,linobj) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04mbfGen htPage == + n := htpProperty(htPage, 'n) + nclin := htpProperty(htPage, 'nclin) + nrowa := htpProperty(htPage, 'nrowa) + itmax := htpProperty(htPage, 'itmax) + msglvl := htpProperty(htPage, 'msglvl) + linobj := htpProperty(htPage, 'linobj) + liwork := htpProperty(htPage,'liwork) + lwork := htpProperty(htPage,'lwork) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + clist := [temp,:clist] + y := rest y + cstring := bcwords2liststring clist + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + bulist := [temp,:bulist] + y := rest y + bustring := bcwords2liststring bulist + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + bllist := [temp,:bllist] + y := rest y + blstring := bcwords2liststring bllist + for i in 1..nrowa repeat -- matrix A + for j in 1..n repeat + a := STRCONC((first y).1," ") + arrlist := [a,:arrlist] + y := rest y + amatlist := [:amatlist,arrlist] + arrlist := [] + amatlist := reverse amatlist + amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] + nctotl := n + nclin + prefix := STRCONC("e04mbf(",STRINGIMAGE itmax,",", STRINGIMAGE msglvl,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,",",STRINGIMAGE nclin,", ") + prefix := STRCONC(prefix,STRINGIMAGE nctotl,",",STRINGIMAGE nrowa,", ") + middle := STRCONC(amatstr,",[") + middle := STRCONC(middle,blstring,"],[",bustring,"],[",cstring) + middle := STRCONC(middle,"],",linobj,", ",STRINGIMAGE liwork) + middle := STRCONC(middle,",",STRINGIMAGE lwork,",[") + middle := STRCONC(middle,xstring,"],",STRINGIMAGE ifail,")") + linkGen STRCONC(prefix,middle) + + + +e04naf() == + htInitPage('"E04NAF - Quadratic programming problem",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXe04naf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04naf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04NAF is a comprehensive routine to solve quadratic problems ") + (text . "(QP) of the form \center{\htbitmap{e04naf}} \newline ") + (text . "where {\it c} is a constant {\it n} element vector, {\it H} is a") + (text . " constant {\it n} by {\it n} symmetric matrix, and the matrix ") + (text . "{\it A} is {\it m} by {\it n}, i.e. there are {\it n} variables ") + (text . "and {\it m} general linear constraints. {\it m} may be zero in ") + (text . "which case the LP problem is subject only to bounds on the ") + (text . "variables. \blankline If {\it H} = 0 a flag can be set so that ") + (text . "the problem is treated as a linear programming (LP) problem. ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Upper bound on number of iterations, {\it itmax}:") + (text . "\newline\tab{2} ") + (bcStrings (6 20 itmax PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Type of output messages required, {\it msglvl}: ") + (radioButtons msglvl + (" < 0 " " No printing " mMinus) + (" = 0 " " Printing only if an input parameter is incorrect or overflow is likely" mZero) + (" = 1" " Printing occurs at the solution " mOne) + (" = 5" " One line of output for each constraint addition or deletion, no printout" mFive) + (" \htbitmap{great=} 10" " As above with printout of the solution" mTen) + (" \htbitmap{great=} 15" " As above with X, ISTATE and indices of free variables at each iteration" mFifteen) + (" \htbitmap{great=} 20" " As above with the Lagrange multiplier estimates and the free variables at each iteration" mTwenty) + (" \htbitmap{great=} 30" " As above with the diagonal elements of the matrix {\it T} associated with the {\it TQ} factorization of the working set, and the diagonal elements of the Cholesky factor {\it R} of the projected Hessian" mThirty) + (" \htbitmap{great=} 80" " As above with debug printout" mEighty) + (" = 99" " As above with arrays {\it cvec} and {\it hess}" mNinetyNine)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables, {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of general linear constraints, {\it nclin}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 7 nclin PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "First dimension of array {\it a}, {\it nrowa}:") + (text . "\newline\tab{2} ") + (bcStrings (6 7 nrowa PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "First dimension of array {\it hess}, {\it nrowh}:") + (text . "\newline\tab{2} ") + (bcStrings (6 7 nrowh PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Second dimension of array {\it hess}, {\it ncolh}:") + (text . "\newline\tab{2} ") + (bcStrings (6 7 ncolh PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Size above which a bound is regarded as infinite, {\it bigbnd}:") + (text . "\newline\tab{2} ") + (bcStrings (10 "1.0e10" bigbnd F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Specifies whether or not an initial estimate of the active constraints is present, {\it cold}:") + (radioButtons cold + ("" " true - E04NAF determines the initial working set" cTrue) + ("" " false - user defined contents of array {\it istate}" cFalse)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Specifies whether or not {\it h} is a zero matrix, {\it lp}:") + (radioButtons lp + ("" " false - QP problem " lFalse) + ("" " true - LP problem, {\it hess} and {\it qphess} are not referenced " lTrue)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Specifies whether or not orthogonal transformations are to be used in computing and updating the working set, {\it orthog}:") + (radioButtons orthog + ("" " true " oTrue) + ("" " false " oFalse)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Dimension of {\it iwork}, {\it liwork}:") + (text . "\newline\tab{2} ") + (bcStrings (5 14 liwork F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of {\it work}, {\it lwork}:") + (text . "\newline\tab{2} ") + (bcStrings (5 238 lwork F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04nafSolve) + htShowPage() + +e04nafSolve htPage == + itmax := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itmax) + objValUnwrap htpLabelSpadValue(htPage, 'itmax) + msg := htpButtonValue(htPage,'msglvl) + msglvl := + msg = 'mMinus => '-1 + msg = 'mZero => '0 + msg = 'mOne => '1 + msg = 'mFive => '5 + msg = 'mTen => '10 + msg = 'mFifteen => '15 + msg = 'mTwenty => '20 + msg = 'mThirty => '30 + msg = 'mEighty => '80 + '99 + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nclin := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) + objValUnwrap htpLabelSpadValue(htPage, 'nclin) + nrowa := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowa) + objValUnwrap htpLabelSpadValue(htPage, 'nrowa) + nrowh := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrowh) + objValUnwrap htpLabelSpadValue(htPage, 'nrowh) + ncolh := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolh) + objValUnwrap htpLabelSpadValue(htPage, 'ncolh) + bigbnd := htpLabelInputString(htPage,'bigbnd) + col := htpButtonValue(htPage,'cold) + cold := + col = 'cTrue => '"true" + '"false" + linear := htpButtonValue(htPage,'lp) + lp := + linear = 'lTrue => '"true" + '"false" + ortho := htpButtonValue(htPage,'orthog) + orthog := + ortho = 'oTrue => '"true" + '"false" + liwork := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'liwork) + objValUnwrap htpLabelSpadValue(htPage, 'liwork) + lwork := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) + objValUnwrap htpLabelSpadValue(htPage, 'lwork) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (((nrowa = '7 and n = '7) and (nrowh = '7 and ncolh ='7)) and nclin = '7) => + e04nafDefaultSolve(htPage,itmax,msglvl,bigbnd,cold,lp,orthog,liwork,lwork,ifail) + aList := + "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[8, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") + middle := STRCONC(middle,'"conditions {\it bl(n + nclin)}: \newline ") + blList := + "append"/[fc(i) for i in 1..(n+nclin)] where fc(i) == + blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", blnam, 'F]]] + blList := [['text,:middle],:blList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") + middle := STRCONC(middle,'"conditions {\it bu(n+nclin)}: \newline ") + buList := + "append"/[fd(i) for i in 1..(n+nclin)] where fd(i) == + bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", bunam, 'F]]] + buList := [['text,:middle],:buList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter coefficients of the ") + middle := STRCONC(middle,'"objective function {\it cvec(n)}: \newline ") + cList := + "append"/[fe(i) for i in 1..n] where fe(i) == + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", cnam, 'F]]] + cList := [['text,:middle],:cList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter set of positive ") + middle := STRCONC(middle,'"tolerances {\it featol(n+nclin)}: \newline ") + fList := + "append"/[ff(i) for i in 1..(n+nclin)] where ff(i) == + fnam := INTERN STRCONC ('"f",STRINGIMAGE i) + [['bcStrings,[9, '"0.1053e-7", fnam, 'F]]] + fList := [['text,:middle],:fList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the elements of ") + middle := STRCONC(middle,'"array {\it hess(nrowh,ncolh)}: \newline ") + hList := + "append"/[fh(i,n) for i in 1..nrowh] where fh(i,n) == + labelList := + "append"/[fi(i,j) for j in 1..n] where fi(i,j) == + hnam := INTERN STRCONC ('"h",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[8, 0, hnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + hList := [['text,:middle],:hList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + xList := + "append"/[fg(i) for i in 1..n] where fg(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + xList := [['text,:middle],:xList] + middle := ('"\blankline \menuitemstyle{}\tab{2} If {\it cold} = false ") + middle := STRCONC(middle,'"enter {\it istate(n+nclin)} values: \newline ") + iList := + "append"/[fj(i) for i in 1..(n+nclin)] where fj(i) == + inam := INTERN STRCONC ('"i",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", inam, 'F]]] + iList := [['text,:middle],:iList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList,:blList,:buList,:cList,:fList,:hList,:xList,:iList] + page:= htInitPage('"E04NAF - Quadratic programming problem",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the elements of the array {\it a(nrowa,n)}: \newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04nafGen) + htpSetProperty(page,'itmax,itmax) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'nrowh,nrowh) + htpSetProperty(page,'ncolh,ncolh) + htpSetProperty(page,'bigbnd,bigbnd) + htpSetProperty(page,'cold,cold) + htpSetProperty(page,'lp,lp) + htpSetProperty(page,'orthog,orthog) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04nafDefaultSolve(htPage,itmax,msglvl,bigbnd,cold,lp,orthog,liwork,lwork,ifail) == + n := '7 + nclin := '7 + nrowa := '7 + nrowh := '7 + ncolh := '7 + page:= htInitPage('"E04NAF - Quadratic programming problem",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of array {\it a(nrowa,n)}: \newline ") + (bcStrings (5 "1" a11 F)) + (bcStrings (5 "1" a12 F)) + (bcStrings (5 "1" a13 F)) + (bcStrings (5 "1" a14 F)) + (bcStrings (5 "1" a15 F)) + (bcStrings (5 "1" a16 F)) + (bcStrings (5 "1" a17 F)) + (text . "\newline ") + (bcStrings (5 "0.15" a21 F)) + (bcStrings (5 "0.04" a22 F)) + (bcStrings (5 "0.02" a23 F)) + (bcStrings (5 "0.04" a24 F)) + (bcStrings (5 "0.02" a25 F)) + (bcStrings (5 "0.01" a26 F)) + (bcStrings (5 "0.03" a27 F)) + (text . "\newline ") + (bcStrings (5 "0.03" a31 F)) + (bcStrings (5 "0.05" a32 F)) + (bcStrings (5 "0.08" a33 F)) + (bcStrings (5 "0.02" a34 F)) + (bcStrings (5 "0.06" a35 F)) + (bcStrings (5 "0.01" a36 F)) + (bcStrings (5 "0" a37 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a41 F)) + (bcStrings (5 "0.04" a42 F)) + (bcStrings (5 "0.01" a43 F)) + (bcStrings (5 "0.02" a44 F)) + (bcStrings (5 "0.02" a45 F)) + (bcStrings (5 "0" a46 F)) + (bcStrings (5 "0" a47 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a51 F)) + (bcStrings (5 "0.03" a52 F)) + (bcStrings (5 "0" a53 F)) + (bcStrings (5 "0" a54 F)) + (bcStrings (5 "0.01" a55 F)) + (bcStrings (5 "0" a56 F)) + (bcStrings (5 "0" a57 F)) + (text . "\newline ") + (bcStrings (5 "0.7" a61 F)) + (bcStrings (5 "0.75" a62 F)) + (bcStrings (5 "0.8" a63 F)) + (bcStrings (5 "0.75" a64 F)) + (bcStrings (5 "0.8" a65 F)) + (bcStrings (5 "0.97" a66 F)) + (bcStrings (5 "0" a67 F)) + (text . "\newline ") + (bcStrings (5 "0.02" a71 F)) + (bcStrings (5 "0.06" a72 F)) + (bcStrings (5 "0.08" a73 F)) + (bcStrings (5 "0.12" a74 F)) + (bcStrings (5 "0.02" a75 F)) + (bcStrings (5 "0.01" a76 F)) + (bcStrings (5 "0.97" a77 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter lower boundary conditions {\it bl(n+nclin)}: \newline ") + (bcStrings (8 "-0.01" bl1 F)) + (bcStrings (8 "-0.1" bl2 F)) + (bcStrings (8 "-0.01" bl3 F)) + (bcStrings (8 "-0.04" bl4 F)) + (bcStrings (8 "-0.1" bl5 F)) + (bcStrings (8 "-0.01" bl6 F)) + (bcStrings (8 "-0.01" bl7 F)) + (bcStrings (8 "-0.13" bl8 F)) + (bcStrings (8 "-1.0e+21" bl9 F)) + (bcStrings (8 "-1.0e+21" bl10 F)) + (bcStrings (8 "-1.0e+21" bl11 F)) + (bcStrings (8 "-1.0e+21" bl12 F)) + (bcStrings (8 "-0.0992" bl13 F)) + (bcStrings (8 "-0.003" bl14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter upper boundary conditions {\it bu(n+nclin)}: \newline ") + (bcStrings (8 "0.01" bu1 F)) + (bcStrings (8 "0.15" bu2 F)) + (bcStrings (8 "0.03" bu3 F)) + (bcStrings (8 "0.02" bu4 F)) + (bcStrings (8 "0.05" bu5 F)) + (bcStrings (8 "1.0e+21" bu6 F)) + (bcStrings (8 "1.0e+21" bu7 F)) + (bcStrings (8 "-0.13" bu8 F)) + (bcStrings (8 "-0.0049" bu9 F)) + (bcStrings (8 "-0.0064" bu10 F)) + (bcStrings (8 "-0.0037" bu11 F)) + (bcStrings (8 "-0.0012" bu12 F)) + (bcStrings (8 "1.0e+21" bu13 F)) + (bcStrings (8 "0.002" bu14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter coefficients of the objective function, {\it cvec(n)}: ") + (text . "\newline ") + (bcStrings (8 "-0.02" c1 F)) + (bcStrings (8 "-0.2" c2 F)) + (bcStrings (8 "-0.2" c3 F)) + (bcStrings (8 "-0.2" c4 F)) + (bcStrings (8 "-0.2" c5 F)) + (bcStrings (8 "0.04" c6 F)) + (bcStrings (8 "0.04" c7 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter set of positive tolerances {\it featol(n+nclin)}:\newline ") + (bcStrings (9 "0.1053e-7" f1 F)) + (bcStrings (9 "0.1053e-7" f2 F)) + (bcStrings (9 "0.1053e-7" f3 F)) + (bcStrings (9 "0.1053e-7" f4 F)) + (bcStrings (9 "0.1053e-7" f5 F)) + (bcStrings (9 "0.1053e-7" f6 F)) + (bcStrings (9 "0.1053e-7" f7 F)) + (bcStrings (9 "0.1053e-7" f8 F)) + (bcStrings (9 "0.1053e-7" f9 F)) + (bcStrings (9 "0.1053e-7" f10 F)) + (bcStrings (9 "0.1053e-7" f11 F)) + (bcStrings (9 "0.1053e-7" f12 F)) + (bcStrings (9 "0.1053e-7" f13 F)) + (bcStrings (9 "0.1053e-7" f14 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of array {\it hess(nrowh,ncolh)}: \newline ") + (bcStrings (5 "2" h11 F)) + (bcStrings (5 "0" h12 F)) + (bcStrings (5 "0" h13 F)) + (bcStrings (5 "0" h14 F)) + (bcStrings (5 "0" h15 F)) + (bcStrings (5 "0" h16 F)) + (bcStrings (5 "0" h17 F)) + (text . "\newline ") + (bcStrings (5 "0" h21 F)) + (bcStrings (5 "2" h22 F)) + (bcStrings (5 "0" h23 F)) + (bcStrings (5 "0" h24 F)) + (bcStrings (5 "0" h25 F)) + (bcStrings (5 "0" h26 F)) + (bcStrings (5 "0" h27 F)) + (text . "\newline ") + (bcStrings (5 "0" h31 F)) + (bcStrings (5 "0" h32 F)) + (bcStrings (5 "2" h33 F)) + (bcStrings (5 "2" h34 F)) + (bcStrings (5 "0" h35 F)) + (bcStrings (5 "0" h36 F)) + (bcStrings (5 "0" h37 F)) + (text . "\newline ") + (bcStrings (5 "0" h41 F)) + (bcStrings (5 "0" h42 F)) + (bcStrings (5 "2" h43 F)) + (bcStrings (5 "2" h44 F)) + (bcStrings (5 "0" h45 F)) + (bcStrings (5 "0" h46 F)) + (bcStrings (5 "0" h47 F)) + (text . "\newline ") + (bcStrings (5 "0" h51 F)) + (bcStrings (5 "0" h52 F)) + (bcStrings (5 "0" h53 F)) + (bcStrings (5 "0" h54 F)) + (bcStrings (5 "2" h55 F)) + (bcStrings (5 "0" h56 F)) + (bcStrings (5 "0" h57 F)) + (text . "\newline ") + (bcStrings (5 "0" h61 F)) + (bcStrings (5 "0" h62 F)) + (bcStrings (5 "0" h63 F)) + (bcStrings (5 "0" h64 F)) + (bcStrings (5 "0" h65 F)) + (bcStrings (5 "-2" h66 F)) + (bcStrings (5 "-2" h67 F)) + (text . "\newline ") + (bcStrings (5 "0" h71 F)) + (bcStrings (5 "0" h72 F)) + (bcStrings (5 "0" h73 F)) + (bcStrings (5 "0" h74 F)) + (bcStrings (5 "0" h75 F)) + (bcStrings (5 "-2" h76 F)) + (bcStrings (5 "-2" h77 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector, {\it x(n)}: ") + (text . "\newline ") + (bcStrings (8 "-0.01" x1 F)) + (bcStrings (8 "-0.03" x2 F)) + (bcStrings (8 "0.0" x3 F)) + (bcStrings (8 "-0.01" x4 F)) + (bcStrings (8 "-0.1" x5 F)) + (bcStrings (8 "0.02" x6 F)) + (bcStrings (8 "0.01" x7 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "If {\it cold} = false enter {\it istate(n+nclin)} values: ") + (text . "\newline ") + (bcStrings (8 "0" i1 F)) + (bcStrings (8 "0" i2 F)) + (bcStrings (8 "0" i3 F)) + (bcStrings (8 "0" i4 F)) + (bcStrings (8 "0" i5 F)) + (bcStrings (8 "0" i6 F)) + (bcStrings (8 "0" i7 F)) + (bcStrings (8 "0" i8 F)) + (bcStrings (8 "0" i9 F)) + (bcStrings (8 "0" i10 F)) + (bcStrings (8 "0" i11 F)) + (bcStrings (8 "0" i12 F)) + (bcStrings (8 "0" i13 F)) + (bcStrings (8 "0" i14 F))) + htMakeDoneButton('"Continue",'e04nafGen) + htpSetProperty(page,'itmax,itmax) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'nrowh,nrowh) + htpSetProperty(page,'ncolh,ncolh) + htpSetProperty(page,'bigbnd,bigbnd) + htpSetProperty(page,'cold,cold) + htpSetProperty(page,'lp,lp) + htpSetProperty(page,'orthog,orthog) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04nafGen htPage == + itmax := htpProperty(htPage, 'itmax) + msglvl := htpProperty(htPage, 'msglvl) + n := htpProperty(htPage, 'n) + nclin := htpProperty(htPage, 'nclin) + nrowa := htpProperty(htPage, 'nrowa) + nrowh := htpProperty(htPage, 'nrowh) + ncolh := htpProperty(htPage, 'ncolh) + bigbnd := htpProperty(htPage, 'bigbnd) + cold := htpProperty(htPage, 'cold) + lp := htpProperty(htPage, 'lp) + orthog := htpProperty(htPage, 'orthog) + liwork := htpProperty(htPage,'liwork) + lwork := htpProperty(htPage,'lwork) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + ilist := [temp,:ilist] + y := rest y + istring := bcwords2liststring ilist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + for i in 1..nrowh repeat -- matrix H + for j in 1..ncolh repeat + h := STRCONC((first y).1," ") + hlist := [h,:hlist] + y := rest y + hmatlist := [:hmatlist,hlist] + hlist := [] + hmatlist := reverse hmatlist + hmatstr := bcwords2liststring [bcwords2liststring x for x in hmatlist] + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + flist := [temp,:flist] + y := rest y + fstring := bcwords2liststring flist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + clist := [temp,:clist] + y := rest y + cstring := bcwords2liststring clist + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + bulist := [temp,:bulist] + y := rest y + bustring := bcwords2liststring bulist + for i in 1..(n+nclin) repeat + temp := STRCONC ((first y).1," ") + bllist := [temp,:bllist] + y := rest y + blstring := bcwords2liststring bllist + for i in 1..nrowa repeat -- matrix A + for j in 1..n repeat + a := STRCONC((first y).1," ") + arrlist := [a,:arrlist] + y := rest y + amatlist := [:amatlist,arrlist] + arrlist := [] + amatlist := reverse amatlist + amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] + nctotl := n + nclin + prefix := STRCONC("e04naf(",STRINGIMAGE itmax,",", STRINGIMAGE msglvl,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,",",STRINGIMAGE nclin,", ") + prefix := STRCONC(prefix,STRINGIMAGE nctotl,",",STRINGIMAGE nrowa,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrowh,",",STRINGIMAGE ncolh,", ",bigbnd) + middle := STRCONC(", ",amatstr,",[") + middle := STRCONC(middle,blstring,"],[",bustring,"],[",cstring) + middle := STRCONC(middle,"],[",fstring,"],",hmatstr,",",STRINGIMAGE cold,",") + middle := STRCONC(middle,STRINGIMAGE lp,", ",STRINGIMAGE orthog,", ") + middle := STRCONC(middle,STRINGIMAGE liwork,",",STRINGIMAGE lwork,",[") + middle := STRCONC(middle,xstring,"],[",istring,"]::Matrix Integer,") + middle := STRCONC(middle,STRINGIMAGE ifail) + end := STRCONC(",((",hmatstr,")::Matrix Expression Float)::ASP20('QPHESS))") + linkGen STRCONC(prefix,middle,end) + +e04ucf() == + htInitPage('"E04UCF - Minimum, function of several variables, sequential QP method, nonlinear constraints, using function values and optionally 1st derivatives", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXe04ucf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04ucf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04UCF minimizes an arbitrary smooth function subject to ") + (text . "constraints which may include simple bounds on the variables, ") + (text . "linear constraints and smooth nonlinear constraints. As many ") + (text . "first partial derivatives as possible should be supplied by the ") + (text . "user, unspecified derivatives being estimated by finite ") + (text . "differences. \newline The routine solves problems of the form") + (text . "\center{\htbitmap{e04ucf}}\newline where the objective function ") + (text . "{\it F(x)} is nonlinear, \htbitmap{Al} is an \htbitmap{nl} by n ") + (text . "constant matrix and {\it c(x)} is an \htbitmap{nn} element ") + (text . "vector of nonlinear constraint functions. The objective function") + (text . " and constraint functions are assumed to be smooth (i.e. at ") + (text . "least twice continuously differentiable), although the method ") + (text . "will usually work if there are discontinuities away from the ") + (text . "solution. \blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the number of variables, {\it n}: ") + (text . "\newline ") + (bcStrings (5 4 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the number of general linear constraints, {\it nclin}: ") + (text . "\newline ") + (bcStrings (5 1 nclin PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the number of nonlinear constraints, {\it ncnln}: ") + (text . "\newline ") + (bcStrings (5 2 ncnln PI)) + (text . "\blankline ") + (text . "Change optional parameters:") + (radioButtons optional + ("" " No" no) + ("" " Yes" yes)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Start value:") + (radioButtons start + ("" " Cold start" false) + ("" " Warm start" true)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04ucfSolve) + htShowPage() + + +e04ucfSolve(htPage) == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nclin := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) + objValUnwrap htpLabelSpadValue(htPage, 'nclin) + ncnln := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncnln) + objValUnwrap htpLabelSpadValue(htPage, 'ncnln) + nrowa := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nclin) + objValUnwrap htpLabelSpadValue(htPage, 'nrowa) + nrowj := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncnln) + objValUnwrap htpLabelSpadValue(htPage, 'nrowj) + nrowr := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'nrowr) + liwork := 3*n+nclin+2*ncnln + lwork := + (ncnln = '0 and nclin = '0) => 20*n + (ncnln = '0 and nclin > '0) => 2*n*n + 20*n + 11*nclin + (ncnln > '0 and nclin >= '0) => 2*n*n + n*nclin +2*n*ncnln + 20*n + 11*nclin + 21*ncnln + '1 + initial := htpButtonValue(htPage,'start) + start := + initial = 'true => '1 + '0 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + param := htpButtonValue(htPage,'optional) + optional := + param = 'no => '0 + '1 + ((n = '4 and optional = '0 and nclin=1 and ncnln=2) and (start = '0)) => + e04ucfDefaultSolve(htPage,nclin,ncnln,nrowa,nrowj,nrowr,liwork,lwork,ifail) + start = '1 => e04ucfCopOut() + optional := '1 + aList := + "append"/[fa(i,n) for i in 1..nrowa] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[8, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter lower boundary ") + middle := STRCONC(middle,'"conditions {\it bl(n+nclin+ncnln)}: \newline ") + blList := + "append"/[fc(i) for i in 1..(n+nclin+ncnln)] where fc(i) == + blnam := INTERN STRCONC ('"bl",STRINGIMAGE i) + [['bcStrings,[8, '"-1.E25", blnam, 'F]]] + blList := [['text,:middle],:blList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter upper boundary ") + middle := STRCONC(middle,'"conditions {\it bu(n+nclin+ncnln)}: \newline ") + buList := + "append"/[fd(i) for i in 1..(n+nclin+ncnln)] where fd(i) == + bunam := INTERN STRCONC ('"bu",STRINGIMAGE i) + [['bcStrings,[8, '"1.E25", bunam, 'F]]] + buList := [['text,:middle],:buList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the nonlinear ") + middle := STRCONC(middle,'"constraint functions {\it c(ncnln)} ") + middle := STRCONC(middle,'"in terms of X[1]...X[n]: \newline ") + cList := + "append"/[fe(i) for i in 1..ncnln] where fe(i) == + lineEnd := ('"\newline \tab{2} ") + cnam := INTERN STRCONC ('"c",STRINGIMAGE i) + [['text,:lineEnd],['bcStrings,[55, '"X[1]", cnam, 'F]]] + cList := [['text,:middle],:cList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the objective ") + middle := STRCONC(middle,'"function, {\it F(x)} ") + middle := STRCONC(middle,'"in terms of X[1]...X[n]: \newline ") + funcList := [['bcStrings,[55, '"X[1]", 'f, 'EM]]] + funcList := [['text,:middle],:funcList] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter initial guess ") + middle := STRCONC(middle,'"of the solution vector {\it x(n)}: \newline ") + xList := + "append"/[fg(i) for i in 1..n] where fg(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[8, '"0.0", xnam, 'F]]] + xList := [['text,:middle],:xList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList,:blList,:buList,:cList,:funcList,:xList, + :'( + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Crash tolerance, {\it cra}: ") + (text . "\newline ") + (bcStrings (20 "0.01" cra F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Derivative level, {\it der}: ") + (text . "\newline ") + (bcStrings (5 3 der PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Feasibility tolerance, {\it fea}: ") + (text . "\newline ") + (bcStrings (20 "0.1053671201E-7" fea F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Function Precision, {\it fun}: ") + (text . "\newline ") + (bcStrings (20 "0.4373903510E-14" fun F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it r} is a Hessian matrix :") + (radioButtons hess + ("" " No" hFalse) + ("" " Yes" hTrue)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Infinite bound size, {\it infb}: ") + (text . "\newline ") + (bcStrings (20 "1.00E+15" infb F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Infinite step size, {\it infs}: ") + (text . "\newline ") + (bcStrings (20 "1.00E+15" infs F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Linear feasibility tolerance, {\it linf}: ") + (text . "\newline ") + (bcStrings (20 "0.1053671201E-7" linf F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Linesearch tolerance, {\it lint}: ") + (text . "\newline ") + (bcStrings (20 "0.9" lint F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "List parameters:") + (radioButtons list + ("" " No" false) + ("" " Yes" true)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Major iteration limit, {\it maji}: ") + (text . "\newline ") + (bcStrings (5 30 maji PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Major print level, {\it majp}: ") + (text . "\newline ") + (bcStrings (5 1 majp PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Minor iteration limit, {\it mini}: ") + (text . "\newline ") + (bcStrings (5 81 mini PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Minor print level, {\it minp}: ") + (text . "\newline ") + (bcStrings (5 0 minp PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Monitoring channel, {\it mon}. ") + (text . "(Ignored in Foundation Library version.) ") + (text . "\newline ") + (bcStrings (5 "-1" mon F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Nonlinear feasibiltity tolerance, {\it nonf}: ") + (text . "\newline ") + (bcStrings (20 "1.05E-08" nonf F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Optimality tolerance, {\it opt}: ") + (text . "\newline ") + (bcStrings (20 "3.26E-08" opt F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Step limit, {\it ste}: ") + (text . "\newline ") + (bcStrings (5 "2.0" ste F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Start objective check at variable, {\it stao}: ") + (text . "\newline ") + (bcStrings (5 1 stao PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Start constraint check at variable, {\it stac}: ") + (text . "\newline ") + (bcStrings (5 1 stac PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Stop objective check at variable, {\it stoo}: ") + (text . "\newline ") + (bcStrings (5 9 stoo PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Stop objective check at variable, {\it stoc}: ") + (text . "\newline ") + (bcStrings (5 9 stoc PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Verify level, {\it ver}: ") + (text . "\newline ") + (bcStrings (5 3 ver PI)))] + page := htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the elements of the array, {\it A(nrowa,n)}: " + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04ucfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'ncnln,ncnln) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'nrowj,nrowj) + htpSetProperty(page,'nrowr,nrowr) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'optional,optional) + htpSetProperty(page,'start,start) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04ucfDefaultSolve(htPage,nclin,ncnln,nrowa,nrowj,nrowr,liwork,lwork,ifail) == + n := '4 + optional := '0 + start := '0 + page := htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of the array {\it A(nrowa,n)}: ") + (text . "\newline ") + (bcStrings (4 "1.0" a11 F)) + (bcStrings (4 "1.0" a12 F)) + (bcStrings (4 "1.0" a13 F)) + (bcStrings (4 "1.0" a14 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the lower boundary conditions {\it bl(n+nclin+ncnln)}: ") + (text . "\newline ") + (bcStrings (8 "1.0" bl1 F)) + (bcStrings (8 "1.0" bl2 F)) + (bcStrings (8 "1.0" bl3 F)) + (bcStrings (8 "1.0" bl4 F)) + (bcStrings (8 "-1.E25" bl5 F)) + (bcStrings (8 "-1.E25" bl6 F)) + (bcStrings (8 "25.0" bl7 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the upper boundary conditions {\it bu(n+nclin+ncnln)}: ") + (text . "\newline ") + (bcStrings (8 "5.0" bu1 F)) + (bcStrings (8 "5.0" bu2 F)) + (bcStrings (8 "5.0" bu3 F)) + (bcStrings (8 "5.0" bu4 F)) + (bcStrings (8 "20.0" bu5 F)) + (bcStrings (8 "40.0" bu6 F)) + (bcStrings (8 "1.E25" bu7 F)) + -- no istate or clamda or r as default condition is cold + -- what about cjac when der = 3 ? + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the nonlinear constraint functions, {\it c(ncnln)} ") + (text . "in terms of X[1]...X[n]: ") + (text . "\newline ") + (bcStrings (55 "X[1]**2 + X[2]**2 + X[3]**2 + X[4]**2" cx1 EM)) + (text . "\newline ") + (bcStrings (55 "X[1]*X[2]*X[3]*X[4]" cx2 EM)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the objective function, {\it F(x)} ") + (text . "in terms of X[1]...X[n]: ") + (text . "\newline ") + (bcStrings (55 "X[1]*X[4]*(X[1] + X[2] + X[3]) + X[3]" of EM)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter initial guess of the solution vector, {\it x(n)}: \newline") + (bcStrings (8 "1.0" x1 F)) + (bcStrings (8 "5.0" x2 F)) + (bcStrings (8 "5.0" x3 F)) + (bcStrings (8 "1.0" x4 F))) + htMakeDoneButton('"Continue",'e04ucfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nclin,nclin) + htpSetProperty(page,'ncnln,ncnln) + htpSetProperty(page,'nrowa,nrowa) + htpSetProperty(page,'nrowj,nrowj) + htpSetProperty(page,'nrowr,nrowr) + htpSetProperty(page,'liwork,liwork) + htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'start,start) + htpSetProperty(page,'optional,optional) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +e04ucfGen htPage == + n := htpProperty(htPage,'n) + nclin := htpProperty(htPage,'nclin) + ncnln := htpProperty(htPage,'ncnln) + nrowa := htpProperty(htPage,'nrowa) + nrowj := htpProperty(htPage,'nrowj) + nrowr := htpProperty(htPage,'nrowr) + liwork := htpProperty(htPage,'liwork) + lwork := htpProperty(htPage,'lwork) + optional := htpProperty(htPage,'optional) + start := htpProperty(htPage,'start) + ifail := htpProperty(htPage,'ifail) + sta := 'false -- no warm start in HD + alist := htpInputAreaAlist htPage + y := alist + if (optional = '0) then + cra := '"0.01" + der := 3 + fea := '"0.1053671201E-7" + fun := '"0.4373903510E-14" + hes := 'true + infb := '"1.00E+15" + infs := '"1.00E+15" + linf := '"0.1053671201E-7" + lint := '"0.9" + lis := 'true + maji := 30 + majp := 1 + mini := 81 + minp := 0 + mon := '"-1" + nonf := '"1.05E-08" + opt := '"3.26E-08" + ste := '"2.0" + stao := 1 + stac := 1 + stoo := n + stoc := n + ver := 3 + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + f := (first y).1 + y := rest y + for i in 1..ncnln repeat + temp := STRCONC ((first y).1," ") + cxlist := [temp,:cxlist] + y := rest y + cxstring := bcwords2liststring cxlist + for i in 1..(n+nclin+ncnln) repeat + temp := STRCONC ((first y).1," ") + bulist := [temp,:bulist] + y := rest y + buu := bcwords2liststring bulist + for i in 1..(n+nclin+ncnln) repeat + temp := STRCONC ((first y).1," ") + bllist := [temp,:bllist] + y := rest y + bll := bcwords2liststring bllist + for i in 1..nrowa repeat -- matrix A + for j in 1..n repeat + a := STRCONC((first y).1," ") + arrlist := [a,:arrlist] + y := rest y + amatlist := [:amatlist,arrlist] + arrlist := [] + amatlist := reverse amatlist + amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] + else + ver := STRCONC((first y).1," ") + y := rest y + stoc := STRCONC((first y).1," ") + y := rest y + stoo := STRCONC((first y).1," ") + y := rest y + stac := STRCONC((first y).1," ") + y := rest y + stao := STRCONC((first y).1," ") + y := rest y + ste := STRCONC((first y).1," ") + y := rest y + opt := STRCONC((first y).1," ") + y := rest y + nonf := STRCONC((first y).1," ") + y := rest y + mon := STRCONC((first y).1," ") + y := rest y + minp := STRCONC((first y).1," ") + y := rest y + mini := STRCONC((first y).1," ") + y := rest y + majp := STRCONC((first y).1," ") + y := rest y + maji := STRCONC((first y).1," ") + y := rest y + nolist := (first y).1 + lis := + nolist = '" nil" => '"false" + '"true" + y := rest y + dummy1 := first y + y := rest y + lint := STRCONC((first y).1," ") + y := rest y + linf := STRCONC((first y).1," ") + y := rest y + infs := STRCONC((first y).1," ") + y := rest y + infb := STRCONC((first y).1," ") + y := rest y + noHess := (first y).1 + hes := + noHess = '" nil" => '"false" + '"true" + y := rest y + dummy2 := first y + y := rest y + fun := STRCONC((first y).1," ") + y := rest y + fea := STRCONC((first y).1," ") + y := rest y + der := STRCONC((first y).1," ") + y := rest y + cra := STRCONC((first y).1," ") + y := rest y + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + xlist := [temp,:xlist] + y := rest y + xstring := bcwords2liststring xlist + f := (first y).1 + y := rest y + for i in 1..ncnln repeat + temp := STRCONC ((first y).1," ") + cxlist := [temp,:cxlist] + y := rest y + cxstring := bcwords2liststring cxlist + for i in 1..(n+nclin+ncnln) repeat + temp := STRCONC ((first y).1," ") + bulist := [temp,:bulist] + y := rest y + buu := bcwords2liststring bulist + for i in 1..(n+nclin+ncnln) repeat + temp := STRCONC ((first y).1," ") + bllist := [temp,:bllist] + y := rest y + bll := bcwords2liststring bllist + for i in 1..nrowa repeat -- matrix A + for j in 1..n repeat + a := STRCONC((first y).1," ") + arrlist := [a,:arrlist] + y := rest y + amatlist := [:amatlist,arrlist] + arrlist := [] + amatlist := reverse amatlist + amatstr := bcwords2liststring [bcwords2liststring x for x in amatlist] + ntotl := n + nclin + ncnln + prefix := STRCONC("e04ucf(",STRINGIMAGE n,", ",STRINGIMAGE nclin,", ") + prefix := STRCONC(prefix,STRINGIMAGE ncnln,", ",STRINGIMAGE nrowa,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrowj,", ",STRINGIMAGE nrowr,", ") + prefix:= STRCONC(prefix,amatstr,",[",bll,"],[",buu,"],",STRINGIMAGE liwork) + prefix := STRCONC(prefix,", ",STRINGIMAGE lwork,", ",STRINGIMAGE sta,", ") + prefix := STRCONC(prefix,cra,", ",STRINGIMAGE der,", ",fea,", ") + prefix := STRCONC(prefix,fun,", ",hes,", ",infb,", ",infs,", ",linf,", ") + prefix := STRCONC(prefix,lint,", ",lis,", ",STRINGIMAGE maji,", ") + prefix := STRCONC(prefix,STRINGIMAGE majp,", ",STRINGIMAGE mini,", ") + prefix := STRCONC(prefix,STRINGIMAGE minp,", ",mon,", ",nonf,", ",opt,", ") + prefix := STRCONC(prefix,ste,", ",STRINGIMAGE stao,", ",STRINGIMAGE stac) + prefix := STRCONC(prefix,", ",STRINGIMAGE stoo,", ",STRINGIMAGE stoc,", ") + middle:= STRCONC(STRINGIMAGE ver,",[[0 for i in 1..",STRINGIMAGE ntotl,"]]") + middle:=STRCONC(middle,"::Matrix Integer,[[0.0 for i in 1..",STRINGIMAGE n) + middle:=STRCONC(middle,"] for j in 1..",STRINGIMAGE nrowj,"],[[0.0 for i in 1..") + middle := STRCONC(middle,STRINGIMAGE ntotl,"]],[[0.0 for i in 1..") + middle := STRCONC(middle,STRINGIMAGE n,"] for j in 1..",STRINGIMAGE nrowr) + middle := STRCONC(middle,"],[",xstring,"],",STRINGIMAGE ifail) + end:=STRCONC(",((",cxstring,")::Vector Expression(Float))::ASP55(CONFUN),") + end := STRCONC(end,"((",f,")::Expression(Float))::ASP49(OBJFUN))") + linkGen STRCONC(prefix,middle,end) + + +e04ucfCopOut() == + htInitPage('"E04UCF - Unconstrained minimum, pre-conditioned conjugate gradient algorithm, function of several variables using 1st derivatives",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\blankline ") + (text . "{\center{\em Hyperdoc interface not available for warm start}}") + (text . "\newline ") + (text . "{\center{\em Please use the command line.}}")) + htMakeDoneButton('"Continue",'e04ucf) + htShowPage() + +e04ycf() == + htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXe04ycf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|e04ycf| '|NagOptimisationPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "E04YCF returns estimates of elements of the variance-covariance ") + (text . "matrix of the estimated regression coefficients for a nonlinear ") + (text . "least-squares problem. ") + (text . "\blankline ") + (text . "This routine may be used following any of the nonlinear ") + (text . "least-squares routines E04FDF, E04GCF. It ") + (text . "requires the parameters {\it fumsq, s} and {\it v} supplied ") + (text . "by those routines. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Elements of {\it c} returned, {\it job}: ") + (radioButtons job + (" 0" " The diagonal elements of {\it c} " jZero) + (" 1" " Elements of column {\it job} of {\it c} " jOne) + (" -1" " The whole {\it n} by {\it n} symmetric matrix " jMinus)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of observations, {\it m}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 15 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of variables, {\it n}: ") + (text . "\newline\tab{2} ") + (bcStrings (6 3 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Sum of the squares of the residuals, {\it fsumsq}: ") + (text . "\newline\tab{2} ") + (bcStrings (30 "0.0082148773065789729" fsumsq F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "First dimension of array {\it v}, {\it lv}:") + (text . "\newline\tab{2} ") + (bcStrings (6 3 lv PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'e04ycfSolve) + htShowPage() + +e04ycfSolve htPage == + temp := htpButtonValue(htPage,'job) + job := + temp = 'jMinus => '-1 + temp = 'jOne => '1 + '0 + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fsumsq := htpLabelInputString(htPage, 'fsumsq) + lv := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lv) + objValUnwrap htpLabelSpadValue(htPage, 'lv) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = 3 and lv = 3) => e04ycfDefaultSolve(htPage,job,m,fsumsq,ifail) + sList := + "append"/[fa(i) for i in 1..(n)] where fa(i) == + snam := INTERN STRCONC ('"s",STRINGIMAGE i) + [['bcStrings,[30, '"0.0", snam, 'F]]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the elements ") + middle := STRCONC(middle,'"of array {\it v(lv,n)}: \newline ") + vList := + "append"/[fb(i,n) for i in 1..lv] where fb(i,n) == + labelList := + "append"/[fc(i,j) for j in 1..n] where fc(i,j) == + vnam := INTERN STRCONC ('"v",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[15, 0, vnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + vList := [['text,:middle],:vList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))), + :sList,:vList] + page:= htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the elements of the array {\it s(n)}: \newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'e04ycfGen) + htpSetProperty(page,'job,job) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'fsumsq,fsumsq) + htpSetProperty(page,'lv,lv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04ycfDefaultSolve(htPage,job,m,fsumsq,ifail) == + n := '3 + lv := '3 + page:= htInitPage('"E04YCF - Covariance matrix for non-linear least-squares problem", nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of array {\it s(n)}: \newline ") + (bcStrings (30 "4.0965034571419325" s1 F)) + (bcStrings (30 "1.5949579400198182" s2 F)) + (bcStrings (30 "0.061258491120317927" s3 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the elements of array {\it v(lv,n)}: \newline ") + -- not the correct values yet ! + (bcStrings (8 "0.9354" v11 F)) + (bcStrings (8 "-0.2592" v12 F)) + (bcStrings (8 "-0.2405" v13 F)) + (text . "\newline ") + (bcStrings (8 "0.3530" v21 F)) + (bcStrings (8 "0.6432" v22 F)) + (bcStrings (8 "0.6795" v23 F)) + (text . "\newline ") + (bcStrings (8 "-0.0215" v31 F)) + (bcStrings (8 "-0.7205" v32 F)) + (bcStrings (8 "0.6932" v33 F))) + htMakeDoneButton('"Continue",'e04ycfGen) + htpSetProperty(page,'job,job) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'fsumsq,fsumsq) + htpSetProperty(page,'lv,lv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +e04ycfGen htPage == + job := htpProperty(htPage,'job) + n := htpProperty(htPage, 'n) + m := htpProperty(htPage, 'm) + fsumsq := htpProperty(htPage, 'fsumsq) + lv := htpProperty(htPage, 'lv) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..(lv*n) repeat + temp := STRCONC ((first y).1," ") + vlist := [temp,:vlist] + y := rest y + vstring := bcwords2liststring vlist + for i in 1..n repeat + temp := STRCONC ((first y).1," ") + slist := [temp,:slist] + y := rest y + sstring := bcwords2liststring slist + prefix := STRCONC("e04ycf(",STRINGIMAGE job,",", STRINGIMAGE m,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,",",fsumsq,", [") + prefix := STRCONC(prefix,sstring,"],", STRINGIMAGE lv,",[",vstring) + linkGen STRCONC(prefix,"],",STRINGIMAGE ifail,")") + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-f01.boot b/src/interp/nag-f01.boot deleted file mode 100644 index e3deaf9a..00000000 --- a/src/interp/nag-f01.boot +++ /dev/null @@ -1,2230 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -f01brf() == - htInitPage("F01BRF - LU factorization of real sparse matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf01brf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01brf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Factorizes a real sparse matrix A of order n. The routine forms ") - (text . "the {\it LU} factorization of the entire matrix, or ,") - (text . "optionally, first permutes the matrix to block lower ") - (text . "triangular form and then only factorizes the diagonal block. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the order {\em n} of the matrix A ") - (text . "\htbitmap{great=} 1:") - (text . "\newline\tab{2} ") - (bcStrings (8 6 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of non-zero elements {\it nz}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "{\it pivot}:") - (text . "\newline \tab{2} ") - (bcStrings (8 15 nz PI)) - (text . "\tab{34} ") - (bcStrings (8 "0.1" pivot PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of A & ICN {\it licn}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Dimension of IRN {\it lirn}:") - (text . "\newline \tab{2} ") - (bcStrings (6 150 licn PI)) - (text . "\tab{34} ") - (bcStrings (6 75 lirn PI)) - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2} Grow value:") - (radioButtons grow - ("" " True" gr_true) - ("" " False" gr_false)) - (text . "\blankline") - (text . "\menuitemstyle{}\tab{2} Lblock value:") - (radioButtons lblock - ("" " True" lb_true) - ("" " False" lb_false)) - (text . "\blankline ") - (text . "\newline \tab{2} ") - (text . "Ifail is input in three components: ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it a} ") - (radioButtons afail - ("" " 0, hard failure" azero) - ("" " 1, soft failure" aone)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it b} ") - (radioButtons bfail - ("" " 1, print error messages" bone) - ("" " 0, suppress error messages" bzero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it c} ") - (radioButtons cfail - ("" " 1, print warning messages" cone) - ("" " 0, suppress warning messages" czero))) - htMakeDoneButton('"Continue", 'f01brfSolve) - htShowPage() - -f01brfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nz := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nz) - objValUnwrap htpLabelSpadValue(htPage, 'nz) - licn := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'licn) - objValUnwrap htpLabelSpadValue(htPage, 'licn) - lirn := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lirn) - objValUnwrap htpLabelSpadValue(htPage, 'lirn) - pivot := htpLabelInputString(htPage, 'pivot) - gr := htpButtonValue(htPage,'grow) - grow := - gr = 'gr_true => '"true" - '"false" - lb := htpButtonValue(htPage,'lblock) - lblock := - lb = 'lb_true => '"true" - '"false" - aerror := htpButtonValue(htPage,'afail) - afail := - aerror = 'azero => '0 - '1 - berror := htpButtonValue(htPage,'bfail) - bfail := - berror = 'bone => '1 - '0 - cerror := htpButtonValue(htPage,'cfail) - cfail := - cerror = 'cone => '1 - '0 - ifail := 100*cfail + 10*bfail + afail - ((n = '6 and nz = '15) and (licn = '150 and lirn = '75)) - => f01brfDefaultSolve(htPage,pivot,grow,lblock,ifail) - labelList := - "append"/[f(i) for i in 1..nz] where f(i) == - prefix := ('"\newline \tab{2} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - mid := ('"\tab{32} ") - rnam := INTERN STRCONC ('"irn",STRINGIMAGE i) - end := ('"\tab{42} ") - cnam := INTERN STRCONC ('"icn",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, anam, 'F]], - ['text,:mid],['bcStrings,[4, 0, rnam, 'PI]], - ['text,:end],['bcStrings,[4, 0, cnam, 'PI]]] - abortList := - [['bcStrings,[6, '"true", 'abortone, 'EM]], - ['bcStrings,[6, '"true", 'aborttwo, 'EM]], - ['bcStrings,[6, '"false", 'abortthree, 'EM]], - ['bcStrings,[6, '"true", 'abortfour, 'EM]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} Abort: ") - abortList := [['text,:prefix],:abortList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain EM ($EmptyMode)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:abortList] - page := htInitPage("F01BRF - LU factorization of real sparse matrix",nil) - htSay '"\menuitemstyle{}\tab{2} Non-zero elements of A: " - htSay '"\tab{30} \menuitemstyle{}\tab{32} Row: " - htSay '"\tab{40} \menuitemstyle{}\tab{42} Column: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01brfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nz,nz) - htpSetProperty(page,'licn,licn) - htpSetProperty(page,'lirn,lirn) - htpSetProperty(page,'pivot,pivot) - htpSetProperty(page,'grow,grow) - htpSetProperty(page,'lblock,lblock) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01brfDefaultSolve(htPage,pivot,grow,lblock,ifail) == - n := '6 - nz := '15 - licn := '150 - lirn := '75 - page := htInitPage("F01BRF - LU factorization of real sparse matrix",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Non-zero elements of A: ") - (text . "\tab{30} \menuitemstyle{}\tab{32} Row: ") - (text . "\tab{40} \menuitemstyle{}\tab{42} Column: ") - (text . "\newline \tab{2}") - (bcStrings (8 "5.0" a1 F)) - (text . "\tab{32} ") - (bcStrings (4 1 irn1 PI)) - (text . "\tab{42} ") - (bcStrings (4 1 icn1 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "2.0" a2 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn2 PI)) - (text . "\tab{42} ") - (bcStrings (4 2 icn2 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-1.0" a3 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn3 PI)) - (text . "\tab{42} ") - (bcStrings (4 3 icn3 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "2.0" a4 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn4 PI)) - (text . "\tab{42} ") - (bcStrings (4 4 icn4 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "3.0" a5 F)) - (text . "\tab{32} ") - (bcStrings (4 3 irn5 PI)) - (text . "\tab{42} ") - (bcStrings (4 3 icn5 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-2.0" a6 F)) - (text . "\tab{32} ") - (bcStrings (4 4 irn6 PI)) - (text . "\tab{42} ") - (bcStrings (4 1 icn6 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a7 F)) - (text . "\tab{32} ") - (bcStrings (4 4 irn7 PI)) - (text . "\tab{42} ") - (bcStrings (4 4 icn7 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a8 F)) - (text . "\tab{32} ") - (bcStrings (4 4 irn8 PI)) - (text . "\tab{42} ") - (bcStrings (4 5 icn8 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-1.0" a9 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn9 PI)) - (text . "\tab{42} ") - (bcStrings (4 1 icn9 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-1.0" a10 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn10 PI)) - (text . "\tab{42} ") - (bcStrings (4 4 icn10 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "2.0" a11 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn11 PI)) - (text . "\tab{42} ") - (bcStrings (4 5 icn11 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-3.0" a12 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn12 PI)) - (text . "\tab{42} ") - (bcStrings (4 6 icn12 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-1.0" a13 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn13 PI)) - (text . "\tab{42} ") - (bcStrings (4 1 icn13 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-1.0" a14 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn14 PI)) - (text . "\tab{42} ") - (bcStrings (4 2 icn14 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "6.0" a15 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn15 PI)) - (text . "\tab{42} ") - (bcStrings (4 6 icn15 PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} Abort :") - (bcStrings (8 "true" abort_one EM)) - (bcStrings (8 "true" abort_two EM)) - (bcStrings (8 "false" abort_three EM)) - (bcStrings (8 "true" abort_four EM))) - htMakeDoneButton('"Continue",'f01brfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nz,nz) - htpSetProperty(page,'licn,licn) - htpSetProperty(page,'lirn,lirn) - htpSetProperty(page,'pivot,pivot) - htpSetProperty(page,'grow,grow) - htpSetProperty(page,'lblock,lblock) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01brfGen htPage == - n := htpProperty(htPage,'n) - nz := htpProperty(htPage,'nz) - licn := htpProperty(htPage,'licn) - lirn := htpProperty(htPage,'lirn) - pivot := htpProperty(htPage,'pivot) - grow := htpProperty(htPage,'grow) - lblock := htpProperty(htPage,'lblock) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..4 repeat - abort := STRCONC((first y).1," ") - y := rest y - abortList := [abort,:abortList] - astring := bcwords2liststring abortList - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - top := STRCONC ((first y).1," ") - y := rest y - cList := [end,:cList] - rList := [mid,:rList] - matList := [top,:matList] - for i in 1..(licn-nz) repeat - cList := [:cList,'"0 "] - matList := [:matList,'"0 "] - for i in 1..(lirn-nz) repeat - rList := [:rList,'"0 "] - cstring := bcwords2liststring cList - rstring := bcwords2liststring rList - matstring := bcwords2liststring matList - prefix := STRCONC('"f01brf(",STRINGIMAGE n,", ",STRINGIMAGE nz,", ") - prefix := STRCONC(prefix,STRINGIMAGE licn,", ",STRINGIMAGE lirn,", ",pivot) - prefix := STRCONC(prefix,", ",lblock,", ",grow,", ",astring,",[",matstring) - prefix := STRCONC(prefix,"],[",rstring,"],[",cstring,"], ") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - -f01bsf() == - htInitPage("F01BSF - LU factorization of real sparse matrix with known sparsity pattern",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf01bsf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01bsf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Factorizes a real sparse matrix A of order n using the pivotal ") - (text . "sequence previously obtained by F01BRF when a matrix of the ") - (text . "same sparsity pattern was factorized. ") - (text . "\blankline ") - (text . "Read the input file to see the example program. ") - (text . "\spadpaste{)read f01bsf \bound{s0}} ") - (text . "\blankline") - (text . "\newline ")) - htShowPage() - -f01maf() == - htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf01maf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01maf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes an incomplete Cholesky factorization of a real ") - (text . "sparse symmetric positive-definite matrix A of order n. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the order {\em n} of the matrix A ") - (text . "\htbitmap{great=} 1:") - (text . "\newline\tab{2} ") - (bcStrings (8 16 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of non-zero elements {\it nz}:") - (text . "\newline \tab{2} ") - (bcStrings (8 40 nz PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Dimension of A & ICN {\it licn}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Dimension of IRN {\it lirn}:") - (text . "\newline \tab{2} ") - (bcStrings (6 90 licn PI)) - (text . "\tab{34} ") - (bcStrings (6 50 lirn PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Tolerance {\it droptl}: ") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "{\it densw}:") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.1" droptl F)) - (text . "\tab{34} ") - (bcStrings (6 "0.8" densw F)) - (text . "\blankline ") - (text . "\newline \tab{2} ") - (text . "Ifail is input in three components: ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it a} ") - (radioButtons afail - ("" " 0, hard failure" azero) - ("" " 1, soft failure" aone)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it b} ") - (radioButtons bfail - ("" " 1, print error messages" bone) - ("" " 0, suppress error messages" bzero)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "{\it c} ") - (radioButtons cfail - ("" " 1, print warning messages" cone) - ("" " 0, suppress warning messages" czero))) - htMakeDoneButton('"Continue", 'f01mafSolve) - htShowPage() - -f01mafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nz := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nz) - objValUnwrap htpLabelSpadValue(htPage, 'nz) - licn := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'licn) - objValUnwrap htpLabelSpadValue(htPage, 'licn) - lirn := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lirn) - objValUnwrap htpLabelSpadValue(htPage, 'lirn) - aerror := htpButtonValue(htPage,'afail) - afail := - aerror = 'azero => '0 - '1 - berror := htpButtonValue(htPage,'bfail) - bfail := - berror = 'bone => '1 - '0 - cerror := htpButtonValue(htPage,'cfail) - cfail := - cerror = 'cone => '1 - '0 - ifail := 100*cfail + 10*bfail + afail - droptl := htpLabelInputString(htPage, 'droptl) - densw := htpLabelInputString(htPage, 'densw) - ((n = '16 and nz = '40) and (licn = '90 and lirn = '50)) - => f01mafDefaultSolve(htPage,droptl,densw,ifail) - labelList := - "append"/[f(i) for i in 1..nz] where f(i) == - prefix := ('"\newline \tab{2} ") - anam := INTERN STRCONC ('"a",STRINGIMAGE i) - mid := ('"\tab{32} ") - rnam := INTERN STRCONC ('"irn",STRINGIMAGE i) - end := ('"\tab{42} ") - cnam := INTERN STRCONC ('"icn",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[8, 0.0, anam, 'F]], - ['text,:mid],['bcStrings,[4, 0, rnam, 'PI]], - ['text,:end],['bcStrings,[4, 0, cnam, 'PI]]] - abortList := - [['bcStrings,[6, '"true", 'abortone, 'EM]], - ['bcStrings,[6, '"true", 'aborttwo, 'EM]], - ['bcStrings,[6, '"true", 'abortthree, 'EM]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} Abort: ") - abortList := [['text,:prefix],:abortList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain EM ($EmptyMode)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:abortList] - page := htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) - htSay '"\menuitemstyle{}\tab{2} Non-zero elements of A: " - htSay '"\tab{30} \menuitemstyle{}\tab{32} Row: " - htSay '"\tab{40} \menuitemstyle{}\tab{42} Column: " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01mafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nz,nz) - htpSetProperty(page,'licn,licn) - htpSetProperty(page,'lirn,lirn) - htpSetProperty(page,'droptl,droptl) - htpSetProperty(page,'densw,densw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01mafDefaultSolve(htPage,droptl,densw,ifail) == - n := '16 - nz := '40 - licn := '90 - lirn := '50 - page := htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Non-zero elements of A: ") - (text . "\tab{30} \menuitemstyle{}\tab{32} Row: ") - (text . "\tab{40} \menuitemstyle{}\tab{42} Column: ") - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a1 F)) - (text . "\tab{32} ") - (bcStrings (4 1 irn1 PI)) - (text . "\tab{42} ") - (bcStrings (4 1 icn1 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a2 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn2 PI)) - (text . "\tab{42} ") - (bcStrings (4 2 icn2 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a3 F)) - (text . "\tab{32} ") - (bcStrings (4 3 irn3 PI)) - (text . "\tab{42} ") - (bcStrings (4 3 icn3 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a4 F)) - (text . "\tab{32} ") - (bcStrings (4 4 irn4 PI)) - (text . "\tab{42} ") - (bcStrings (4 4 icn4 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a5 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn5 PI)) - (text . "\tab{42} ") - (bcStrings (4 5 icn5 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a6 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn6 PI)) - (text . "\tab{42} ") - (bcStrings (4 6 icn6 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a7 F)) - (text . "\tab{32} ") - (bcStrings (4 7 irn7 PI)) - (text . "\tab{42} ") - (bcStrings (4 7 icn7 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a8 F)) - (text . "\tab{32} ") - (bcStrings (4 8 irn8 PI)) - (text . "\tab{42} ") - (bcStrings (4 8 icn8 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a9 F)) - (text . "\tab{32} ") - (bcStrings (4 9 irn9 PI)) - (text . "\tab{42} ") - (bcStrings (4 9 icn9 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a10 F)) - (text . "\tab{32} ") - (bcStrings (4 10 irn10 PI)) - (text . "\tab{42} ") - (bcStrings (4 10 icn10 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a11 F)) - (text . "\tab{32} ") - (bcStrings (4 11 irn11 PI)) - (text . "\tab{42} ") - (bcStrings (4 11 icn11 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a12 F)) - (text . "\tab{32} ") - (bcStrings (4 12 irn12 PI)) - (text . "\tab{42} ") - (bcStrings (4 12 icn12 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a13 F)) - (text . "\tab{32} ") - (bcStrings (4 13 irn13 PI)) - (text . "\tab{42} ") - (bcStrings (4 13 icn13 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a14 F)) - (text . "\tab{32} ") - (bcStrings (4 14 irn14 PI)) - (text . "\tab{42} ") - (bcStrings (4 14 icn14 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a15 F)) - (text . "\tab{32} ") - (bcStrings (4 15 irn15 PI)) - (text . "\tab{42} ") - (bcStrings (4 15 icn15 PI)) - (text . "\blankline ") - (text . "\newline \tab{2}") - (bcStrings (8 "1.0" a16 F)) - (text . "\tab{32} ") - (bcStrings (4 16 irn16 PI)) - (text . "\tab{42} ") - (bcStrings (4 16 icn16 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a17 F)) - (text . "\tab{32} ") - (bcStrings (4 1 irn17 PI)) - (text . "\tab{42} ") - (bcStrings (4 2 icn17 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a18 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn18 PI)) - (text . "\tab{42} ") - (bcStrings (4 3 icn18 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a19 F)) - (text . "\tab{32} ") - (bcStrings (4 3 irn19 PI)) - (text . "\tab{42} ") - (bcStrings (4 4 icn19 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a20 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn20 PI)) - (text . "\tab{42} ") - (bcStrings (4 6 icn20 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a21 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn21 PI)) - (text . "\tab{42} ") - (bcStrings (4 7 icn21 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a22 F)) - (text . "\tab{32} ") - (bcStrings (4 7 irn22 PI)) - (text . "\tab{42} ") - (bcStrings (4 8 icn22 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a23 F)) - (text . "\tab{32} ") - (bcStrings (4 9 irn23 PI)) - (text . "\tab{42} ") - (bcStrings (4 10 icn23 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a24 F)) - (text . "\tab{32} ") - (bcStrings (4 10 irn24 PI)) - (text . "\tab{42} ") - (bcStrings (4 11 icn24 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a25 F)) - (text . "\tab{32} ") - (bcStrings (4 11 irn25 PI)) - (text . "\tab{42} ") - (bcStrings (4 12 icn25 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a26 F)) - (text . "\tab{32} ") - (bcStrings (4 13 irn26 PI)) - (text . "\tab{42} ") - (bcStrings (4 14 icn26 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a27 F)) - (text . "\tab{32} ") - (bcStrings (4 14 irn27 PI)) - (text . "\tab{42} ") - (bcStrings (4 15 icn27 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a28 F)) - (text . "\tab{32} ") - (bcStrings (4 15 irn28 PI)) - (text . "\tab{42} ") - (bcStrings (4 16 icn28 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a29 F)) - (text . "\tab{32} ") - (bcStrings (4 1 irn29 PI)) - (text . "\tab{42} ") - (bcStrings (4 5 icn29 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a30 F)) - (text . "\tab{32} ") - (bcStrings (4 2 irn30 PI)) - (text . "\tab{42} ") - (bcStrings (4 6 icn30 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a31 F)) - (text . "\tab{32} ") - (bcStrings (4 3 irn31 PI)) - (text . "\tab{42} ") - (bcStrings (4 7 icn31 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a32 F)) - (text . "\tab{32} ") - (bcStrings (4 4 irn32 PI)) - (text . "\tab{42} ") - (bcStrings (4 8 icn32 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a33 F)) - (text . "\tab{32} ") - (bcStrings (4 5 irn33 PI)) - (text . "\tab{42} ") - (bcStrings (4 9 icn33 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a34 F)) - (text . "\tab{32} ") - (bcStrings (4 6 irn34 PI)) - (text . "\tab{42} ") - (bcStrings (4 10 icn34 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a35 F)) - (text . "\tab{32} ") - (bcStrings (4 7 irn35 PI)) - (text . "\tab{42} ") - (bcStrings (4 11 icn35 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a36 F)) - (text . "\tab{32} ") - (bcStrings (4 8 irn36 PI)) - (text . "\tab{42} ") - (bcStrings (4 12 icn36 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a37 F)) - (text . "\tab{32} ") - (bcStrings (4 9 irn37 PI)) - (text . "\tab{42} ") - (bcStrings (4 13 icn37 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a38 F)) - (text . "\tab{32} ") - (bcStrings (4 10 irn38 PI)) - (text . "\tab{42} ") - (bcStrings (4 14 icn38 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a39 F)) - (text . "\tab{32} ") - (bcStrings (4 11 irn39 PI)) - (text . "\tab{42} ") - (bcStrings (4 15 icn39 PI)) - (text . "\newline \tab{2}") - (bcStrings (8 "-0.25" a40 F)) - (text . "\tab{32} ") - (bcStrings (4 12 irn40 PI)) - (text . "\tab{42} ") - (bcStrings (4 16 icn40 PI)) - (text . "\blankline ") - (text . "\menuitemstyle{} \tab{2} Abort :") - (bcStrings (8 "true" abort_one EM)) - (bcStrings (8 "true" abort_two EM)) - (bcStrings (8 "true" abort_three EM))) - htMakeDoneButton('"Continue",'f01mafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nz,nz) - htpSetProperty(page,'licn,licn) - htpSetProperty(page,'lirn,lirn) - htpSetProperty(page,'droptl,droptl) - htpSetProperty(page,'densw,densw) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01mafGen htPage == - n := htpProperty(htPage,'n) - nz := htpProperty(htPage,'nz) - licn := htpProperty(htPage,'licn) - lirn := htpProperty(htPage,'lirn) - droptl := htpProperty(htPage,'droptl) - densw := htpProperty(htPage,'densw) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..3 repeat - abort := STRCONC((first y).1," ") - y := rest y - abortList := [abort,:abortList] - astring := bcwords2liststring abortList - while y repeat - end := STRCONC ((first y).1," ") - y := rest y - mid := STRCONC ((first y).1," ") - y := rest y - top := STRCONC ((first y).1," ") - y := rest y - cList := [end,:cList] - rList := [mid,:rList] - matList := [top,:matList] - for i in 1..(licn-nz) repeat - cList := [:cList,'"0 "] - matList := [:matList,'"0 "] - for i in 1..(lirn-nz) repeat - rList := [:rList,'"0 "] - cstring := bcwords2liststring cList - rstring := bcwords2liststring rList - matstring := bcwords2liststring matList - prefix := STRCONC('"f01maf(",STRINGIMAGE n,", ",STRINGIMAGE nz,", ") - prefix := STRCONC(prefix,STRINGIMAGE licn,", ",STRINGIMAGE lirn,", ") - prefix := STRCONC(prefix,astring,",[",matstring) - prefix := STRCONC(prefix,"],[",rstring,"],[",cstring,"], ",droptl,", ",densw) - linkGen STRCONC(prefix,", ",STRINGIMAGE ifail,")") - - - - -f01mcf() == - htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf01mcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01mcf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the Cholesky factorization of a real symmetric positive") - (text . "-definite variable-bandwidth matrix {\it A} or order {\it n}. ") - (text . "That is, {\it A = }\htbitmap{ldlt}, where {\it L} is ") - (text . "a unit lower triangular matrix and {\it D} is a diagonal matrix.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the order {\em n} of the matrix A ") - (text . "\htbitmap{great=} 1:") - (text . "\newline\tab{2} ") - (bcStrings (9 6 n PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Enter the number of elements: ") - (text . "\newline\tab{2} ") - (bcStrings (9 14 lal PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01mcfSolve) - htShowPage() - -f01mcfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lal := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lal) - objValUnwrap htpLabelSpadValue(htPage, 'lal) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and lal = '14) => f01mcfDefaultSolve(htPage,ifail) - labelList := - "append"/[f(i) for i in 1..lal] where f(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[6, 0.0, xnam, 'F]]] - nrowList := - "append"/[g(j) for j in 1..n] where g(j) == - nam := INTERN STRCONC ('"n",STRINGIMAGE j) - [['bcStrings,[6, 0, nam, 'PI]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it NROW(n)} the width ") - prefix := STRCONC(prefix,"of the ith row of A: \newline \tab{2} ") - nrowList := [['text,:prefix],:nrowList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:nrowList] - page := htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) - htSay '"\menuitemstyle{}\tab{2} Elements of matrix {\it A} in row by row " - htSay '"order: \newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01mcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'lal,lal) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01mcfDefaultSolve (htPage,ifail) == - n := '6 - lal := '14 - page := htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Elements of matrix {\it A} in row by ") - (text . "row order: ") - (text . "\newline ") - (bcStrings (6 "1.0" x1 F)) - (bcStrings (6 "2.0" x2 F)) - (bcStrings (6 "5.0" x3 F)) - (bcStrings (6 "3.0" x4 F)) - (bcStrings (6 "13.0" x5 F)) - (bcStrings (6 "16.0" x6 F)) - (bcStrings (6 "5.0" x7 F)) - (bcStrings (6 "14.0" x8 F)) - (bcStrings (6 "18.0" x9 F)) - (bcStrings (6 "8.0" x10 F)) - (bcStrings (6 "55.0" x11 F)) - (bcStrings (6 "24.0" x12 F)) - (bcStrings (6 "17.0" x13 F)) - (bcStrings (6 "77.0" x14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it NROW(n)} the width of the ith row ") - (text . "of A: ") - (text . "\newline ") - (bcStrings (6 1 n1 PI)) - (bcStrings (6 2 n2 PI)) - (bcStrings (6 2 n3 PI)) - (bcStrings (6 1 n4 PI)) - (bcStrings (6 5 n5 PI)) - (bcStrings (6 3 n6 PI)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01mcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'lal,lal) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01mcfGen htPage == - n := htpProperty(htPage,'n) - lal := htpProperty(htPage,'lal) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - right := STRCONC ((first y).1," ") - y := rest y - nrowList := [right,:nrowList] - nrowstring := bcwords2liststring nrowList - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - matList := [right,:matList] - matstring := bcwords2liststring matList - prefix := STRCONC('"f01mcf(",STRINGIMAGE n,", [",matstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE lal,", [",nrowstring,"], ") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - - -f01qcf() == - htInitPage('"F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01qcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qcf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Finds the QR factorization of a real {\it m} by {it n} ({\it m ") - (text . "\htbitmap{great=} n}) matrix {\it A}, which ") - (text . "is factorized as \htbitmap{f01qcf}, ") - (text . "where {\it m > n} and {\it A = QR } when {\it m = n }, where ") - (text . "{\it Q} is an {\it m} by {\it m } orthogonal matrix and {\it R} ") - (text . "is an {\it n} by {\it n} upper triangular matrix. The {\it k}th ") - (text . "transformation matrix,{\it Qk}, ") - (text . "which is used to introduce zeros into the {\it k}th column of ") - (text . "{\it A}, is given in the form ") - (text . "\htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01qcf2}, ") - (text . "\htbitmap{f01qcf3}, ") - (text . "\htbitmap{zetak} is a scalar and ") - (text . "\htbitmap{zk} is an (m-k) element vector. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01qcfSolve) - htShowPage() - -f01qcfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '5 and n = '3) => f01qcfDefaultSolve(htPage,lda,ifail) - matList := - "append"/[f(i,n) for i in 1..lda] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage("F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01qcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01qcfDefaultSolve (htPage,lda,ifail) == - n := '3 - m := '5 - page := htInitPage('"F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a11 F)) - (bcStrings (6 "2.5" a12 F)) - (bcStrings (6 "2.5" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a21 F)) - (bcStrings (6 "2.5" a22 F)) - (bcStrings (6 "2.5" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.6" a31 F)) - (bcStrings (6 "-0.4" a32 F)) - (bcStrings (6 "2.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a41 F)) - (bcStrings (6 "-0.5" a42 F)) - (bcStrings (6 "0.5" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.2" a51 F)) - (bcStrings (6 "-0.3" a52 F)) - (bcStrings (6 "-2.9" a53 F))) - htMakeDoneButton('"Continue",'f01qcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01qcfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) - lda := m - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f01qcf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",matstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f01qdf() == - htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01qdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qdf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Performs one of the transformations {\it B = QB or B = }") - (text . "\htbitmap{f01qdf}, where {\it B} is a real {\it m} ") - (text . "by {\it ncolb} matrix and {\it Q} is an {\it m} by {\it m} ") - (text . "orthogonal matrix assumed to be given by {\it Q = }") - (text . "\htbitmap{f01qdf1}, \htbitmap{f01qdf2} ") - (text . "being given in the form ") - (text . "\htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01qcf2}, ") - (text . "\htbitmap{f01qcf3}, ") - (text . "\htbitmap{zetak} is a scalar and ") - (text . "\htbitmap{zk} is an (m-k) element vector. ") - (text . "The routine is intended for use following F01QCF or F01QFF. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of B, {\it ldb} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) --- (text . "\tab{34} ") --- (bcStrings (6 5 ldb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Number of columns of matrix B {\it ncolb}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 2 ncolb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Transformation to be performed: ") - (radioButtons trans - (" " " {\it B = QB}" no_trans) - (" " " {\it B =} \htbitmap{f01qdf}" trans)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Where the elements can be found: ") - (radioButtons wheret - (" " " the elements of \zeta are in A" in_a) - (" " " the elements of \zeta are in ZETA, returned by F01QCF/F01QFF" seperate)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01qdfSolve) - htShowPage() - -f01qdfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - ncolb := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) - objValUnwrap htpLabelSpadValue(htPage, 'ncolb) - operation := htpButtonValue(htPage,'trans) - trans := - operation = 'no_trans => '"n" - '"t" - elements := htpButtonValue(htPage,'wheret) - wheret := - elements = 'in_a => '"i" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolb = '2) => f01qdfDefaultSolve(htPage,lda,ldb,trans,wheret,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bList := - "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == - labelList := - "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") - bList := [['text,:prefix],:bList] - zList := - "append"/[fz(i) for i in 1..n] where fz(i) == - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - [['bcStrings,[6, "0.0", znam, 'F]]] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \zeta ") - prefix := STRCONC(prefix,"(if required): \newline \tab{2}") - zList := [['text,:prefix],:zList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bList,:zList] - page := htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01qdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01qdfDefaultSolve (htPage,lda,ldb,trans,wheret,ifail) == - n := '3 - m := '5 - ncolb := '2 - page := htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a11 F)) - (bcStrings (6 "2.5" a12 F)) - (bcStrings (6 "2.5" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a21 F)) - (bcStrings (6 "2.5" a22 F)) - (bcStrings (6 "2.5" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.6" a31 F)) - (bcStrings (6 "-0.4" a32 F)) - (bcStrings (6 "2.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a41 F)) - (bcStrings (6 "-0.5" a42 F)) - (bcStrings (6 "0.5" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.2" a51 F)) - (bcStrings (6 "-0.3" a52 F)) - (bcStrings (6 "-2.9" a53 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.1" b11 F)) - (bcStrings (6 "0.0" b12 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.9" b21 F)) - (bcStrings (6 "0.0" b22 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.6" b31 F)) - (bcStrings (6 "1.32" b32 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b41 F)) - (bcStrings (6 "1.1" b42 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-0.8" b51 F)) - (bcStrings (6 "-0.26" b52 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \zeta (if required): ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" z1 F)) - (bcStrings (10 "0.0" z2 F)) - (bcStrings (10 "0.0" z3 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01qdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01qdfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) --- ldb := htpProperty(htPage,'ldb) - lda := m - ldb := m - ncolb := htpProperty(htPage,'ncolb) - trans := htpProperty(htPage,'trans) - wheret := htpProperty(htPage,'wheret) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - left := STRCONC((first y).1," ") - y := rest y - zetalist := [left,:zetalist] - zetastring := bcwords2liststring zetalist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - for i in 1..ldb repeat - for j in 1..ncolb repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f01qdf(_"",trans,"_",_"",wheret,"_",",STRINGIMAGE m,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",STRINGIMAGE lda) - prefix := STRCONC(prefix,",[",zetastring,"],",STRINGIMAGE ncolb,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - - -f01qef() == - htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01qef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qef| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns the first {\it ncolq} columns of the real {\it m} by ") - (text . "{\it n} orthogonal matrix {\it Q}, where {\it Q} is assumed ") - (text . "to be given by {\it Q = }\htbitmap{f01qdf1}, ") - (text . "\htbitmap{f01qdf2} being given in the form ") - (text . "\htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01qcf2}, ") - (text . "\htbitmap{f01qcf3}, ") - (text . "\htbitmap{zetak} is a scalar and ") - (text . "\htbitmap{zk} is an (m-k) element vector. ") - (text . "The routine is intended for use following F01QCF or F01QFF. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Number columns of matrix Q {\it ncolq}: ") - (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) --- (text . "\tab{34} ") - (bcStrings (6 5 ncolq PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Where the elements can be found: ") - (radioButtons wheret - (" " " the elements of \zeta are in ZETA, returned by F01QCF/F01QFF" subsequent) - (" " " the elements of \zeta are in A" initial)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01qefSolve) - htShowPage() - -f01qefSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ncolq := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolq) - objValUnwrap htpLabelSpadValue(htPage, 'ncolq) - elements := htpButtonValue(htPage,'wheret) - wheret := - elements = 'initial => '"i" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolq = '5) => f01qefDefaultSolve(htPage,lda,wheret,ifail) - matList := - "append"/[fa(i,ncolq) for i in 1..lda] where fa(i,ncolq) == - labelList := - "append"/[ga(i,j) for j in 1..ncolq] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[7, "0.0", anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - zList := - "append"/[fz(i) for i in 1..n] where fz(i) == - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - [['bcStrings,[7, "0.0", znam, 'F]]] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \zeta ") - prefix := STRCONC(prefix,"(if required): \newline ") - zList := [['text,:prefix],:zList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:zList] - page := htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it Q}: " - htSay '"\newline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01qefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ncolq,ncolq) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01qefDefaultSolve (htPage,lda,wheret,ifail) == - n := '3 - m := '5 - ncolq := '5 - page := htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it Q}") - (text . "(in this case returned by the default entries of F01QCF) : ") - (text . "\newline ") - (bcStrings (7 "-4.0" a11 F)) - (bcStrings (7 "-2.0" a12 F)) - (bcStrings (7 "-3.0" a13 F)) - (bcStrings (7 "0.0" a14 F)) - (bcStrings (7 "0.0" a15 F)) - (text . "\newline ") - (bcStrings (7 "0.4085" a21 F)) - (bcStrings (7 "-3.0" a22 F)) - (bcStrings (7 "-2.0" a23 F)) - (bcStrings (7 "0.0" a24 F)) - (bcStrings (7 "0.0" a25 F)) - (text . "\newline ") - (bcStrings (7 "0.3266" a31 F)) - (bcStrings (7 "-0.4619" a32 F)) - (bcStrings (7 "-4.0" a33 F)) - (bcStrings (7 "0.0" a34 F)) - (bcStrings (7 "0.0" a35 F)) - (text . "\newline ") - (bcStrings (7 "0.4082" a41 F)) - (bcStrings (7 "-0.5774" a42 F)) - (bcStrings (7 "0.0" a43 F)) - (bcStrings (7 "0.0" a44 F)) - (bcStrings (7 "0.0" a45 F)) - (text . "\newline ") - (bcStrings (7 "0.2449" a51 F)) - (bcStrings (7 "-0.3464" a52 F)) - (bcStrings (7 "-0.6326" a53 F)) - (bcStrings (7 "0.0" a54 F)) - (bcStrings (7 "0.0" a55 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \zeta: ") - (text . "\newline ") - (bcStrings (10 "1.2247" z1 F)) - (bcStrings (10 "1.1547" z2 F)) - (bcStrings (10 "1.2649" z3 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01qefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ncolq,ncolq) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01qefGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) - lda := m - ncolq := htpProperty(htPage,'ncolq) - wheret := htpProperty(htPage,'wheret) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - left := STRCONC((first y).1," ") - y := rest y - zetalist := [left,:zetalist] - zetastring := bcwords2liststring zetalist - y := REVERSE y - for i in 1..lda repeat - for j in 1..ncolq repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f01qef(_"",wheret,"_",",STRINGIMAGE m,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE lda,", ") - prefix := STRCONC(prefix,STRINGIMAGE ncolq,",[",zetastring,"],") - prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - -f01rcf() == - htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01rcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01rcf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Finds the QR factorization of the complex m by n matrix {\it A},") - (text . " which is factorized as \htbitmap{f01qcf}, where m > n") - (text . " and A = QR when m = n , where Q is an m by m unitary matrix ") - (text . "and R is an n by n upper triangular matrix with real diagonal ") - (text . "elements. The {\it k}th transformation matrix,{\it Qk}, ") - (text . "which is used to introduce zeros into the {\it k}th column of ") - (text . "{\it A}, is given in the form ") - (text . "\htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01rdf2}, ") - (text . "\htbitmap{f01qcf3}, ") - (text . "\htbitmap{gammak} is a scalar for which Re ") - (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") - (text . "is a real scalar and \htbitmap{zk} is an ") - (text . "(m-k) element vector. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01rcfSolve) - htShowPage() - -f01rcfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '5 and n = '3) => f01rcfDefaultSolve(htPage,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[16, "0.0 + 0.0*%i", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01rcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01rcfDefaultSolve (htPage,ifail) == - n := '3 - m := '5 - lda := '5 - page := htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (15 "0.5*%i" a11 F)) - (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) - (bcStrings (15 "-1.0 + 1.0*%i" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4 + 0.3*%i" a21 F)) - (bcStrings (15 "0.9 + 1.3*%i" a22 F)) - (bcStrings (15 "0.2 + 1.4*%i" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4" a31 F)) - (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) - (bcStrings (15 "1.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.3 - 0.4*%i" a41 F)) - (bcStrings (15 "0.1 + 0.7*%i" a42 F)) - (bcStrings (15 "0.0" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "-0.3*%i" a51 F)) - (bcStrings (15 "0.3 + 0.3*%i" a52 F)) - (bcStrings (15 "2.4*%i" a53 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01rcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01rcfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) - lda := m - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f01rcf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",matstring) - linkGen STRCONC(prefix,", ",STRINGIMAGE ifail,")") - -f01rdf() == - htInitPage('"F01RDF - Operations with unitary matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01rdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01rdf| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Performs one of the transformations B = QB or B = ") - (text . "\htbitmap{f01rdf}, where B is an m ") - (text . "by ncolb matrix and Q is an m by m ") - (text . "unitary matrix assumed to be given by Q = ") - (text . "\htbitmap{f01rdf1}, \htbitmap{f01qdf2} ") - (text . "being given in the form \htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01rdf2}, \htbitmap{f01qcf3}") - (text . ", \htbitmap{gammak} is a scalar for which Re ") - (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") - (text . "is a real scalar and \htbitmap{zk} is an ") - (text . "(m-k) element vector. ") - (text . "The routine is intended for use following F01QCF or F01QFF. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of B, {\it ldb} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) --- (text . "\tab{34} ") --- (bcStrings (6 5 ldb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Number of columns of matrix B {\it ncolb}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 2 ncolb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Transformation to be performed: ") - (radioButtons trans - (" " " {\it B = QB}" no_trans) - (" " " {\it B =} \htbitmap{f01rdf} (Conjugate Transpose)" trans)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Where the elements can be found: ") - (radioButtons wheret - (" " " the elements of \theta are in A" in_a) - (" " " the elements of \theta are in THETA" seperate)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01rdfSolve) - htShowPage() - -f01rdfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - ncolb := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) - objValUnwrap htpLabelSpadValue(htPage, 'ncolb) - operation := htpButtonValue(htPage,'trans) - trans := - operation = 'no_trans => '"n" - '"c" - elements := htpButtonValue(htPage,'wheret) - wheret := - elements = 'in_a => '"i" - '"c" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolb = '2) => f01rdfDefaultSolve(htPage,lda,ldb,trans,wheret,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[16, "0.0 + 0.0*%i", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bList := - "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == - labelList := - "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[16, "0.0 + 0.0*%i", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") - bList := [['text,:prefix],:bList] - zList := - "append"/[fz(i) for i in 1..n] where fz(i) == - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - [['bcStrings,[16, "0.0", znam, 'F]]] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \theta ") - prefix := STRCONC(prefix,"(if required): \newline \tab{2}") - zList := [['text,:prefix],:zList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bList,:zList] - page := htInitPage('"F01RDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF or F01RDF",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01rdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01rdfDefaultSolve (htPage,lda,ldb,trans,wheret,ifail) == - n := '3 - m := '5 - ncolb := '2 - page := htInitPage('"F01RDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF or F01RDF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (15 "0.5*%i" a11 F)) - (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) - (bcStrings (15 "-1.0 + 1.0*%i" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4 + 0.3*%i" a21 F)) - (bcStrings (15 "0.9 + 1.3*%i" a22 F)) - (bcStrings (15 "0.2 + 1.4*%i" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4" a31 F)) - (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) - (bcStrings (15 "1.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.3 - 0.4*%i" a41 F)) - (bcStrings (15 "0.1 + 0.7*%i" a42 F)) - (bcStrings (15 "0.0" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "-0.3*%i" a51 F)) - (bcStrings (15 "0.3 + 0.3*%i" a52 F)) - (bcStrings (15 "2.4" a53 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (15 "-0.55 + 1.05*%i" b11 F)) - (bcStrings (15 "0.45 + 1.05*%i" b12 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.49 + 0.93*%i" b21 F)) - (bcStrings (15 "1.09 + 0.13*%i" b22 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.56 - 0.16*%i" b31 F)) - (bcStrings (15 "0.64 + 0.16*%i" b32 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.39 + 0.23*%i" b41 F)) - (bcStrings (15 "-0.39 - 0.23*%i" b42 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "1.13 + 0.83*%i" b51 F)) - (bcStrings (15 "-1.13 + 0.77*%i" b52 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \theta (if required): ") - (text . "\newline \tab{2} ") - (bcStrings (15 "0.0" z1 F)) - (bcStrings (15 "0.0" z2 F)) - (bcStrings (15 "0.0" z3 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01rdfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01rdfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) --- ldb := htpProperty(htPage,'ldb) - lda := m - ldb := m - ncolb := htpProperty(htPage,'ncolb) - trans := htpProperty(htPage,'trans) - wheret := htpProperty(htPage,'wheret) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - left := STRCONC((first y).1," ") - y := rest y - zetalist := [left,:zetalist] - zetastring := bcwords2liststring zetalist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - for i in 1..ldb repeat - for j in 1..ncolb repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f01rdf(_"",trans,"_",_"",wheret,"_",",STRINGIMAGE m,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",STRINGIMAGE lda) - prefix := STRCONC(prefix,",[",zetastring,"],",STRINGIMAGE ncolb,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - - -f01ref() == - htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf01ref} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01ref| '|NagMatrixOperationsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns the first {\it ncolq} columns of the real {\it m} by ") - (text . "{\it m} unitary matrix {\it Q}, where {\it Q} is assumed ") - (text . "to be given by {\it Q = }\htbitmap{f01rdf1}, ") - (text . "\htbitmap{f01qdf2} being given in the form ") - (text . "\htbitmap{f01qcf1}, ") - (text . "where \htbitmap{f01rdf2}, ") - (text . "\htbitmap{f01qcf3}, ") - (text . "\htbitmap{gammak} is a scalar for which Re ") - (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") - (text . "is a real scalar and \htbitmap{zk} is an ") - (text . "(m-k) element vector. ") - (text . "The routine is intended for use following F01RCF or F01RFF. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda} ") --- (text . "\htbitmap{great=} m: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Required number of columns of matrix Q {\it ncolq}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 2 ncolq PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Where the elements can be found: ") - (radioButtons wheret - (" " " the elements of \theta are in THETA" seperate) - (" " " the elements of \theta are in A" in_a)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f01refSolve) - htShowPage() - -f01refSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ncolq := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolq) - objValUnwrap htpLabelSpadValue(htPage, 'ncolq) - elements := htpButtonValue(htPage,'wheret) - wheret := - elements = 'in_a => '"i" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolq = '2) => f01refDefaultSolve(htPage,lda,wheret,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[20, "0.0 + 0.0*%i", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - zList := - "append"/[fz(i) for i in 1..n] where fz(i) == - znam := INTERN STRCONC ('"z",STRINGIMAGE i) - [['bcStrings,[20, "0.0", znam, 'F]]] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \theta ") - prefix := STRCONC(prefix,"(if required): \newline \tab{2}") - zList := [['text,:prefix],:zList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:zList] - page := htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f01refGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ncolq,ncolq) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f01refDefaultSolve (htPage,lda,wheret,ifail) == - n := '3 - m := '5 - ncolq := '2 - page := htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (16 "1" a11 F)) - (bcStrings (16 "1 + %i" a12 F)) - (bcStrings (16 "1 + %i" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (16 "-0.2-0.4*%i" a21 F)) - (bcStrings (16 "-2" a22 F)) - (bcStrings (16 "-1 - %i" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (16 "-0.32 - 0.16*%i" a31 F)) - (bcStrings (16 "-0.3505+0.263*%i" a32 F)) - (bcStrings (16 "-3" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (16 "-0.4 + 0.2*%i" a41 F)) - (bcStrings (16 "0.5477*%i" a42 F)) - (bcStrings (16 "0.0" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (16 "-0.12 + 0.24*%i" a51 F)) - (bcStrings (16 "0.1972+0.2629*%i" a52 F)) - (bcStrings (16 "0.6325" a53 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of \theta: ") - (text . "\newline \tab{2} ") - (bcStrings (16 "1 + 0.5*%i" z1 F)) - (bcStrings (16 "1.0954-0.3333*%i" z2 F)) - (bcStrings (16 "1.2649-1.1565*%i" z3 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f01refGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ncolq,ncolq) - htpSetProperty(page,'wheret,wheret) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f01refGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- lda := htpProperty(htPage,'lda) - lda := m - ncolq := htpProperty(htPage,'ncolq) - wheret := htpProperty(htPage,'wheret) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - left := STRCONC((first y).1," ") - y := rest y - thetalist := [left,:thetalist] - thetastring := bcwords2liststring thetalist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f01ref(_"",wheret,"_",",STRINGIMAGE m,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE ncolq,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,",[",thetastring,"],") - prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - diff --git a/src/interp/nag-f01.boot.pamphlet b/src/interp/nag-f01.boot.pamphlet new file mode 100644 index 00000000..7751874b --- /dev/null +++ b/src/interp/nag-f01.boot.pamphlet @@ -0,0 +1,2252 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-f01.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +f01brf() == + htInitPage("F01BRF - LU factorization of real sparse matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf01brf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01brf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Factorizes a real sparse matrix A of order n. The routine forms ") + (text . "the {\it LU} factorization of the entire matrix, or ,") + (text . "optionally, first permutes the matrix to block lower ") + (text . "triangular form and then only factorizes the diagonal block. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the order {\em n} of the matrix A ") + (text . "\htbitmap{great=} 1:") + (text . "\newline\tab{2} ") + (bcStrings (8 6 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of non-zero elements {\it nz}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "{\it pivot}:") + (text . "\newline \tab{2} ") + (bcStrings (8 15 nz PI)) + (text . "\tab{34} ") + (bcStrings (8 "0.1" pivot PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of A & ICN {\it licn}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Dimension of IRN {\it lirn}:") + (text . "\newline \tab{2} ") + (bcStrings (6 150 licn PI)) + (text . "\tab{34} ") + (bcStrings (6 75 lirn PI)) + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2} Grow value:") + (radioButtons grow + ("" " True" gr_true) + ("" " False" gr_false)) + (text . "\blankline") + (text . "\menuitemstyle{}\tab{2} Lblock value:") + (radioButtons lblock + ("" " True" lb_true) + ("" " False" lb_false)) + (text . "\blankline ") + (text . "\newline \tab{2} ") + (text . "Ifail is input in three components: ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it a} ") + (radioButtons afail + ("" " 0, hard failure" azero) + ("" " 1, soft failure" aone)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it b} ") + (radioButtons bfail + ("" " 1, print error messages" bone) + ("" " 0, suppress error messages" bzero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it c} ") + (radioButtons cfail + ("" " 1, print warning messages" cone) + ("" " 0, suppress warning messages" czero))) + htMakeDoneButton('"Continue", 'f01brfSolve) + htShowPage() + +f01brfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nz := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nz) + objValUnwrap htpLabelSpadValue(htPage, 'nz) + licn := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'licn) + objValUnwrap htpLabelSpadValue(htPage, 'licn) + lirn := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lirn) + objValUnwrap htpLabelSpadValue(htPage, 'lirn) + pivot := htpLabelInputString(htPage, 'pivot) + gr := htpButtonValue(htPage,'grow) + grow := + gr = 'gr_true => '"true" + '"false" + lb := htpButtonValue(htPage,'lblock) + lblock := + lb = 'lb_true => '"true" + '"false" + aerror := htpButtonValue(htPage,'afail) + afail := + aerror = 'azero => '0 + '1 + berror := htpButtonValue(htPage,'bfail) + bfail := + berror = 'bone => '1 + '0 + cerror := htpButtonValue(htPage,'cfail) + cfail := + cerror = 'cone => '1 + '0 + ifail := 100*cfail + 10*bfail + afail + ((n = '6 and nz = '15) and (licn = '150 and lirn = '75)) + => f01brfDefaultSolve(htPage,pivot,grow,lblock,ifail) + labelList := + "append"/[f(i) for i in 1..nz] where f(i) == + prefix := ('"\newline \tab{2} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + mid := ('"\tab{32} ") + rnam := INTERN STRCONC ('"irn",STRINGIMAGE i) + end := ('"\tab{42} ") + cnam := INTERN STRCONC ('"icn",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, anam, 'F]], + ['text,:mid],['bcStrings,[4, 0, rnam, 'PI]], + ['text,:end],['bcStrings,[4, 0, cnam, 'PI]]] + abortList := + [['bcStrings,[6, '"true", 'abortone, 'EM]], + ['bcStrings,[6, '"true", 'aborttwo, 'EM]], + ['bcStrings,[6, '"false", 'abortthree, 'EM]], + ['bcStrings,[6, '"true", 'abortfour, 'EM]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} Abort: ") + abortList := [['text,:prefix],:abortList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain EM ($EmptyMode)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:abortList] + page := htInitPage("F01BRF - LU factorization of real sparse matrix",nil) + htSay '"\menuitemstyle{}\tab{2} Non-zero elements of A: " + htSay '"\tab{30} \menuitemstyle{}\tab{32} Row: " + htSay '"\tab{40} \menuitemstyle{}\tab{42} Column: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01brfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nz,nz) + htpSetProperty(page,'licn,licn) + htpSetProperty(page,'lirn,lirn) + htpSetProperty(page,'pivot,pivot) + htpSetProperty(page,'grow,grow) + htpSetProperty(page,'lblock,lblock) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01brfDefaultSolve(htPage,pivot,grow,lblock,ifail) == + n := '6 + nz := '15 + licn := '150 + lirn := '75 + page := htInitPage("F01BRF - LU factorization of real sparse matrix",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Non-zero elements of A: ") + (text . "\tab{30} \menuitemstyle{}\tab{32} Row: ") + (text . "\tab{40} \menuitemstyle{}\tab{42} Column: ") + (text . "\newline \tab{2}") + (bcStrings (8 "5.0" a1 F)) + (text . "\tab{32} ") + (bcStrings (4 1 irn1 PI)) + (text . "\tab{42} ") + (bcStrings (4 1 icn1 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "2.0" a2 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn2 PI)) + (text . "\tab{42} ") + (bcStrings (4 2 icn2 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-1.0" a3 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn3 PI)) + (text . "\tab{42} ") + (bcStrings (4 3 icn3 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "2.0" a4 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn4 PI)) + (text . "\tab{42} ") + (bcStrings (4 4 icn4 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "3.0" a5 F)) + (text . "\tab{32} ") + (bcStrings (4 3 irn5 PI)) + (text . "\tab{42} ") + (bcStrings (4 3 icn5 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-2.0" a6 F)) + (text . "\tab{32} ") + (bcStrings (4 4 irn6 PI)) + (text . "\tab{42} ") + (bcStrings (4 1 icn6 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a7 F)) + (text . "\tab{32} ") + (bcStrings (4 4 irn7 PI)) + (text . "\tab{42} ") + (bcStrings (4 4 icn7 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a8 F)) + (text . "\tab{32} ") + (bcStrings (4 4 irn8 PI)) + (text . "\tab{42} ") + (bcStrings (4 5 icn8 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-1.0" a9 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn9 PI)) + (text . "\tab{42} ") + (bcStrings (4 1 icn9 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-1.0" a10 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn10 PI)) + (text . "\tab{42} ") + (bcStrings (4 4 icn10 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "2.0" a11 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn11 PI)) + (text . "\tab{42} ") + (bcStrings (4 5 icn11 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-3.0" a12 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn12 PI)) + (text . "\tab{42} ") + (bcStrings (4 6 icn12 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-1.0" a13 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn13 PI)) + (text . "\tab{42} ") + (bcStrings (4 1 icn13 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-1.0" a14 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn14 PI)) + (text . "\tab{42} ") + (bcStrings (4 2 icn14 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "6.0" a15 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn15 PI)) + (text . "\tab{42} ") + (bcStrings (4 6 icn15 PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} Abort :") + (bcStrings (8 "true" abort_one EM)) + (bcStrings (8 "true" abort_two EM)) + (bcStrings (8 "false" abort_three EM)) + (bcStrings (8 "true" abort_four EM))) + htMakeDoneButton('"Continue",'f01brfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nz,nz) + htpSetProperty(page,'licn,licn) + htpSetProperty(page,'lirn,lirn) + htpSetProperty(page,'pivot,pivot) + htpSetProperty(page,'grow,grow) + htpSetProperty(page,'lblock,lblock) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01brfGen htPage == + n := htpProperty(htPage,'n) + nz := htpProperty(htPage,'nz) + licn := htpProperty(htPage,'licn) + lirn := htpProperty(htPage,'lirn) + pivot := htpProperty(htPage,'pivot) + grow := htpProperty(htPage,'grow) + lblock := htpProperty(htPage,'lblock) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..4 repeat + abort := STRCONC((first y).1," ") + y := rest y + abortList := [abort,:abortList] + astring := bcwords2liststring abortList + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + top := STRCONC ((first y).1," ") + y := rest y + cList := [end,:cList] + rList := [mid,:rList] + matList := [top,:matList] + for i in 1..(licn-nz) repeat + cList := [:cList,'"0 "] + matList := [:matList,'"0 "] + for i in 1..(lirn-nz) repeat + rList := [:rList,'"0 "] + cstring := bcwords2liststring cList + rstring := bcwords2liststring rList + matstring := bcwords2liststring matList + prefix := STRCONC('"f01brf(",STRINGIMAGE n,", ",STRINGIMAGE nz,", ") + prefix := STRCONC(prefix,STRINGIMAGE licn,", ",STRINGIMAGE lirn,", ",pivot) + prefix := STRCONC(prefix,", ",lblock,", ",grow,", ",astring,",[",matstring) + prefix := STRCONC(prefix,"],[",rstring,"],[",cstring,"], ") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + +f01bsf() == + htInitPage("F01BSF - LU factorization of real sparse matrix with known sparsity pattern",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf01bsf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01bsf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Factorizes a real sparse matrix A of order n using the pivotal ") + (text . "sequence previously obtained by F01BRF when a matrix of the ") + (text . "same sparsity pattern was factorized. ") + (text . "\blankline ") + (text . "Read the input file to see the example program. ") + (text . "\spadpaste{)read f01bsf \bound{s0}} ") + (text . "\blankline") + (text . "\newline ")) + htShowPage() + +f01maf() == + htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf01maf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01maf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes an incomplete Cholesky factorization of a real ") + (text . "sparse symmetric positive-definite matrix A of order n. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the order {\em n} of the matrix A ") + (text . "\htbitmap{great=} 1:") + (text . "\newline\tab{2} ") + (bcStrings (8 16 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of non-zero elements {\it nz}:") + (text . "\newline \tab{2} ") + (bcStrings (8 40 nz PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Dimension of A & ICN {\it licn}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Dimension of IRN {\it lirn}:") + (text . "\newline \tab{2} ") + (bcStrings (6 90 licn PI)) + (text . "\tab{34} ") + (bcStrings (6 50 lirn PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Tolerance {\it droptl}: ") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "{\it densw}:") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.1" droptl F)) + (text . "\tab{34} ") + (bcStrings (6 "0.8" densw F)) + (text . "\blankline ") + (text . "\newline \tab{2} ") + (text . "Ifail is input in three components: ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it a} ") + (radioButtons afail + ("" " 0, hard failure" azero) + ("" " 1, soft failure" aone)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it b} ") + (radioButtons bfail + ("" " 1, print error messages" bone) + ("" " 0, suppress error messages" bzero)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "{\it c} ") + (radioButtons cfail + ("" " 1, print warning messages" cone) + ("" " 0, suppress warning messages" czero))) + htMakeDoneButton('"Continue", 'f01mafSolve) + htShowPage() + +f01mafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nz := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nz) + objValUnwrap htpLabelSpadValue(htPage, 'nz) + licn := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'licn) + objValUnwrap htpLabelSpadValue(htPage, 'licn) + lirn := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lirn) + objValUnwrap htpLabelSpadValue(htPage, 'lirn) + aerror := htpButtonValue(htPage,'afail) + afail := + aerror = 'azero => '0 + '1 + berror := htpButtonValue(htPage,'bfail) + bfail := + berror = 'bone => '1 + '0 + cerror := htpButtonValue(htPage,'cfail) + cfail := + cerror = 'cone => '1 + '0 + ifail := 100*cfail + 10*bfail + afail + droptl := htpLabelInputString(htPage, 'droptl) + densw := htpLabelInputString(htPage, 'densw) + ((n = '16 and nz = '40) and (licn = '90 and lirn = '50)) + => f01mafDefaultSolve(htPage,droptl,densw,ifail) + labelList := + "append"/[f(i) for i in 1..nz] where f(i) == + prefix := ('"\newline \tab{2} ") + anam := INTERN STRCONC ('"a",STRINGIMAGE i) + mid := ('"\tab{32} ") + rnam := INTERN STRCONC ('"irn",STRINGIMAGE i) + end := ('"\tab{42} ") + cnam := INTERN STRCONC ('"icn",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[8, 0.0, anam, 'F]], + ['text,:mid],['bcStrings,[4, 0, rnam, 'PI]], + ['text,:end],['bcStrings,[4, 0, cnam, 'PI]]] + abortList := + [['bcStrings,[6, '"true", 'abortone, 'EM]], + ['bcStrings,[6, '"true", 'aborttwo, 'EM]], + ['bcStrings,[6, '"true", 'abortthree, 'EM]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} Abort: ") + abortList := [['text,:prefix],:abortList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain EM ($EmptyMode)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:abortList] + page := htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) + htSay '"\menuitemstyle{}\tab{2} Non-zero elements of A: " + htSay '"\tab{30} \menuitemstyle{}\tab{32} Row: " + htSay '"\tab{40} \menuitemstyle{}\tab{42} Column: " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01mafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nz,nz) + htpSetProperty(page,'licn,licn) + htpSetProperty(page,'lirn,lirn) + htpSetProperty(page,'droptl,droptl) + htpSetProperty(page,'densw,densw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01mafDefaultSolve(htPage,droptl,densw,ifail) == + n := '16 + nz := '40 + licn := '90 + lirn := '50 + page := htInitPage("F01MAF - \htbitmap{llt} factorization of real sparse symmetric positive-definite matrix",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Non-zero elements of A: ") + (text . "\tab{30} \menuitemstyle{}\tab{32} Row: ") + (text . "\tab{40} \menuitemstyle{}\tab{42} Column: ") + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a1 F)) + (text . "\tab{32} ") + (bcStrings (4 1 irn1 PI)) + (text . "\tab{42} ") + (bcStrings (4 1 icn1 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a2 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn2 PI)) + (text . "\tab{42} ") + (bcStrings (4 2 icn2 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a3 F)) + (text . "\tab{32} ") + (bcStrings (4 3 irn3 PI)) + (text . "\tab{42} ") + (bcStrings (4 3 icn3 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a4 F)) + (text . "\tab{32} ") + (bcStrings (4 4 irn4 PI)) + (text . "\tab{42} ") + (bcStrings (4 4 icn4 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a5 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn5 PI)) + (text . "\tab{42} ") + (bcStrings (4 5 icn5 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a6 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn6 PI)) + (text . "\tab{42} ") + (bcStrings (4 6 icn6 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a7 F)) + (text . "\tab{32} ") + (bcStrings (4 7 irn7 PI)) + (text . "\tab{42} ") + (bcStrings (4 7 icn7 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a8 F)) + (text . "\tab{32} ") + (bcStrings (4 8 irn8 PI)) + (text . "\tab{42} ") + (bcStrings (4 8 icn8 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a9 F)) + (text . "\tab{32} ") + (bcStrings (4 9 irn9 PI)) + (text . "\tab{42} ") + (bcStrings (4 9 icn9 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a10 F)) + (text . "\tab{32} ") + (bcStrings (4 10 irn10 PI)) + (text . "\tab{42} ") + (bcStrings (4 10 icn10 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a11 F)) + (text . "\tab{32} ") + (bcStrings (4 11 irn11 PI)) + (text . "\tab{42} ") + (bcStrings (4 11 icn11 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a12 F)) + (text . "\tab{32} ") + (bcStrings (4 12 irn12 PI)) + (text . "\tab{42} ") + (bcStrings (4 12 icn12 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a13 F)) + (text . "\tab{32} ") + (bcStrings (4 13 irn13 PI)) + (text . "\tab{42} ") + (bcStrings (4 13 icn13 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a14 F)) + (text . "\tab{32} ") + (bcStrings (4 14 irn14 PI)) + (text . "\tab{42} ") + (bcStrings (4 14 icn14 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a15 F)) + (text . "\tab{32} ") + (bcStrings (4 15 irn15 PI)) + (text . "\tab{42} ") + (bcStrings (4 15 icn15 PI)) + (text . "\blankline ") + (text . "\newline \tab{2}") + (bcStrings (8 "1.0" a16 F)) + (text . "\tab{32} ") + (bcStrings (4 16 irn16 PI)) + (text . "\tab{42} ") + (bcStrings (4 16 icn16 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a17 F)) + (text . "\tab{32} ") + (bcStrings (4 1 irn17 PI)) + (text . "\tab{42} ") + (bcStrings (4 2 icn17 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a18 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn18 PI)) + (text . "\tab{42} ") + (bcStrings (4 3 icn18 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a19 F)) + (text . "\tab{32} ") + (bcStrings (4 3 irn19 PI)) + (text . "\tab{42} ") + (bcStrings (4 4 icn19 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a20 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn20 PI)) + (text . "\tab{42} ") + (bcStrings (4 6 icn20 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a21 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn21 PI)) + (text . "\tab{42} ") + (bcStrings (4 7 icn21 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a22 F)) + (text . "\tab{32} ") + (bcStrings (4 7 irn22 PI)) + (text . "\tab{42} ") + (bcStrings (4 8 icn22 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a23 F)) + (text . "\tab{32} ") + (bcStrings (4 9 irn23 PI)) + (text . "\tab{42} ") + (bcStrings (4 10 icn23 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a24 F)) + (text . "\tab{32} ") + (bcStrings (4 10 irn24 PI)) + (text . "\tab{42} ") + (bcStrings (4 11 icn24 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a25 F)) + (text . "\tab{32} ") + (bcStrings (4 11 irn25 PI)) + (text . "\tab{42} ") + (bcStrings (4 12 icn25 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a26 F)) + (text . "\tab{32} ") + (bcStrings (4 13 irn26 PI)) + (text . "\tab{42} ") + (bcStrings (4 14 icn26 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a27 F)) + (text . "\tab{32} ") + (bcStrings (4 14 irn27 PI)) + (text . "\tab{42} ") + (bcStrings (4 15 icn27 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a28 F)) + (text . "\tab{32} ") + (bcStrings (4 15 irn28 PI)) + (text . "\tab{42} ") + (bcStrings (4 16 icn28 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a29 F)) + (text . "\tab{32} ") + (bcStrings (4 1 irn29 PI)) + (text . "\tab{42} ") + (bcStrings (4 5 icn29 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a30 F)) + (text . "\tab{32} ") + (bcStrings (4 2 irn30 PI)) + (text . "\tab{42} ") + (bcStrings (4 6 icn30 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a31 F)) + (text . "\tab{32} ") + (bcStrings (4 3 irn31 PI)) + (text . "\tab{42} ") + (bcStrings (4 7 icn31 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a32 F)) + (text . "\tab{32} ") + (bcStrings (4 4 irn32 PI)) + (text . "\tab{42} ") + (bcStrings (4 8 icn32 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a33 F)) + (text . "\tab{32} ") + (bcStrings (4 5 irn33 PI)) + (text . "\tab{42} ") + (bcStrings (4 9 icn33 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a34 F)) + (text . "\tab{32} ") + (bcStrings (4 6 irn34 PI)) + (text . "\tab{42} ") + (bcStrings (4 10 icn34 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a35 F)) + (text . "\tab{32} ") + (bcStrings (4 7 irn35 PI)) + (text . "\tab{42} ") + (bcStrings (4 11 icn35 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a36 F)) + (text . "\tab{32} ") + (bcStrings (4 8 irn36 PI)) + (text . "\tab{42} ") + (bcStrings (4 12 icn36 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a37 F)) + (text . "\tab{32} ") + (bcStrings (4 9 irn37 PI)) + (text . "\tab{42} ") + (bcStrings (4 13 icn37 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a38 F)) + (text . "\tab{32} ") + (bcStrings (4 10 irn38 PI)) + (text . "\tab{42} ") + (bcStrings (4 14 icn38 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a39 F)) + (text . "\tab{32} ") + (bcStrings (4 11 irn39 PI)) + (text . "\tab{42} ") + (bcStrings (4 15 icn39 PI)) + (text . "\newline \tab{2}") + (bcStrings (8 "-0.25" a40 F)) + (text . "\tab{32} ") + (bcStrings (4 12 irn40 PI)) + (text . "\tab{42} ") + (bcStrings (4 16 icn40 PI)) + (text . "\blankline ") + (text . "\menuitemstyle{} \tab{2} Abort :") + (bcStrings (8 "true" abort_one EM)) + (bcStrings (8 "true" abort_two EM)) + (bcStrings (8 "true" abort_three EM))) + htMakeDoneButton('"Continue",'f01mafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nz,nz) + htpSetProperty(page,'licn,licn) + htpSetProperty(page,'lirn,lirn) + htpSetProperty(page,'droptl,droptl) + htpSetProperty(page,'densw,densw) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01mafGen htPage == + n := htpProperty(htPage,'n) + nz := htpProperty(htPage,'nz) + licn := htpProperty(htPage,'licn) + lirn := htpProperty(htPage,'lirn) + droptl := htpProperty(htPage,'droptl) + densw := htpProperty(htPage,'densw) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..3 repeat + abort := STRCONC((first y).1," ") + y := rest y + abortList := [abort,:abortList] + astring := bcwords2liststring abortList + while y repeat + end := STRCONC ((first y).1," ") + y := rest y + mid := STRCONC ((first y).1," ") + y := rest y + top := STRCONC ((first y).1," ") + y := rest y + cList := [end,:cList] + rList := [mid,:rList] + matList := [top,:matList] + for i in 1..(licn-nz) repeat + cList := [:cList,'"0 "] + matList := [:matList,'"0 "] + for i in 1..(lirn-nz) repeat + rList := [:rList,'"0 "] + cstring := bcwords2liststring cList + rstring := bcwords2liststring rList + matstring := bcwords2liststring matList + prefix := STRCONC('"f01maf(",STRINGIMAGE n,", ",STRINGIMAGE nz,", ") + prefix := STRCONC(prefix,STRINGIMAGE licn,", ",STRINGIMAGE lirn,", ") + prefix := STRCONC(prefix,astring,",[",matstring) + prefix := STRCONC(prefix,"],[",rstring,"],[",cstring,"], ",droptl,", ",densw) + linkGen STRCONC(prefix,", ",STRINGIMAGE ifail,")") + + + + +f01mcf() == + htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf01mcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01mcf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the Cholesky factorization of a real symmetric positive") + (text . "-definite variable-bandwidth matrix {\it A} or order {\it n}. ") + (text . "That is, {\it A = }\htbitmap{ldlt}, where {\it L} is ") + (text . "a unit lower triangular matrix and {\it D} is a diagonal matrix.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the order {\em n} of the matrix A ") + (text . "\htbitmap{great=} 1:") + (text . "\newline\tab{2} ") + (bcStrings (9 6 n PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Enter the number of elements: ") + (text . "\newline\tab{2} ") + (bcStrings (9 14 lal PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01mcfSolve) + htShowPage() + +f01mcfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lal := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lal) + objValUnwrap htpLabelSpadValue(htPage, 'lal) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and lal = '14) => f01mcfDefaultSolve(htPage,ifail) + labelList := + "append"/[f(i) for i in 1..lal] where f(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[6, 0.0, xnam, 'F]]] + nrowList := + "append"/[g(j) for j in 1..n] where g(j) == + nam := INTERN STRCONC ('"n",STRINGIMAGE j) + [['bcStrings,[6, 0, nam, 'PI]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it NROW(n)} the width ") + prefix := STRCONC(prefix,"of the ith row of A: \newline \tab{2} ") + nrowList := [['text,:prefix],:nrowList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:nrowList] + page := htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) + htSay '"\menuitemstyle{}\tab{2} Elements of matrix {\it A} in row by row " + htSay '"order: \newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01mcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'lal,lal) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01mcfDefaultSolve (htPage,ifail) == + n := '6 + lal := '14 + page := htInitPage("F01MCF - \htbitmap{ldlt} factorization of real symmetric positive-definite variable-bandwidth matrix",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Elements of matrix {\it A} in row by ") + (text . "row order: ") + (text . "\newline ") + (bcStrings (6 "1.0" x1 F)) + (bcStrings (6 "2.0" x2 F)) + (bcStrings (6 "5.0" x3 F)) + (bcStrings (6 "3.0" x4 F)) + (bcStrings (6 "13.0" x5 F)) + (bcStrings (6 "16.0" x6 F)) + (bcStrings (6 "5.0" x7 F)) + (bcStrings (6 "14.0" x8 F)) + (bcStrings (6 "18.0" x9 F)) + (bcStrings (6 "8.0" x10 F)) + (bcStrings (6 "55.0" x11 F)) + (bcStrings (6 "24.0" x12 F)) + (bcStrings (6 "17.0" x13 F)) + (bcStrings (6 "77.0" x14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it NROW(n)} the width of the ith row ") + (text . "of A: ") + (text . "\newline ") + (bcStrings (6 1 n1 PI)) + (bcStrings (6 2 n2 PI)) + (bcStrings (6 2 n3 PI)) + (bcStrings (6 1 n4 PI)) + (bcStrings (6 5 n5 PI)) + (bcStrings (6 3 n6 PI)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01mcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'lal,lal) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01mcfGen htPage == + n := htpProperty(htPage,'n) + lal := htpProperty(htPage,'lal) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + right := STRCONC ((first y).1," ") + y := rest y + nrowList := [right,:nrowList] + nrowstring := bcwords2liststring nrowList + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + matList := [right,:matList] + matstring := bcwords2liststring matList + prefix := STRCONC('"f01mcf(",STRINGIMAGE n,", [",matstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE lal,", [",nrowstring,"], ") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + + +f01qcf() == + htInitPage('"F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01qcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qcf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Finds the QR factorization of a real {\it m} by {it n} ({\it m ") + (text . "\htbitmap{great=} n}) matrix {\it A}, which ") + (text . "is factorized as \htbitmap{f01qcf}, ") + (text . "where {\it m > n} and {\it A = QR } when {\it m = n }, where ") + (text . "{\it Q} is an {\it m} by {\it m } orthogonal matrix and {\it R} ") + (text . "is an {\it n} by {\it n} upper triangular matrix. The {\it k}th ") + (text . "transformation matrix,{\it Qk}, ") + (text . "which is used to introduce zeros into the {\it k}th column of ") + (text . "{\it A}, is given in the form ") + (text . "\htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01qcf2}, ") + (text . "\htbitmap{f01qcf3}, ") + (text . "\htbitmap{zetak} is a scalar and ") + (text . "\htbitmap{zk} is an (m-k) element vector. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01qcfSolve) + htShowPage() + +f01qcfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '5 and n = '3) => f01qcfDefaultSolve(htPage,lda,ifail) + matList := + "append"/[f(i,n) for i in 1..lda] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage("F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01qcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01qcfDefaultSolve (htPage,lda,ifail) == + n := '3 + m := '5 + page := htInitPage('"F01QCF - QR factorization or real m by n matrix (m \htbitmap{great=} n)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a11 F)) + (bcStrings (6 "2.5" a12 F)) + (bcStrings (6 "2.5" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a21 F)) + (bcStrings (6 "2.5" a22 F)) + (bcStrings (6 "2.5" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.6" a31 F)) + (bcStrings (6 "-0.4" a32 F)) + (bcStrings (6 "2.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a41 F)) + (bcStrings (6 "-0.5" a42 F)) + (bcStrings (6 "0.5" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.2" a51 F)) + (bcStrings (6 "-0.3" a52 F)) + (bcStrings (6 "-2.9" a53 F))) + htMakeDoneButton('"Continue",'f01qcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01qcfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) + lda := m + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f01qcf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",matstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f01qdf() == + htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01qdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qdf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Performs one of the transformations {\it B = QB or B = }") + (text . "\htbitmap{f01qdf}, where {\it B} is a real {\it m} ") + (text . "by {\it ncolb} matrix and {\it Q} is an {\it m} by {\it m} ") + (text . "orthogonal matrix assumed to be given by {\it Q = }") + (text . "\htbitmap{f01qdf1}, \htbitmap{f01qdf2} ") + (text . "being given in the form ") + (text . "\htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01qcf2}, ") + (text . "\htbitmap{f01qcf3}, ") + (text . "\htbitmap{zetak} is a scalar and ") + (text . "\htbitmap{zk} is an (m-k) element vector. ") + (text . "The routine is intended for use following F01QCF or F01QFF. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of B, {\it ldb} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 5 ldb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Number of columns of matrix B {\it ncolb}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 2 ncolb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Transformation to be performed: ") + (radioButtons trans + (" " " {\it B = QB}" no_trans) + (" " " {\it B =} \htbitmap{f01qdf}" trans)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Where the elements can be found: ") + (radioButtons wheret + (" " " the elements of \zeta are in A" in_a) + (" " " the elements of \zeta are in ZETA, returned by F01QCF/F01QFF" seperate)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01qdfSolve) + htShowPage() + +f01qdfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + ncolb := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) + objValUnwrap htpLabelSpadValue(htPage, 'ncolb) + operation := htpButtonValue(htPage,'trans) + trans := + operation = 'no_trans => '"n" + '"t" + elements := htpButtonValue(htPage,'wheret) + wheret := + elements = 'in_a => '"i" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolb = '2) => f01qdfDefaultSolve(htPage,lda,ldb,trans,wheret,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bList := + "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == + labelList := + "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") + bList := [['text,:prefix],:bList] + zList := + "append"/[fz(i) for i in 1..n] where fz(i) == + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + [['bcStrings,[6, "0.0", znam, 'F]]] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \zeta ") + prefix := STRCONC(prefix,"(if required): \newline \tab{2}") + zList := [['text,:prefix],:zList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bList,:zList] + page := htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01qdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01qdfDefaultSolve (htPage,lda,ldb,trans,wheret,ifail) == + n := '3 + m := '5 + ncolb := '2 + page := htInitPage('"F01QDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01qdf} after factorization by F01QCF or F01QDF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a11 F)) + (bcStrings (6 "2.5" a12 F)) + (bcStrings (6 "2.5" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a21 F)) + (bcStrings (6 "2.5" a22 F)) + (bcStrings (6 "2.5" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.6" a31 F)) + (bcStrings (6 "-0.4" a32 F)) + (bcStrings (6 "2.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a41 F)) + (bcStrings (6 "-0.5" a42 F)) + (bcStrings (6 "0.5" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.2" a51 F)) + (bcStrings (6 "-0.3" a52 F)) + (bcStrings (6 "-2.9" a53 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.1" b11 F)) + (bcStrings (6 "0.0" b12 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.9" b21 F)) + (bcStrings (6 "0.0" b22 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.6" b31 F)) + (bcStrings (6 "1.32" b32 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b41 F)) + (bcStrings (6 "1.1" b42 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-0.8" b51 F)) + (bcStrings (6 "-0.26" b52 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \zeta (if required): ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" z1 F)) + (bcStrings (10 "0.0" z2 F)) + (bcStrings (10 "0.0" z3 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01qdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01qdfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) +-- ldb := htpProperty(htPage,'ldb) + lda := m + ldb := m + ncolb := htpProperty(htPage,'ncolb) + trans := htpProperty(htPage,'trans) + wheret := htpProperty(htPage,'wheret) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + left := STRCONC((first y).1," ") + y := rest y + zetalist := [left,:zetalist] + zetastring := bcwords2liststring zetalist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + for i in 1..ldb repeat + for j in 1..ncolb repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f01qdf(_"",trans,"_",_"",wheret,"_",",STRINGIMAGE m,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",STRINGIMAGE lda) + prefix := STRCONC(prefix,",[",zetastring,"],",STRINGIMAGE ncolb,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + + +f01qef() == + htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01qef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01qef| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns the first {\it ncolq} columns of the real {\it m} by ") + (text . "{\it n} orthogonal matrix {\it Q}, where {\it Q} is assumed ") + (text . "to be given by {\it Q = }\htbitmap{f01qdf1}, ") + (text . "\htbitmap{f01qdf2} being given in the form ") + (text . "\htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01qcf2}, ") + (text . "\htbitmap{f01qcf3}, ") + (text . "\htbitmap{zetak} is a scalar and ") + (text . "\htbitmap{zk} is an (m-k) element vector. ") + (text . "The routine is intended for use following F01QCF or F01QFF. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Number columns of matrix Q {\it ncolq}: ") + (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) +-- (text . "\tab{34} ") + (bcStrings (6 5 ncolq PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Where the elements can be found: ") + (radioButtons wheret + (" " " the elements of \zeta are in ZETA, returned by F01QCF/F01QFF" subsequent) + (" " " the elements of \zeta are in A" initial)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01qefSolve) + htShowPage() + +f01qefSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ncolq := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolq) + objValUnwrap htpLabelSpadValue(htPage, 'ncolq) + elements := htpButtonValue(htPage,'wheret) + wheret := + elements = 'initial => '"i" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolq = '5) => f01qefDefaultSolve(htPage,lda,wheret,ifail) + matList := + "append"/[fa(i,ncolq) for i in 1..lda] where fa(i,ncolq) == + labelList := + "append"/[ga(i,j) for j in 1..ncolq] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[7, "0.0", anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + zList := + "append"/[fz(i) for i in 1..n] where fz(i) == + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + [['bcStrings,[7, "0.0", znam, 'F]]] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \zeta ") + prefix := STRCONC(prefix,"(if required): \newline ") + zList := [['text,:prefix],:zList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:zList] + page := htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it Q}: " + htSay '"\newline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01qefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ncolq,ncolq) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01qefDefaultSolve (htPage,lda,wheret,ifail) == + n := '3 + m := '5 + ncolq := '5 + page := htInitPage('"F01QEF - Operations with orthogonal matrices, form columns of {\it Q} after factorization by F01QCF or F01QFF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it Q}") + (text . "(in this case returned by the default entries of F01QCF) : ") + (text . "\newline ") + (bcStrings (7 "-4.0" a11 F)) + (bcStrings (7 "-2.0" a12 F)) + (bcStrings (7 "-3.0" a13 F)) + (bcStrings (7 "0.0" a14 F)) + (bcStrings (7 "0.0" a15 F)) + (text . "\newline ") + (bcStrings (7 "0.4085" a21 F)) + (bcStrings (7 "-3.0" a22 F)) + (bcStrings (7 "-2.0" a23 F)) + (bcStrings (7 "0.0" a24 F)) + (bcStrings (7 "0.0" a25 F)) + (text . "\newline ") + (bcStrings (7 "0.3266" a31 F)) + (bcStrings (7 "-0.4619" a32 F)) + (bcStrings (7 "-4.0" a33 F)) + (bcStrings (7 "0.0" a34 F)) + (bcStrings (7 "0.0" a35 F)) + (text . "\newline ") + (bcStrings (7 "0.4082" a41 F)) + (bcStrings (7 "-0.5774" a42 F)) + (bcStrings (7 "0.0" a43 F)) + (bcStrings (7 "0.0" a44 F)) + (bcStrings (7 "0.0" a45 F)) + (text . "\newline ") + (bcStrings (7 "0.2449" a51 F)) + (bcStrings (7 "-0.3464" a52 F)) + (bcStrings (7 "-0.6326" a53 F)) + (bcStrings (7 "0.0" a54 F)) + (bcStrings (7 "0.0" a55 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \zeta: ") + (text . "\newline ") + (bcStrings (10 "1.2247" z1 F)) + (bcStrings (10 "1.1547" z2 F)) + (bcStrings (10 "1.2649" z3 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01qefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ncolq,ncolq) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01qefGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) + lda := m + ncolq := htpProperty(htPage,'ncolq) + wheret := htpProperty(htPage,'wheret) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + left := STRCONC((first y).1," ") + y := rest y + zetalist := [left,:zetalist] + zetastring := bcwords2liststring zetalist + y := REVERSE y + for i in 1..lda repeat + for j in 1..ncolq repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f01qef(_"",wheret,"_",",STRINGIMAGE m,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE lda,", ") + prefix := STRCONC(prefix,STRINGIMAGE ncolq,",[",zetastring,"],") + prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + +f01rcf() == + htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01rcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01rcf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Finds the QR factorization of the complex m by n matrix {\it A},") + (text . " which is factorized as \htbitmap{f01qcf}, where m > n") + (text . " and A = QR when m = n , where Q is an m by m unitary matrix ") + (text . "and R is an n by n upper triangular matrix with real diagonal ") + (text . "elements. The {\it k}th transformation matrix,{\it Qk}, ") + (text . "which is used to introduce zeros into the {\it k}th column of ") + (text . "{\it A}, is given in the form ") + (text . "\htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01rdf2}, ") + (text . "\htbitmap{f01qcf3}, ") + (text . "\htbitmap{gammak} is a scalar for which Re ") + (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") + (text . "is a real scalar and \htbitmap{zk} is an ") + (text . "(m-k) element vector. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01rcfSolve) + htShowPage() + +f01rcfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '5 and n = '3) => f01rcfDefaultSolve(htPage,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[16, "0.0 + 0.0*%i", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01rcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01rcfDefaultSolve (htPage,ifail) == + n := '3 + m := '5 + lda := '5 + page := htInitPage('"F01RCF - {\it QR} factorization of complex {\it m} by {\it n} matrix (m \htbitmap{great=} n)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (15 "0.5*%i" a11 F)) + (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) + (bcStrings (15 "-1.0 + 1.0*%i" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4 + 0.3*%i" a21 F)) + (bcStrings (15 "0.9 + 1.3*%i" a22 F)) + (bcStrings (15 "0.2 + 1.4*%i" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4" a31 F)) + (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) + (bcStrings (15 "1.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.3 - 0.4*%i" a41 F)) + (bcStrings (15 "0.1 + 0.7*%i" a42 F)) + (bcStrings (15 "0.0" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "-0.3*%i" a51 F)) + (bcStrings (15 "0.3 + 0.3*%i" a52 F)) + (bcStrings (15 "2.4*%i" a53 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01rcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01rcfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) + lda := m + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f01rcf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",matstring) + linkGen STRCONC(prefix,", ",STRINGIMAGE ifail,")") + +f01rdf() == + htInitPage('"F01RDF - Operations with unitary matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01rdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01rdf| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Performs one of the transformations B = QB or B = ") + (text . "\htbitmap{f01rdf}, where B is an m ") + (text . "by ncolb matrix and Q is an m by m ") + (text . "unitary matrix assumed to be given by Q = ") + (text . "\htbitmap{f01rdf1}, \htbitmap{f01qdf2} ") + (text . "being given in the form \htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01rdf2}, \htbitmap{f01qcf3}") + (text . ", \htbitmap{gammak} is a scalar for which Re ") + (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") + (text . "is a real scalar and \htbitmap{zk} is an ") + (text . "(m-k) element vector. ") + (text . "The routine is intended for use following F01QCF or F01QFF. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of B, {\it ldb} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 5 ldb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Number of columns of matrix B {\it ncolb}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 2 ncolb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Transformation to be performed: ") + (radioButtons trans + (" " " {\it B = QB}" no_trans) + (" " " {\it B =} \htbitmap{f01rdf} (Conjugate Transpose)" trans)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Where the elements can be found: ") + (radioButtons wheret + (" " " the elements of \theta are in A" in_a) + (" " " the elements of \theta are in THETA" seperate)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01rdfSolve) + htShowPage() + +f01rdfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + ncolb := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) + objValUnwrap htpLabelSpadValue(htPage, 'ncolb) + operation := htpButtonValue(htPage,'trans) + trans := + operation = 'no_trans => '"n" + '"c" + elements := htpButtonValue(htPage,'wheret) + wheret := + elements = 'in_a => '"i" + '"c" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolb = '2) => f01rdfDefaultSolve(htPage,lda,ldb,trans,wheret,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[16, "0.0 + 0.0*%i", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bList := + "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == + labelList := + "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[16, "0.0 + 0.0*%i", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") + bList := [['text,:prefix],:bList] + zList := + "append"/[fz(i) for i in 1..n] where fz(i) == + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + [['bcStrings,[16, "0.0", znam, 'F]]] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \theta ") + prefix := STRCONC(prefix,"(if required): \newline \tab{2}") + zList := [['text,:prefix],:zList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bList,:zList] + page := htInitPage('"F01RDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF or F01RDF",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01rdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01rdfDefaultSolve (htPage,lda,ldb,trans,wheret,ifail) == + n := '3 + m := '5 + ncolb := '2 + page := htInitPage('"F01RDF - Operations with orthogonal matrices, compute {\it QB} or \htbitmap{f01rdf} after factorization by F01QCF or F01RDF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (15 "0.5*%i" a11 F)) + (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) + (bcStrings (15 "-1.0 + 1.0*%i" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4 + 0.3*%i" a21 F)) + (bcStrings (15 "0.9 + 1.3*%i" a22 F)) + (bcStrings (15 "0.2 + 1.4*%i" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4" a31 F)) + (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) + (bcStrings (15 "1.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.3 - 0.4*%i" a41 F)) + (bcStrings (15 "0.1 + 0.7*%i" a42 F)) + (bcStrings (15 "0.0" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "-0.3*%i" a51 F)) + (bcStrings (15 "0.3 + 0.3*%i" a52 F)) + (bcStrings (15 "2.4" a53 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (15 "-0.55 + 1.05*%i" b11 F)) + (bcStrings (15 "0.45 + 1.05*%i" b12 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.49 + 0.93*%i" b21 F)) + (bcStrings (15 "1.09 + 0.13*%i" b22 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.56 - 0.16*%i" b31 F)) + (bcStrings (15 "0.64 + 0.16*%i" b32 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.39 + 0.23*%i" b41 F)) + (bcStrings (15 "-0.39 - 0.23*%i" b42 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "1.13 + 0.83*%i" b51 F)) + (bcStrings (15 "-1.13 + 0.77*%i" b52 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \theta (if required): ") + (text . "\newline \tab{2} ") + (bcStrings (15 "0.0" z1 F)) + (bcStrings (15 "0.0" z2 F)) + (bcStrings (15 "0.0" z3 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01rdfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01rdfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) +-- ldb := htpProperty(htPage,'ldb) + lda := m + ldb := m + ncolb := htpProperty(htPage,'ncolb) + trans := htpProperty(htPage,'trans) + wheret := htpProperty(htPage,'wheret) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + left := STRCONC((first y).1," ") + y := rest y + zetalist := [left,:zetalist] + zetastring := bcwords2liststring zetalist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + for i in 1..ldb repeat + for j in 1..ncolb repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f01rdf(_"",trans,"_",_"",wheret,"_",",STRINGIMAGE m,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",STRINGIMAGE lda) + prefix := STRCONC(prefix,",[",zetastring,"],",STRINGIMAGE ncolb,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + + +f01ref() == + htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf01ref} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f01ref| '|NagMatrixOperationsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns the first {\it ncolq} columns of the real {\it m} by ") + (text . "{\it m} unitary matrix {\it Q}, where {\it Q} is assumed ") + (text . "to be given by {\it Q = }\htbitmap{f01rdf1}, ") + (text . "\htbitmap{f01qdf2} being given in the form ") + (text . "\htbitmap{f01qcf1}, ") + (text . "where \htbitmap{f01rdf2}, ") + (text . "\htbitmap{f01qcf3}, ") + (text . "\htbitmap{gammak} is a scalar for which Re ") + (text . "\htbitmap{gammak} = 1.0, \htbitmap{zetak} ") + (text . "is a real scalar and \htbitmap{zk} is an ") + (text . "(m-k) element vector. ") + (text . "The routine is intended for use following F01RCF or F01RFF. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda} ") +-- (text . "\htbitmap{great=} m: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Required number of columns of matrix Q {\it ncolq}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 2 ncolq PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Where the elements can be found: ") + (radioButtons wheret + (" " " the elements of \theta are in THETA" seperate) + (" " " the elements of \theta are in A" in_a)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f01refSolve) + htShowPage() + +f01refSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ncolq := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolq) + objValUnwrap htpLabelSpadValue(htPage, 'ncolq) + elements := htpButtonValue(htPage,'wheret) + wheret := + elements = 'in_a => '"i" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolq = '2) => f01refDefaultSolve(htPage,lda,wheret,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[20, "0.0 + 0.0*%i", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + zList := + "append"/[fz(i) for i in 1..n] where fz(i) == + znam := INTERN STRCONC ('"z",STRINGIMAGE i) + [['bcStrings,[20, "0.0", znam, 'F]]] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of \theta ") + prefix := STRCONC(prefix,"(if required): \newline \tab{2}") + zList := [['text,:prefix],:zList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:zList] + page := htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f01refGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ncolq,ncolq) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f01refDefaultSolve (htPage,lda,wheret,ifail) == + n := '3 + m := '5 + ncolq := '2 + page := htInitPage('"F01REF - Operations with unitary matrices, form columns of {\it Q} after factorization by F01RCF",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (16 "1" a11 F)) + (bcStrings (16 "1 + %i" a12 F)) + (bcStrings (16 "1 + %i" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (16 "-0.2-0.4*%i" a21 F)) + (bcStrings (16 "-2" a22 F)) + (bcStrings (16 "-1 - %i" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (16 "-0.32 - 0.16*%i" a31 F)) + (bcStrings (16 "-0.3505+0.263*%i" a32 F)) + (bcStrings (16 "-3" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (16 "-0.4 + 0.2*%i" a41 F)) + (bcStrings (16 "0.5477*%i" a42 F)) + (bcStrings (16 "0.0" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (16 "-0.12 + 0.24*%i" a51 F)) + (bcStrings (16 "0.1972+0.2629*%i" a52 F)) + (bcStrings (16 "0.6325" a53 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of \theta: ") + (text . "\newline \tab{2} ") + (bcStrings (16 "1 + 0.5*%i" z1 F)) + (bcStrings (16 "1.0954-0.3333*%i" z2 F)) + (bcStrings (16 "1.2649-1.1565*%i" z3 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f01refGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ncolq,ncolq) + htpSetProperty(page,'wheret,wheret) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f01refGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- lda := htpProperty(htPage,'lda) + lda := m + ncolq := htpProperty(htPage,'ncolq) + wheret := htpProperty(htPage,'wheret) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + left := STRCONC((first y).1," ") + y := rest y + thetalist := [left,:thetalist] + thetastring := bcwords2liststring thetalist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f01ref(_"",wheret,"_",",STRINGIMAGE m,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE ncolq,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,",[",thetastring,"],") + prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-f02.boot b/src/interp/nag-f02.boot deleted file mode 100644 index d532b389..00000000 --- a/src/interp/nag-f02.boot +++ /dev/null @@ -1,2733 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -f02aaf() == - htInitPage('"F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02aaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aaf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues of a real symmetric matrix ") - (text . "{\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02aafSolve) - htShowPage() - -f02aafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02aafDefaultSolve(htPage,ia,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage("F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02aafGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02aafDefaultSolve (htPage,ia,ifail) == - n := '4 - page := htInitPage('"F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "2.3" a13 F)) - (bcStrings (6 "-2.6" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "0.5" a22 F)) - (bcStrings (6 "-1.4" a23 F)) - (bcStrings (6 "-0.7" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.3" a31 F)) - (bcStrings (6 "-1.4" a32 F)) - (bcStrings (6 "0.5" a33 F)) - (bcStrings (6 "0.0" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.6" a41 F)) - (bcStrings (6 "-0.7" a42 F)) - (bcStrings (6 "0.0" a43 F)) - (bcStrings (6 "0.5" a44 F))) - htMakeDoneButton('"Continue",'f02aafGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02aafGen htPage == - n := htpProperty(htPage,'n) - -- ia should be = n, unlike the example program - -- where ia = nmax --- ia := htpProperty(htPage,'ia) - ia := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f02aaf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - -f02abf() == - htInitPage('"F02ABF - All eigenvalues and eignevectors of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02abf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02abf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues and eigenvectors of a real ") - (text . "symmetric matrix ") - (text . "{\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of V, {\it v} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 v PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02abfSolve) - htShowPage() - -f02abfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - iv := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'v) --- objValUnwrap htpLabelSpadValue(htPage, 'v) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02abfDefaultSolve(htPage,ia,iv,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage("F02ABF - All eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02abfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02abfDefaultSolve (htPage,ia,iv,ifail) == - n := '4 - page := htInitPage('"F02ABF - All eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "2.3" a13 F)) - (bcStrings (6 "-2.6" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "0.5" a22 F)) - (bcStrings (6 "-1.4" a23 F)) - (bcStrings (6 "-0.7" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.3" a31 F)) - (bcStrings (6 "-1.4" a32 F)) - (bcStrings (6 "0.5" a33 F)) - (bcStrings (6 "0.0" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.6" a41 F)) - (bcStrings (6 "-0.7" a42 F)) - (bcStrings (6 "0.0" a43 F)) - (bcStrings (6 "0.5" a44 F))) - htMakeDoneButton('"Continue",'f02abfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02abfGen htPage == - n := htpProperty(htPage,'n) - -- ia should be = n, unlike the example program - -- where ia = nmax --- ia := htpProperty(htPage,'ia) --- iv := htpProperty(htPage,'iv) - ia := n - iv := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f02abf(",matstring,", ",STRINGIMAGE ia,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE iv,", ") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - -f02adf() == - htInitPage('"F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02adf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates all the eigenvalues of Ax = \lambda Bx, where ") - (text . "A and B are real symmetric matrices of order n and B is positive-definite ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrices A and B, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "\newline First dimension of B, {\it ib}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 ib F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02adfSolve) - htShowPage() - -f02adfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - ib := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) --- objValUnwrap htpLabelSpadValue(htPage, 'ib) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02adfDefaultSolve(htPage,ia,ib,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..ib] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02adfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02adfDefaultSolve (htPage,ia,ib,ifail) == - n := '4 - page := htInitPage('"F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "1.5" a12 F)) - (bcStrings (6 "6.6" a13 F)) - (bcStrings (6 "4.8" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" a21 F)) - (bcStrings (6 "6.5" a22 F)) - (bcStrings (6 "16.2" a23 F)) - (bcStrings (6 "8.6" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "6.6" a31 F)) - (bcStrings (6 "16.2" a32 F)) - (bcStrings (6 "37.6" a33 F)) - (bcStrings (6 "9.8" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "4.8" a41 F)) - (bcStrings (6 "8.6" a42 F)) - (bcStrings (6 "9.8" a43 F)) - (bcStrings (6 "-17.1" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 b11 F)) - (bcStrings (6 3 b12 F)) - (bcStrings (6 4 b13 F)) - (bcStrings (6 1 b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 3 b21 F)) - (bcStrings (6 13 b22 F)) - (bcStrings (6 16 b23 F)) - (bcStrings (6 11 b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 4 b31 F)) - (bcStrings (6 16 b32 F)) - (bcStrings (6 24 b33 F)) - (bcStrings (6 18 b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 1 b41 F)) - (bcStrings (6 11 b42 F)) - (bcStrings (6 18 b43 F)) - (bcStrings (6 27 b44 F))) - htMakeDoneButton('"Continue",'f02adfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02adfGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) --- ib := htpProperty(htPage,'ib) - ia := n - ib := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..ib repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02adf(",STRINGIMAGE ia,", ",STRINGIMAGE ib,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f02aef() == - htInitPage('"F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aef| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates all the eigenvalues and eigenvectors of Ax = ") - (text . "\lambda Bx, where A and B are real symmetric matrices of order ") - (text . "n and B is positive-definite ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrices A and B, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "\newline First dimension of B, {\it ib}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 ib F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of V, {\it iv}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 iv PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02aefSolve) - htShowPage() - -f02aefSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - ib := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) --- objValUnwrap htpLabelSpadValue(htPage, 'ib) - iv := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) --- objValUnwrap htpLabelSpadValue(htPage, 'iv) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02aefDefaultSolve(htPage,ia,ib,iv,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..ib] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02aefGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02aefDefaultSolve (htPage,ia,ib,iv,ifail) == - n := '4 - page := htInitPage('"F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "1.5" a12 F)) - (bcStrings (6 "6.6" a13 F)) - (bcStrings (6 "4.8" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" a21 F)) - (bcStrings (6 "6.5" a22 F)) - (bcStrings (6 "16.2" a23 F)) - (bcStrings (6 "8.6" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "6.6" a31 F)) - (bcStrings (6 "16.2" a32 F)) - (bcStrings (6 "37.6" a33 F)) - (bcStrings (6 "9.8" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "4.8" a41 F)) - (bcStrings (6 "8.6" a42 F)) - (bcStrings (6 "9.8" a43 F)) - (bcStrings (6 "-17.1" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 b11 F)) - (bcStrings (6 3 b12 F)) - (bcStrings (6 4 b13 F)) - (bcStrings (6 1 b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 3 b21 F)) - (bcStrings (6 13 b22 F)) - (bcStrings (6 16 b23 F)) - (bcStrings (6 11 b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 4 b31 F)) - (bcStrings (6 16 b32 F)) - (bcStrings (6 24 b33 F)) - (bcStrings (6 18 b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 1 b41 F)) - (bcStrings (6 11 b42 F)) - (bcStrings (6 18 b43 F)) - (bcStrings (6 27 b44 F))) - htMakeDoneButton('"Continue",'f02aefGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02aefGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) --- ib := htpProperty(htPage,'ib) --- iv := htpProperty(htPage,'iv) - ia := n - ib := n - iv := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..ib repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02aef(",STRINGIMAGE ia,", ",STRINGIMAGE ib,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE iv,", ") - prefix := STRCONC(prefix,matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - - -f02aff() == - htInitPage('"F02AFF - All eigenvalues of real matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02aff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aff| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues of a real unsymmetric matrix ") - (text . "{\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02affSolve) - htShowPage() - -f02affSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02affDefaultSolve(htPage,ia,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage("F02AFF - All eigenvalues of real matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02affGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02affDefaultSolve (htPage,ia,ifail) == - n := '4 - page := htInitPage('"F02AFF - All eigenvalues of real matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" a11 F)) - (bcStrings (6 "0.1" a12 F)) - (bcStrings (6 "4.5" a13 F)) - (bcStrings (6 "-1.5" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-22.5" a21 F)) - (bcStrings (6 "3.5" a22 F)) - (bcStrings (6 "12.5" a23 F)) - (bcStrings (6 "-2.5" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" a31 F)) - (bcStrings (6 "0.3" a32 F)) - (bcStrings (6 "4.5" a33 F)) - (bcStrings (6 "-2.5" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" a41 F)) - (bcStrings (6 "0.1" a42 F)) - (bcStrings (6 "4.5" a43 F)) - (bcStrings (6 "2.5" a44 F))) - htMakeDoneButton('"Continue",'f02affGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02affGen htPage == - n := htpProperty(htPage,'n) - -- ia should be = n, unlike the example program - -- where ia = nmax --- ia := htpProperty(htPage,'ia) - ia := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f02aff(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - -f02agf() == - htInitPage('"F02AGF - All eigenvalues and eignevectors of real matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02agf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02agf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues and eigenvectors of a real ") - (text . "unsymmetric matrix {\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of VR, {\it ivr} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 ivr PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of VI, {\it ivi} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ivi PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02agfSolve) - htShowPage() - -f02agfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - ivr := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) --- objValUnwrap htpLabelSpadValue(htPage, 'ivr) - ivi := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) --- objValUnwrap htpLabelSpadValue(htPage, 'ivi) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02agfDefaultSolve(htPage,ia,ivr,ivi,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage("F02AGF - All eigenvalues and eigenvectors of real matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02agfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02agfDefaultSolve (htPage,ia,ivr,ivi,ifail) == - n := '4 - page := htInitPage('"F02AGF - All eigenvalues and eigenvectors of real matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" a11 F)) - (bcStrings (6 "0.1" a12 F)) - (bcStrings (6 "4.5" a13 F)) - (bcStrings (6 "-1.5" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-22.5" a21 F)) - (bcStrings (6 "3.5" a22 F)) - (bcStrings (6 "12.5" a23 F)) - (bcStrings (6 "-2.5" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" a31 F)) - (bcStrings (6 "0.3" a32 F)) - (bcStrings (6 "4.5" a33 F)) - (bcStrings (6 "-2.5" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" a41 F)) - (bcStrings (6 "0.1" a42 F)) - (bcStrings (6 "4.5" a43 F)) - (bcStrings (6 "2.5" a44 F))) - htMakeDoneButton('"Continue",'f02agfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02agfGen htPage == - n := htpProperty(htPage,'n) - -- ia should be = n, unlike the example program - -- where ia = nmax --- ia := htpProperty(htPage,'ia) --- ivr := htpProperty(htPage,'ivr) --- ivi := htpProperty(htPage,'ivi) - ia := n - ivr := n - ivi := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f02agf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE ivr,", ",STRINGIMAGE ivi,", ") - linkGen STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") - -f02ajf() == - htInitPage('"F02AJF - All eigenvalues of complex matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02ajf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02ajf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates all the eigenvalues of a complex matrix {\it A} ") - (text . "of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing real parts, ") --- (text . " {\it iar}: \newline \tab{2} ") --- (bcStrings (6 4 iar PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing imaginary parts,") --- (text . " {\it iai}: \newline \tab{2} ") --- (bcStrings (6 4 iai F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02ajfSolve) - htShowPage() - -f02ajfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - iar := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) --- objValUnwrap htpLabelSpadValue(htPage, 'iar) - iai := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) --- objValUnwrap htpLabelSpadValue(htPage, 'iai) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02ajfDefaultSolve(htPage,iar,iai,ifail) - matList := - "append"/[f(i,n) for i in 1..iar] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..iai] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{}\tab{2}Enter imag values of {\it A}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02AJF - All eigenvalues of complex matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02ajfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02ajfDefaultSolve (htPage,iar,iai,ifail) == - n := '4 - page := htInitPage('"F02AJF - All eigenvalues of complex matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-21.0" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "13.6" a13 F)) - (bcStrings (6 "0.0" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "26.0" a22 F)) - (bcStrings (6 "7.5" a23 F)) - (bcStrings (6 "2.5" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.0" a31 F)) - (bcStrings (6 "1.68" a32 F)) - (bcStrings (6 "4.5" a33 F)) - (bcStrings (6 "1.5" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a41 F)) - (bcStrings (6 "-2.6" a42 F)) - (bcStrings (6 "-2.7" a43 F)) - (bcStrings (6 "2.5" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-5.0" b11 F)) - (bcStrings (6 "24.6" b12 F)) - (bcStrings (6 "10.2"b13 F)) - (bcStrings (6 "4.0" b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "22.5" b21 F)) - (bcStrings (6 "-5.0" b22 F)) - (bcStrings (6 "-10.0" b23 F)) - (bcStrings (6 "0.0" b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" b31 F)) - (bcStrings (6 "2.24" b32 F)) - (bcStrings (6 "-5.0" b33 F)) - (bcStrings (6 "2.0" b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" b41 F)) - (bcStrings (6 "0.0" b42 F)) - (bcStrings (6 "3.6" b43 F)) - (bcStrings (6 "-5.0" b44 F))) - htMakeDoneButton('"Continue",'f02ajfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02ajfGen htPage == - n := htpProperty(htPage,'n) --- iar := htpProperty(htPage,'iar) --- iai := htpProperty(htPage,'iai) - iar := n - iai := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..iar repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..iai repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02ajf(",STRINGIMAGE n,", ",STRINGIMAGE iar,", ") - prefix := STRCONC(prefix,STRINGIMAGE iai,", ",matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f02akf() == - htInitPage('"F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02akf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02akf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues and eigenvectors of a complex ") - (text . "matrix {\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing real parts, ") --- (text . " {\it iar}: \newline \tab{2} ") --- (bcStrings (6 4 iar PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing imaginary parts,") --- (text . " {\it iai}: \newline \tab{2} ") --- (bcStrings (6 4 iai F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} \newline ") --- (text . "First dimension of array of real parts of the eigenvectors, ") --- (text . " {\it ivr}: \newline \tab{2} ") --- (bcStrings (6 4 ivr PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} \newline ") --- (text . "First dimension of array of imaginary parts of the eigenvectors,") --- (text . " {\it ivi}: \newline \tab{2} ") --- (bcStrings (6 4 ivi PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02akfSolve) - htShowPage() - -f02akfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - iar := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) --- objValUnwrap htpLabelSpadValue(htPage, 'iar) - iai := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) --- objValUnwrap htpLabelSpadValue(htPage, 'iai) - ivr := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) --- objValUnwrap htpLabelSpadValue(htPage, 'ivr) - ivi := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) --- objValUnwrap htpLabelSpadValue(htPage, 'ivi) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02akfDefaultSolve(htPage,iar,iai,ivr,ivi,ifail) - matList := - "append"/[f(i,n) for i in 1..iar] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..iai] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{}\tab{2}Enter imag values of {\it A}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02akfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02akfDefaultSolve (htPage,iar,iai,ivr,ivi,ifail) == - n := '4 - page := htInitPage('"F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-21.0" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "13.6" a13 F)) - (bcStrings (6 "0.0" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "26.0" a22 F)) - (bcStrings (6 "7.5" a23 F)) - (bcStrings (6 "2.5" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.0" a31 F)) - (bcStrings (6 "1.68" a32 F)) - (bcStrings (6 "4.5" a33 F)) - (bcStrings (6 "1.5" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a41 F)) - (bcStrings (6 "-2.6" a42 F)) - (bcStrings (6 "-2.7" a43 F)) - (bcStrings (6 "2.5" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-5.0" b11 F)) - (bcStrings (6 "24.6" b12 F)) - (bcStrings (6 "10.2"b13 F)) - (bcStrings (6 "4.0" b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "22.5" b21 F)) - (bcStrings (6 "-5.0" b22 F)) - (bcStrings (6 "-10.0" b23 F)) - (bcStrings (6 "0.0" b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.5" b31 F)) - (bcStrings (6 "2.24" b32 F)) - (bcStrings (6 "-5.0" b33 F)) - (bcStrings (6 "2.0" b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.5" b41 F)) - (bcStrings (6 "0.0" b42 F)) - (bcStrings (6 "3.6" b43 F)) - (bcStrings (6 "-5.0" b44 F))) - htMakeDoneButton('"Continue",'f02akfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02akfGen htPage == - n := htpProperty(htPage,'n) --- iar := htpProperty(htPage,'iar) --- iai := htpProperty(htPage,'iai) --- ivr := htpProperty(htPage,'ivr) --- ivi := htpProperty(htPage,'ivi) - iar := n - iai := n - ivr := n - ivi := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..iar repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..iai repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02akf(",STRINGIMAGE iar,", ",STRINGIMAGE iai,", ") - prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE ivr,", ") - prefix := STRCONC(prefix,STRINGIMAGE ivi,", ",matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f02awf() == - htInitPage('"F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02awf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02awf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates all the eigenvalues of a complex Hermitian matrix ") - (text . "{\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of the complex Hermitian matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing real parts, ") --- (text . " {\it iar}: \newline \tab{2} ") --- (bcStrings (6 4 iar PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing imaginary parts,") --- (text . " {\it iai}: \newline \tab{2} ") --- (bcStrings (6 4 iai F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02awfSolve) - htShowPage() - -f02awfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - iar := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) --- objValUnwrap htpLabelSpadValue(htPage, 'iar) - iai := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) --- objValUnwrap htpLabelSpadValue(htPage, 'iai) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02awfDefaultSolve(htPage,iar,iai,ifail) - matList := - "append"/[f(i,n) for i in 1..iar] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..iai] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{}\tab{2}Enter imaginary values {\it AI}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it AR}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02awfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02awfDefaultSolve (htPage,iar,iai,ifail) == - n := '4 - page := htInitPage('"F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter real values {\it AR}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "1.84" a13 F)) - (bcStrings (6 "2.08" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "0.5" a22 F)) - (bcStrings (6 "1.12" a23 F)) - (bcStrings (6 "-0.56" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.84" a31 F)) - (bcStrings (6 "1.12" a32 F)) - (bcStrings (6 "0.5" a33 F)) - (bcStrings (6 "0.0" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.08" a41 F)) - (bcStrings (6 "-0.56" a42 F)) - (bcStrings (6 "0.0" a43 F)) - (bcStrings (6 "0.5" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter imaginary values {\it AI}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b11 F)) - (bcStrings (6 "0.0" b12 F)) - (bcStrings (6 "1.38" b13 F)) - (bcStrings (6 "-1.56" b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b21 F)) - (bcStrings (6 "0.0" b22 F)) - (bcStrings (6 "0.84" b23 F)) - (bcStrings (6 "0.42" b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-1.38" b31 F)) - (bcStrings (6 "-0.84" b32 F)) - (bcStrings (6 "0.0" b33 F)) - (bcStrings (6 "0.0" b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.56" b41 F)) - (bcStrings (6 "-0.42" b42 F)) - (bcStrings (6 "0.0" b43 F)) - (bcStrings (6 "0.0" b44 F))) - htMakeDoneButton('"Continue",'f02awfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02awfGen htPage == - n := htpProperty(htPage,'n) --- iar := htpProperty(htPage,'iar) --- iai := htpProperty(htPage,'iai) - iar := n - iai := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..iar repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..iai repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02awf(",STRINGIMAGE n,", ",STRINGIMAGE iar,", ") - prefix := STRCONC(prefix,STRINGIMAGE iai,", ",matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f02axf() == - htInitPage('"F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02axf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02axf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues and eigenvectors of a complex ") - (text . "Hermitian matrix {\it A} of order {\it n}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing real parts, ") --- (text . " {\it iar}: \newline \tab{2} ") --- (bcStrings (6 4 iar PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of array containing imaginary parts,") --- (text . " {\it iai}: \newline \tab{2} ") --- (bcStrings (6 4 iai F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} \newline ") --- (text . "First dimension of array of real parts of the eigenvectors, ") --- (text . " {\it ivr}: \newline \tab{2} ") --- (bcStrings (6 4 ivr PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} \newline ") --- (text . "First dimension of array of imaginary parts of the eigenvectors,") --- (text . " {\it ivi}: \newline \tab{2} ") --- (bcStrings (6 4 ivi PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02axfSolve) - htShowPage() - -f02axfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - iar := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) --- objValUnwrap htpLabelSpadValue(htPage, 'iar) - iai := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) --- objValUnwrap htpLabelSpadValue(htPage, 'iai) - ivr := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) --- objValUnwrap htpLabelSpadValue(htPage, 'ivr) - ivi := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) --- objValUnwrap htpLabelSpadValue(htPage, 'ivi) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02axfDefaultSolve(htPage,iar,iai,ivr,ivi,ifail) - matList := - "append"/[f(i,n) for i in 1..iar] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..iai] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{}\tab{2}Enter imaginary values of {\it A}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02axfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02axfDefaultSolve (htPage,iar,iai,ivr,ivi,ifail) == - n := '4 - page := htInitPage('"F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "1.84" a13 F)) - (bcStrings (6 "2.08" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "0.5" a22 F)) - (bcStrings (6 "1.12" a23 F)) - (bcStrings (6 "-0.56" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.84" a31 F)) - (bcStrings (6 "1.12" a32 F)) - (bcStrings (6 "0.5" a33 F)) - (bcStrings (6 "0.0" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.08" a41 F)) - (bcStrings (6 "-0.56" a42 F)) - (bcStrings (6 "0.0" a43 F)) - (bcStrings (6 "0.5" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b11 F)) - (bcStrings (6 "0.0" b12 F)) - (bcStrings (6 "1.38" b13 F)) - (bcStrings (6 "-1.56" b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b21 F)) - (bcStrings (6 "0.0" b22 F)) - (bcStrings (6 "0.84" b23 F)) - (bcStrings (6 "0.42" b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-1.38" b31 F)) - (bcStrings (6 "-0.84" b32 F)) - (bcStrings (6 "0.0" b33 F)) - (bcStrings (6 "0.0" b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.56" b41 F)) - (bcStrings (6 "-0.42" b42 F)) - (bcStrings (6 "0.0" b43 F)) - (bcStrings (6 "0.0" b44 F))) - htMakeDoneButton('"Continue",'f02axfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'iar,iar) --- htpSetProperty(page,'iai,iai) --- htpSetProperty(page,'ivr,ivr) --- htpSetProperty(page,'ivi,ivi) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02axfGen htPage == - n := htpProperty(htPage,'n) --- iar := htpProperty(htPage,'iar) --- iai := htpProperty(htPage,'iai) --- ivr := htpProperty(htPage,'ivr) --- ivi := htpProperty(htPage,'ivi) - iar := n - iai := n - ivr := n - ivi := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..iar repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..iai repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02axf(",matstring,", ",STRINGIMAGE iar,", ",bstring) - prefix := STRCONC(prefix,", ",STRINGIMAGE iai,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE ivr,", ",STRINGIMAGE ivi,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - -f02bbf() == - htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02bbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02bbf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates selected eigenvalues and eigenvectors of a real ") - (text . "symmetric matrix {\it A} of order {\it n} by reduction to ") - (text . "tridiagonal form, bisection and inverse iteration, where the ") - (text . "selected eigenvalues lie within a given interval [{\it l,u}].") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrix A, {\it n}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Max number of eigenvectors, {\it m}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) - (text . "\tab{34} ") - (bcStrings (6 3 m PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Lower end-point of interval {\it l}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Upper end-point of interval {\it u}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.0" alb F)) - (text . "\tab{34} ") - (bcStrings (6 "3.0" ub F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of V, {\it v} ") --- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 iv PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02bbfSolve) - htShowPage() - -f02bbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - alb := htpLabelInputString(htPage,'alb) - ub := htpLabelInputString(htPage,'ub) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - iv := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) --- objValUnwrap htpLabelSpadValue(htPage, 'iv) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02bbfDefaultSolve(htPage,m,alb,ub,ia,iv,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList] - page := htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02bbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'alb,alb) - htpSetProperty(page,'ub,ub) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02bbfDefaultSolve (htPage,m,alb,ub,ia,iv,ifail) == - n := '4 - page := htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.5" a11 F)) - (bcStrings (6 "0.0" a12 F)) - (bcStrings (6 "2.3" a13 F)) - (bcStrings (6 "-2.6" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a21 F)) - (bcStrings (6 "0.5" a22 F)) - (bcStrings (6 "-1.4" a23 F)) - (bcStrings (6 "-0.7" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.3" a31 F)) - (bcStrings (6 "-1.4" a32 F)) - (bcStrings (6 "0.5" a33 F)) - (bcStrings (6 "0.0" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-2.6" a41 F)) - (bcStrings (6 "-0.7" a42 F)) - (bcStrings (6 "0.0" a43 F)) - (bcStrings (6 "0.5" a44 F))) - htMakeDoneButton('"Continue",'f02bbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'alb,alb) - htpSetProperty(page,'ub,ub) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02bbfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - alb := htpProperty(htPage,'alb) - ub := htpProperty(htPage,'ub) - -- ia should be = n, unlike the example program - -- where ia = nmax --- ia := htpProperty(htPage,'ia) --- iv := htpProperty(htPage,'iv) - ia := n - iv := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f02bbf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,alb,", ",ub,", ",STRINGIMAGE m,", ",STRINGIMAGE iv) - prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") - linkGen prefix - -f02bjf() == - htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02bjf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02bjf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates all the eigenvalues and, if required, all the ") - (text . "eigenvectors of Ax = \lambda Bx, where A and B are real ") - (text . "symmetric matrices of order n and B using the QZ algorithm. ") - (text . "The routine does not actually produce the eigenvalues ") - (text . "\inputbitmap{\htbmdir{}/lamdaj.bitmap}, but instead returns ") - (text . "\inputbitmap{\htbmdir{}/alphaj.bitmap} and ") - (text . "\inputbitmap{\htbmdir{}/betaj.bitmap} ") - (text . "such that \inputbitmap{\htbmdir{}/lamdaj.bitmap} = ") - (text . "\inputbitmap{\htbmdir{}/alphaj.bitmap} / ") - (text . "\inputbitmap{\htbmdir{}/betaj.bitmap}, ") - (text . "for j = 1,2,...,n. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Order of matrices A and B, {\it n}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 4 n PI)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it ia}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "\newline First dimension of B, {\it ib}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 4 ia PI)) --- (text . "\tab{34} ") --- (bcStrings (6 4 ib F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of V, {\it iv}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "\newline Tolerance, {\it eps}: ") - (text . "\newline \tab{2} ") --- (bcStrings (6 4 iv PI)) --- (text . "\tab{34} ") - (bcStrings (6 "1.0e-4" eps F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Are eigenvectors required: ") - (radioButtons matv - ("" " true" true) - ("" " false" false)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02bjfSolve) - htShowPage() - -f02bjfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - ib := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) --- objValUnwrap htpLabelSpadValue(htPage, 'ib) - iv := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) --- objValUnwrap htpLabelSpadValue(htPage, 'iv) - eps := htpLabelInputString(htPage,'eps) - bool := htpButtonValue(htPage,'matv) - matv := - bool = 'true => '"true" - '"false" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '4 => f02bjfDefaultSolve(htPage,ia,ib,iv,eps,matv,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k,n) for k in 1..ib] where h(k,n) == - bList := - "append"/[l(k,p) for p in 1..n] where l(k,p) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - bList := [['text,:prefix],:bList] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02bjfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'matv,matv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f02bjfDefaultSolve (htPage,ia,ib,iv,eps,matv,ifail) == - n := '4 - page := htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "3.9" a11 F)) - (bcStrings (6 "12.5" a12 F)) - (bcStrings (6 "-34.5" a13 F)) - (bcStrings (6 "-0.5" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "4.3" a21 F)) - (bcStrings (6 "21.5" a22 F)) - (bcStrings (6 "-47.5" a23 F)) - (bcStrings (6 "7.5" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "4.3" a31 F)) - (bcStrings (6 "21.5" a32 F)) - (bcStrings (6 "-43.5" a33 F)) - (bcStrings (6 "3.5" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "4.4" a41 F)) - (bcStrings (6 "26.0" a42 F)) - (bcStrings (6 "-46.0" a43 F)) - (bcStrings (6 "6.0" a44 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 b11 F)) - (bcStrings (6 2 b12 F)) - (bcStrings (6 "-3" b13 F)) - (bcStrings (6 1 b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 1 b21 F)) - (bcStrings (6 3 b22 F)) - (bcStrings (6 "-5" b23 F)) - (bcStrings (6 4b24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 1 b31 F)) - (bcStrings (6 3 b32 F)) - (bcStrings (6 -4 b33 F)) - (bcStrings (6 3 b34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 1 b41 F)) - (bcStrings (6 3 b42 F)) - (bcStrings (6 -4 b43 F)) - (bcStrings (6 4 b44 F))) - htMakeDoneButton('"Continue",'f02bjfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'iv,iv) - htpSetProperty(page,'eps,eps) - htpSetProperty(page,'matv,matv) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02bjfGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) --- ib := htpProperty(htPage,'ib) --- iv := htpProperty(htPage,'iv) - ia := n - ib := n - iv := n - eps := htpProperty(htPage,'eps) - matv := htpProperty(htPage,'matv) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..ia repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..ib repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02bjf(",STRINGIMAGE n,", ",STRINGIMAGE ia,", ") - prefix := STRCONC(prefix,STRINGIMAGE ib,", ",eps,", ",matv,", ") - prefix := STRCONC(prefix,STRINGIMAGE iv,", ",matstring,", ",bstring,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - linkGen prefix - - -f02fjf() == - htInitPage('"F02FJF - Selected eigenvalues and eigenvectors of sparse symmetric eigenproblem",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02fjf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02fjf| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Finds the {\it m} eigenvalues of largest absolute value and the ") - (text . "corresponding eigenvectors for the eigenvalue problem ") - (text . "{\it Cx = \htbitmap{lambda}x}, where {\it C} is a real matrix ") - (text . "of order {\it n} such that {\it BC = \htbitmap{ctb}} for a ") - (text . "given positive-definite matrix {\it B}. ") - (text . "\blankline ") - (text . "\newline ") - (text . "Read the input file to see the example program. ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\spadcommand{)read f02fjf \bound{s0}} ")) - htShowPage() - - -f02wef() == - htInitPage('"F02WEF - SVD of real matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02wef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02wef| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns all or part of the singular value decomposition of a ") - (text . "real {\it m} by {\it n} matrix {\it A}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) - (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of B, {\it ldb}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) --- (text . "\tab{34} ") --- (bcStrings (6 5 ldb PI)) --- (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Number of columns of matrix B, {\it ncolb}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 ncolb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Is the matrix {\it Q} required, {\it wantq}:") - (radioButtons wantq - (" " " true" qtrue) - (" " " false" qfalse)) - (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of {\it Q}, {\it ldq}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of {\it PT}, {\it ldpt}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 1 ldq PI)) --- (text . "\tab{34} ") --- (bcStrings (6 5 ldpt PI)) --- (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Is the matrix {\it PT} required, {\it wantp}:") - (radioButtons wantp - (" " " true" ptrue) - (" " " false" pfalse)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02wefSolve) - htShowPage() - -f02wefSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - ncolb := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) - objValUnwrap htpLabelSpadValue(htPage, 'ncolb) - operation := htpButtonValue(htPage,'wantq) - wantq := - operation = 'qtrue => '"true" - '"false" - ldq := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldq) --- objValUnwrap htpLabelSpadValue(htPage, 'ldq) - ldpt := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldpt) --- objValUnwrap htpLabelSpadValue(htPage, 'ldpt) - elements := htpButtonValue(htPage,'wantp) - wantp := - elements = 'ptrue => '"true" - '"false" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolb = '1) => - f02wefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldpt,wantp,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[10, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bList := - "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == - pre := ("\newline \tab{2} ") - labelList := - "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", bnam, 'F]]] - labelList := [['text,:pre],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bList] - page := htInitPage('"F02WEF - SVD of real matrix",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02wefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'wantq,wantq) --- htpSetProperty(page,'ldq,ldq) --- htpSetProperty(page,'ldpt,ldpt) - htpSetProperty(page,'wantp,wantp) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02wefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldpt,wantp,ifail) == - n := '3 - m := '5 - ncolb := '1 - page := htInitPage('"F02WEF - SVD of real matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a11 F)) - (bcStrings (6 "2.5" a12 F)) - (bcStrings (6 "2.5" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a21 F)) - (bcStrings (6 "2.5" a22 F)) - (bcStrings (6 "2.5" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.6" a31 F)) - (bcStrings (6 "-0.4" a32 F)) - (bcStrings (6 "2.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a41 F)) - (bcStrings (6 "-0.5" a42 F)) - (bcStrings (6 "0.5" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.2" a51 F)) - (bcStrings (6 "-0.3" a52 F)) - (bcStrings (6 "-2.9" a53 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.1" b11 F)) - (bcStrings (6 "0.9" b12 F)) - (bcStrings (6 "0.6" b13 F)) - (bcStrings (6 "0.0" b14 F)) - (bcStrings (6 "-0.8" b15 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f02wefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'wantq,wantq) - htpSetProperty(page,'ldq,ldq) - htpSetProperty(page,'ldpt,ldpt) - htpSetProperty(page,'wantp,wantp) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02wefGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - lda := htpProperty(htPage,'lda) - ldb := htpProperty(htPage,'ldb) - ncolb := htpProperty(htPage,'ncolb) - wantq := htpProperty(htPage,'wantq) - ldq := htpProperty(htPage,'ldq) - ldpt := htpProperty(htPage,'ldpt) - wantp := htpProperty(htPage,'wantp) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - for i in 1..ldb repeat - for j in 1..ncolb repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02wef(",STRINGIMAGE m,",",STRINGIMAGE n,",") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE ncolb,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",wantq,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldq,", ",wantp,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldpt,", ",matstring,", ",bstring," ,") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - -f02xef() == - htInitPage('"F02XEF - SVD of complex matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf02xef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02xef| '|NagEigenPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns all or part of the singular value decomposition of a ") - (text . "complex {\it m} by {\it n} matrix {\it A}.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 5 m PI)) - (text . "\tab{34} ") - (bcStrings (6 3 n PI)) - (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it lda}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of B, {\it ldb}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 lda PI)) --- (text . "\tab{34} ") --- (bcStrings (6 5 ldb PI)) --- (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Number of columns of matrix B, {\it ncolb}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 ncolb PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Is the matrix {\it Q} required, {\it wantq}:") - (radioButtons wantq - (" " " true" qtrue) - (" " " false" qfalse)) - (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of {\it Q}, {\it ldq}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") --- (text . "First dimension of {\it PH}, {\it ldph}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 5 ldq PI)) --- (text . "\tab{34} ") --- (bcStrings (6 3 ldph PI)) --- (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Is the matrix {\it PH} required, {\it wantp}:") - (radioButtons wantp - (" " " true" ptrue) - (" " " false" pfalse)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f02xefSolve) - htShowPage() - -f02xefSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - ncolb := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) - objValUnwrap htpLabelSpadValue(htPage, 'ncolb) - operation := htpButtonValue(htPage,'wantq) - wantq := - operation = 'qtrue => '"true" - '"false" - ldq := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldq) --- objValUnwrap htpLabelSpadValue(htPage, 'ldq) - ldph := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldph) --- objValUnwrap htpLabelSpadValue(htPage, 'ldph) - elements := htpButtonValue(htPage,'wantp) - wantp := - elements = 'ptrue => '"true" - '"false" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - ((m = '5 and n = '3) and ncolb = '1) => - f02xefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldph,wantp,ifail) - matList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[ga(i,j) for j in 1..n] where ga(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[15, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bList := - "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == - pre := ("\newline \tab{2} ") - labelList := - "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[15, "0.0", bnam, 'F]]] - labelList := [['text,:pre],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bList] - page := htInitPage('"F02XEF - SVD of complex matrix",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f02xefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'wantq,wantq) - htpSetProperty(page,'ldq,ldq) - htpSetProperty(page,'ldph,ldph) - htpSetProperty(page,'wantp,wantp) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02xefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldph,wantp,ifail) == - n := '3 - m := '5 - ncolb := '1 - page := htInitPage('"F02XEF - SVD of complex matrix",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (15 "0.5*%i" a11 F)) - (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) - (bcStrings (15 "-1 + 1*%i" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4 + 0.3*%i" a21 F)) - (bcStrings (15 "0.9 + 1.3*%i" a22 F)) - (bcStrings (15 "0.2 + 1.4*%i" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.4" a31 F)) - (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) - (bcStrings (15 "1.8" a33 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.3 - 0.4*%i" a41 F)) - (bcStrings (15 "0.1 + 0.7*%i" a42 F)) - (bcStrings (15 "0.0" a43 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "-0.3*%i" a51 F)) - (bcStrings (15 "0.3 + 0.3*%i" a52 F)) - (bcStrings (15 "2.4*%i" a53 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") - (text . "\newline \tab{2} ") - (bcStrings (15 "-0.55+1.05*%i" b11 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.49+0.93*%i" b12 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.56-0.16*%i" b13 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "0.39+0.23*%i" b14 F)) - (text . "\newline \tab{2} ") - (bcStrings (15 "1.13+0.83*%i" b15 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f02xefGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) - htpSetProperty(page,'lda,lda) - htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'ncolb,ncolb) - htpSetProperty(page,'wantq,wantq) - htpSetProperty(page,'ldq,ldq) - htpSetProperty(page,'ldph,ldph) - htpSetProperty(page,'wantp,wantp) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f02xefGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) - lda := htpProperty(htPage,'lda) - ldb := htpProperty(htPage,'ldb) - ncolb := htpProperty(htPage,'ncolb) - wantq := htpProperty(htPage,'wantq) - ldq := htpProperty(htPage,'ldq) - ldph := htpProperty(htPage,'ldph) - wantp := htpProperty(htPage,'wantp) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - y := REVERSE y - for i in 1..lda repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - for i in 1..ldb repeat - for j in 1..ncolb repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - bform := [:bform,rowList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bform] - prefix := STRCONC('"f02xef(",STRINGIMAGE m,",",STRINGIMAGE n,",") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE ncolb,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",wantq,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldq,", ",wantp,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldph,", ",matstring,", ",bstring," ,") - linkGen STRCONC(prefix,STRINGIMAGE ifail,")") - - diff --git a/src/interp/nag-f02.boot.pamphlet b/src/interp/nag-f02.boot.pamphlet new file mode 100644 index 00000000..ccbd74f5 --- /dev/null +++ b/src/interp/nag-f02.boot.pamphlet @@ -0,0 +1,2755 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-f02.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +f02aaf() == + htInitPage('"F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02aaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aaf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues of a real symmetric matrix ") + (text . "{\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02aafSolve) + htShowPage() + +f02aafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02aafDefaultSolve(htPage,ia,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage("F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02aafGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02aafDefaultSolve (htPage,ia,ifail) == + n := '4 + page := htInitPage('"F02AAF - All eigenvalues of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "2.3" a13 F)) + (bcStrings (6 "-2.6" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "0.5" a22 F)) + (bcStrings (6 "-1.4" a23 F)) + (bcStrings (6 "-0.7" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.3" a31 F)) + (bcStrings (6 "-1.4" a32 F)) + (bcStrings (6 "0.5" a33 F)) + (bcStrings (6 "0.0" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.6" a41 F)) + (bcStrings (6 "-0.7" a42 F)) + (bcStrings (6 "0.0" a43 F)) + (bcStrings (6 "0.5" a44 F))) + htMakeDoneButton('"Continue",'f02aafGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02aafGen htPage == + n := htpProperty(htPage,'n) + -- ia should be = n, unlike the example program + -- where ia = nmax +-- ia := htpProperty(htPage,'ia) + ia := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f02aaf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + +f02abf() == + htInitPage('"F02ABF - All eigenvalues and eignevectors of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02abf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02abf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues and eigenvectors of a real ") + (text . "symmetric matrix ") + (text . "{\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of V, {\it v} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 v PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02abfSolve) + htShowPage() + +f02abfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + iv := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'v) +-- objValUnwrap htpLabelSpadValue(htPage, 'v) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02abfDefaultSolve(htPage,ia,iv,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage("F02ABF - All eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02abfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02abfDefaultSolve (htPage,ia,iv,ifail) == + n := '4 + page := htInitPage('"F02ABF - All eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "2.3" a13 F)) + (bcStrings (6 "-2.6" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "0.5" a22 F)) + (bcStrings (6 "-1.4" a23 F)) + (bcStrings (6 "-0.7" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.3" a31 F)) + (bcStrings (6 "-1.4" a32 F)) + (bcStrings (6 "0.5" a33 F)) + (bcStrings (6 "0.0" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.6" a41 F)) + (bcStrings (6 "-0.7" a42 F)) + (bcStrings (6 "0.0" a43 F)) + (bcStrings (6 "0.5" a44 F))) + htMakeDoneButton('"Continue",'f02abfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02abfGen htPage == + n := htpProperty(htPage,'n) + -- ia should be = n, unlike the example program + -- where ia = nmax +-- ia := htpProperty(htPage,'ia) +-- iv := htpProperty(htPage,'iv) + ia := n + iv := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f02abf(",matstring,", ",STRINGIMAGE ia,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE iv,", ") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + +f02adf() == + htInitPage('"F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02adf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates all the eigenvalues of Ax = \lambda Bx, where ") + (text . "A and B are real symmetric matrices of order n and B is positive-definite ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrices A and B, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "\newline First dimension of B, {\it ib}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 ib F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02adfSolve) + htShowPage() + +f02adfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + ib := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) +-- objValUnwrap htpLabelSpadValue(htPage, 'ib) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02adfDefaultSolve(htPage,ia,ib,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..ib] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02adfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02adfDefaultSolve (htPage,ia,ib,ifail) == + n := '4 + page := htInitPage('"F02ADF - All eigenvalues of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "1.5" a12 F)) + (bcStrings (6 "6.6" a13 F)) + (bcStrings (6 "4.8" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" a21 F)) + (bcStrings (6 "6.5" a22 F)) + (bcStrings (6 "16.2" a23 F)) + (bcStrings (6 "8.6" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "6.6" a31 F)) + (bcStrings (6 "16.2" a32 F)) + (bcStrings (6 "37.6" a33 F)) + (bcStrings (6 "9.8" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "4.8" a41 F)) + (bcStrings (6 "8.6" a42 F)) + (bcStrings (6 "9.8" a43 F)) + (bcStrings (6 "-17.1" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 b11 F)) + (bcStrings (6 3 b12 F)) + (bcStrings (6 4 b13 F)) + (bcStrings (6 1 b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 3 b21 F)) + (bcStrings (6 13 b22 F)) + (bcStrings (6 16 b23 F)) + (bcStrings (6 11 b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 4 b31 F)) + (bcStrings (6 16 b32 F)) + (bcStrings (6 24 b33 F)) + (bcStrings (6 18 b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 1 b41 F)) + (bcStrings (6 11 b42 F)) + (bcStrings (6 18 b43 F)) + (bcStrings (6 27 b44 F))) + htMakeDoneButton('"Continue",'f02adfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02adfGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) +-- ib := htpProperty(htPage,'ib) + ia := n + ib := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..ib repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02adf(",STRINGIMAGE ia,", ",STRINGIMAGE ib,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f02aef() == + htInitPage('"F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aef| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates all the eigenvalues and eigenvectors of Ax = ") + (text . "\lambda Bx, where A and B are real symmetric matrices of order ") + (text . "n and B is positive-definite ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrices A and B, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "\newline First dimension of B, {\it ib}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 ib F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of V, {\it iv}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 iv PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02aefSolve) + htShowPage() + +f02aefSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + ib := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) +-- objValUnwrap htpLabelSpadValue(htPage, 'ib) + iv := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) +-- objValUnwrap htpLabelSpadValue(htPage, 'iv) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02aefDefaultSolve(htPage,ia,ib,iv,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..ib] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02aefGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02aefDefaultSolve (htPage,ia,ib,iv,ifail) == + n := '4 + page := htInitPage('"F02AEF - All eigenvalues and eigenvectors of generalized real eigenproblem of the form Ax = \lambda Bx where A and B are symmetric and B is positive definite",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "1.5" a12 F)) + (bcStrings (6 "6.6" a13 F)) + (bcStrings (6 "4.8" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" a21 F)) + (bcStrings (6 "6.5" a22 F)) + (bcStrings (6 "16.2" a23 F)) + (bcStrings (6 "8.6" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "6.6" a31 F)) + (bcStrings (6 "16.2" a32 F)) + (bcStrings (6 "37.6" a33 F)) + (bcStrings (6 "9.8" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "4.8" a41 F)) + (bcStrings (6 "8.6" a42 F)) + (bcStrings (6 "9.8" a43 F)) + (bcStrings (6 "-17.1" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 b11 F)) + (bcStrings (6 3 b12 F)) + (bcStrings (6 4 b13 F)) + (bcStrings (6 1 b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 3 b21 F)) + (bcStrings (6 13 b22 F)) + (bcStrings (6 16 b23 F)) + (bcStrings (6 11 b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 4 b31 F)) + (bcStrings (6 16 b32 F)) + (bcStrings (6 24 b33 F)) + (bcStrings (6 18 b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 1 b41 F)) + (bcStrings (6 11 b42 F)) + (bcStrings (6 18 b43 F)) + (bcStrings (6 27 b44 F))) + htMakeDoneButton('"Continue",'f02aefGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02aefGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) +-- ib := htpProperty(htPage,'ib) +-- iv := htpProperty(htPage,'iv) + ia := n + ib := n + iv := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..ib repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02aef(",STRINGIMAGE ia,", ",STRINGIMAGE ib,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE iv,", ") + prefix := STRCONC(prefix,matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + + +f02aff() == + htInitPage('"F02AFF - All eigenvalues of real matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02aff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02aff| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues of a real unsymmetric matrix ") + (text . "{\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02affSolve) + htShowPage() + +f02affSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02affDefaultSolve(htPage,ia,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage("F02AFF - All eigenvalues of real matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02affGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02affDefaultSolve (htPage,ia,ifail) == + n := '4 + page := htInitPage('"F02AFF - All eigenvalues of real matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" a11 F)) + (bcStrings (6 "0.1" a12 F)) + (bcStrings (6 "4.5" a13 F)) + (bcStrings (6 "-1.5" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-22.5" a21 F)) + (bcStrings (6 "3.5" a22 F)) + (bcStrings (6 "12.5" a23 F)) + (bcStrings (6 "-2.5" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" a31 F)) + (bcStrings (6 "0.3" a32 F)) + (bcStrings (6 "4.5" a33 F)) + (bcStrings (6 "-2.5" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" a41 F)) + (bcStrings (6 "0.1" a42 F)) + (bcStrings (6 "4.5" a43 F)) + (bcStrings (6 "2.5" a44 F))) + htMakeDoneButton('"Continue",'f02affGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02affGen htPage == + n := htpProperty(htPage,'n) + -- ia should be = n, unlike the example program + -- where ia = nmax +-- ia := htpProperty(htPage,'ia) + ia := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f02aff(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + +f02agf() == + htInitPage('"F02AGF - All eigenvalues and eignevectors of real matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02agf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02agf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues and eigenvectors of a real ") + (text . "unsymmetric matrix {\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of VR, {\it ivr} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 ivr PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of VI, {\it ivi} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ivi PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02agfSolve) + htShowPage() + +f02agfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + ivr := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivr) + ivi := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivi) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02agfDefaultSolve(htPage,ia,ivr,ivi,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage("F02AGF - All eigenvalues and eigenvectors of real matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02agfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02agfDefaultSolve (htPage,ia,ivr,ivi,ifail) == + n := '4 + page := htInitPage('"F02AGF - All eigenvalues and eigenvectors of real matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" a11 F)) + (bcStrings (6 "0.1" a12 F)) + (bcStrings (6 "4.5" a13 F)) + (bcStrings (6 "-1.5" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-22.5" a21 F)) + (bcStrings (6 "3.5" a22 F)) + (bcStrings (6 "12.5" a23 F)) + (bcStrings (6 "-2.5" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" a31 F)) + (bcStrings (6 "0.3" a32 F)) + (bcStrings (6 "4.5" a33 F)) + (bcStrings (6 "-2.5" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" a41 F)) + (bcStrings (6 "0.1" a42 F)) + (bcStrings (6 "4.5" a43 F)) + (bcStrings (6 "2.5" a44 F))) + htMakeDoneButton('"Continue",'f02agfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02agfGen htPage == + n := htpProperty(htPage,'n) + -- ia should be = n, unlike the example program + -- where ia = nmax +-- ia := htpProperty(htPage,'ia) +-- ivr := htpProperty(htPage,'ivr) +-- ivi := htpProperty(htPage,'ivi) + ia := n + ivr := n + ivi := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f02agf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE ivr,", ",STRINGIMAGE ivi,", ") + linkGen STRCONC(prefix,matstring,", ",STRINGIMAGE ifail,")") + +f02ajf() == + htInitPage('"F02AJF - All eigenvalues of complex matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02ajf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02ajf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates all the eigenvalues of a complex matrix {\it A} ") + (text . "of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing real parts, ") +-- (text . " {\it iar}: \newline \tab{2} ") +-- (bcStrings (6 4 iar PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing imaginary parts,") +-- (text . " {\it iai}: \newline \tab{2} ") +-- (bcStrings (6 4 iai F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02ajfSolve) + htShowPage() + +f02ajfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + iar := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) +-- objValUnwrap htpLabelSpadValue(htPage, 'iar) + iai := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) +-- objValUnwrap htpLabelSpadValue(htPage, 'iai) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02ajfDefaultSolve(htPage,iar,iai,ifail) + matList := + "append"/[f(i,n) for i in 1..iar] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..iai] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{}\tab{2}Enter imag values of {\it A}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02AJF - All eigenvalues of complex matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02ajfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02ajfDefaultSolve (htPage,iar,iai,ifail) == + n := '4 + page := htInitPage('"F02AJF - All eigenvalues of complex matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-21.0" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "13.6" a13 F)) + (bcStrings (6 "0.0" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "26.0" a22 F)) + (bcStrings (6 "7.5" a23 F)) + (bcStrings (6 "2.5" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.0" a31 F)) + (bcStrings (6 "1.68" a32 F)) + (bcStrings (6 "4.5" a33 F)) + (bcStrings (6 "1.5" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a41 F)) + (bcStrings (6 "-2.6" a42 F)) + (bcStrings (6 "-2.7" a43 F)) + (bcStrings (6 "2.5" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-5.0" b11 F)) + (bcStrings (6 "24.6" b12 F)) + (bcStrings (6 "10.2"b13 F)) + (bcStrings (6 "4.0" b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "22.5" b21 F)) + (bcStrings (6 "-5.0" b22 F)) + (bcStrings (6 "-10.0" b23 F)) + (bcStrings (6 "0.0" b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" b31 F)) + (bcStrings (6 "2.24" b32 F)) + (bcStrings (6 "-5.0" b33 F)) + (bcStrings (6 "2.0" b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" b41 F)) + (bcStrings (6 "0.0" b42 F)) + (bcStrings (6 "3.6" b43 F)) + (bcStrings (6 "-5.0" b44 F))) + htMakeDoneButton('"Continue",'f02ajfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02ajfGen htPage == + n := htpProperty(htPage,'n) +-- iar := htpProperty(htPage,'iar) +-- iai := htpProperty(htPage,'iai) + iar := n + iai := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..iar repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..iai repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02ajf(",STRINGIMAGE n,", ",STRINGIMAGE iar,", ") + prefix := STRCONC(prefix,STRINGIMAGE iai,", ",matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f02akf() == + htInitPage('"F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02akf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02akf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues and eigenvectors of a complex ") + (text . "matrix {\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing real parts, ") +-- (text . " {\it iar}: \newline \tab{2} ") +-- (bcStrings (6 4 iar PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing imaginary parts,") +-- (text . " {\it iai}: \newline \tab{2} ") +-- (bcStrings (6 4 iai F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} \newline ") +-- (text . "First dimension of array of real parts of the eigenvectors, ") +-- (text . " {\it ivr}: \newline \tab{2} ") +-- (bcStrings (6 4 ivr PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} \newline ") +-- (text . "First dimension of array of imaginary parts of the eigenvectors,") +-- (text . " {\it ivi}: \newline \tab{2} ") +-- (bcStrings (6 4 ivi PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02akfSolve) + htShowPage() + +f02akfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + iar := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) +-- objValUnwrap htpLabelSpadValue(htPage, 'iar) + iai := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) +-- objValUnwrap htpLabelSpadValue(htPage, 'iai) + ivr := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivr) + ivi := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivi) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02akfDefaultSolve(htPage,iar,iai,ivr,ivi,ifail) + matList := + "append"/[f(i,n) for i in 1..iar] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..iai] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{}\tab{2}Enter imag values of {\it A}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02akfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02akfDefaultSolve (htPage,iar,iai,ivr,ivi,ifail) == + n := '4 + page := htInitPage('"F02AKF - All eigenvalues and eigenvectors of complex matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-21.0" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "13.6" a13 F)) + (bcStrings (6 "0.0" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "26.0" a22 F)) + (bcStrings (6 "7.5" a23 F)) + (bcStrings (6 "2.5" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.0" a31 F)) + (bcStrings (6 "1.68" a32 F)) + (bcStrings (6 "4.5" a33 F)) + (bcStrings (6 "1.5" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a41 F)) + (bcStrings (6 "-2.6" a42 F)) + (bcStrings (6 "-2.7" a43 F)) + (bcStrings (6 "2.5" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-5.0" b11 F)) + (bcStrings (6 "24.6" b12 F)) + (bcStrings (6 "10.2"b13 F)) + (bcStrings (6 "4.0" b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "22.5" b21 F)) + (bcStrings (6 "-5.0" b22 F)) + (bcStrings (6 "-10.0" b23 F)) + (bcStrings (6 "0.0" b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.5" b31 F)) + (bcStrings (6 "2.24" b32 F)) + (bcStrings (6 "-5.0" b33 F)) + (bcStrings (6 "2.0" b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.5" b41 F)) + (bcStrings (6 "0.0" b42 F)) + (bcStrings (6 "3.6" b43 F)) + (bcStrings (6 "-5.0" b44 F))) + htMakeDoneButton('"Continue",'f02akfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02akfGen htPage == + n := htpProperty(htPage,'n) +-- iar := htpProperty(htPage,'iar) +-- iai := htpProperty(htPage,'iai) +-- ivr := htpProperty(htPage,'ivr) +-- ivi := htpProperty(htPage,'ivi) + iar := n + iai := n + ivr := n + ivi := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..iar repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..iai repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02akf(",STRINGIMAGE iar,", ",STRINGIMAGE iai,", ") + prefix := STRCONC(prefix,STRINGIMAGE n,", ",STRINGIMAGE ivr,", ") + prefix := STRCONC(prefix,STRINGIMAGE ivi,", ",matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f02awf() == + htInitPage('"F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02awf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02awf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates all the eigenvalues of a complex Hermitian matrix ") + (text . "{\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of the complex Hermitian matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing real parts, ") +-- (text . " {\it iar}: \newline \tab{2} ") +-- (bcStrings (6 4 iar PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing imaginary parts,") +-- (text . " {\it iai}: \newline \tab{2} ") +-- (bcStrings (6 4 iai F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02awfSolve) + htShowPage() + +f02awfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + iar := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) +-- objValUnwrap htpLabelSpadValue(htPage, 'iar) + iai := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) +-- objValUnwrap htpLabelSpadValue(htPage, 'iai) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02awfDefaultSolve(htPage,iar,iai,ifail) + matList := + "append"/[f(i,n) for i in 1..iar] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..iai] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{}\tab{2}Enter imaginary values {\it AI}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it AR}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02awfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02awfDefaultSolve (htPage,iar,iai,ifail) == + n := '4 + page := htInitPage('"F02AWF - All eigenvalues of complex Hermitian matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter real values {\it AR}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "1.84" a13 F)) + (bcStrings (6 "2.08" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "0.5" a22 F)) + (bcStrings (6 "1.12" a23 F)) + (bcStrings (6 "-0.56" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.84" a31 F)) + (bcStrings (6 "1.12" a32 F)) + (bcStrings (6 "0.5" a33 F)) + (bcStrings (6 "0.0" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.08" a41 F)) + (bcStrings (6 "-0.56" a42 F)) + (bcStrings (6 "0.0" a43 F)) + (bcStrings (6 "0.5" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter imaginary values {\it AI}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b11 F)) + (bcStrings (6 "0.0" b12 F)) + (bcStrings (6 "1.38" b13 F)) + (bcStrings (6 "-1.56" b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b21 F)) + (bcStrings (6 "0.0" b22 F)) + (bcStrings (6 "0.84" b23 F)) + (bcStrings (6 "0.42" b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-1.38" b31 F)) + (bcStrings (6 "-0.84" b32 F)) + (bcStrings (6 "0.0" b33 F)) + (bcStrings (6 "0.0" b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.56" b41 F)) + (bcStrings (6 "-0.42" b42 F)) + (bcStrings (6 "0.0" b43 F)) + (bcStrings (6 "0.0" b44 F))) + htMakeDoneButton('"Continue",'f02awfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02awfGen htPage == + n := htpProperty(htPage,'n) +-- iar := htpProperty(htPage,'iar) +-- iai := htpProperty(htPage,'iai) + iar := n + iai := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..iar repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..iai repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02awf(",STRINGIMAGE n,", ",STRINGIMAGE iar,", ") + prefix := STRCONC(prefix,STRINGIMAGE iai,", ",matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f02axf() == + htInitPage('"F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02axf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02axf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues and eigenvectors of a complex ") + (text . "Hermitian matrix {\it A} of order {\it n}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing real parts, ") +-- (text . " {\it iar}: \newline \tab{2} ") +-- (bcStrings (6 4 iar PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of array containing imaginary parts,") +-- (text . " {\it iai}: \newline \tab{2} ") +-- (bcStrings (6 4 iai F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} \newline ") +-- (text . "First dimension of array of real parts of the eigenvectors, ") +-- (text . " {\it ivr}: \newline \tab{2} ") +-- (bcStrings (6 4 ivr PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} \newline ") +-- (text . "First dimension of array of imaginary parts of the eigenvectors,") +-- (text . " {\it ivi}: \newline \tab{2} ") +-- (bcStrings (6 4 ivi PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02axfSolve) + htShowPage() + +f02axfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + iar := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iar) +-- objValUnwrap htpLabelSpadValue(htPage, 'iar) + iai := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iai) +-- objValUnwrap htpLabelSpadValue(htPage, 'iai) + ivr := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivr) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivr) + ivi := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ivi) +-- objValUnwrap htpLabelSpadValue(htPage, 'ivi) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02axfDefaultSolve(htPage,iar,iai,ivr,ivi,ifail) + matList := + "append"/[f(i,n) for i in 1..iar] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..iai] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{}\tab{2}Enter imaginary values of {\it A}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter real values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02axfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02axfDefaultSolve (htPage,iar,iai,ivr,ivi,ifail) == + n := '4 + page := htInitPage('"F02AXF - All eigenvalues and eigenvectors of complex Hermitian matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter real values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "1.84" a13 F)) + (bcStrings (6 "2.08" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "0.5" a22 F)) + (bcStrings (6 "1.12" a23 F)) + (bcStrings (6 "-0.56" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.84" a31 F)) + (bcStrings (6 "1.12" a32 F)) + (bcStrings (6 "0.5" a33 F)) + (bcStrings (6 "0.0" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.08" a41 F)) + (bcStrings (6 "-0.56" a42 F)) + (bcStrings (6 "0.0" a43 F)) + (bcStrings (6 "0.5" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter imaginary values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b11 F)) + (bcStrings (6 "0.0" b12 F)) + (bcStrings (6 "1.38" b13 F)) + (bcStrings (6 "-1.56" b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b21 F)) + (bcStrings (6 "0.0" b22 F)) + (bcStrings (6 "0.84" b23 F)) + (bcStrings (6 "0.42" b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-1.38" b31 F)) + (bcStrings (6 "-0.84" b32 F)) + (bcStrings (6 "0.0" b33 F)) + (bcStrings (6 "0.0" b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.56" b41 F)) + (bcStrings (6 "-0.42" b42 F)) + (bcStrings (6 "0.0" b43 F)) + (bcStrings (6 "0.0" b44 F))) + htMakeDoneButton('"Continue",'f02axfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'iar,iar) +-- htpSetProperty(page,'iai,iai) +-- htpSetProperty(page,'ivr,ivr) +-- htpSetProperty(page,'ivi,ivi) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02axfGen htPage == + n := htpProperty(htPage,'n) +-- iar := htpProperty(htPage,'iar) +-- iai := htpProperty(htPage,'iai) +-- ivr := htpProperty(htPage,'ivr) +-- ivi := htpProperty(htPage,'ivi) + iar := n + iai := n + ivr := n + ivi := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..iar repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..iai repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02axf(",matstring,", ",STRINGIMAGE iar,", ",bstring) + prefix := STRCONC(prefix,", ",STRINGIMAGE iai,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE ivr,", ",STRINGIMAGE ivi,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + +f02bbf() == + htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02bbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02bbf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates selected eigenvalues and eigenvectors of a real ") + (text . "symmetric matrix {\it A} of order {\it n} by reduction to ") + (text . "tridiagonal form, bisection and inverse iteration, where the ") + (text . "selected eigenvalues lie within a given interval [{\it l,u}].") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrix A, {\it n}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Max number of eigenvectors, {\it m}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) + (text . "\tab{34} ") + (bcStrings (6 3 m PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Lower end-point of interval {\it l}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Upper end-point of interval {\it u}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.0" alb F)) + (text . "\tab{34} ") + (bcStrings (6 "3.0" ub F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of V, {\it v} ") +-- (text . "\inputbitmap{\htbmdir{}/great=.bitmap} n: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 iv PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02bbfSolve) + htShowPage() + +f02bbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + alb := htpLabelInputString(htPage,'alb) + ub := htpLabelInputString(htPage,'ub) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + iv := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) +-- objValUnwrap htpLabelSpadValue(htPage, 'iv) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02bbfDefaultSolve(htPage,m,alb,ub,ia,iv,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList] + page := htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02bbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'alb,alb) + htpSetProperty(page,'ub,ub) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02bbfDefaultSolve (htPage,m,alb,ub,ia,iv,ifail) == + n := '4 + page := htInitPage('"F02BBF - Selected eigenvalues and eigenvectors of real symmetric matrix (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.5" a11 F)) + (bcStrings (6 "0.0" a12 F)) + (bcStrings (6 "2.3" a13 F)) + (bcStrings (6 "-2.6" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a21 F)) + (bcStrings (6 "0.5" a22 F)) + (bcStrings (6 "-1.4" a23 F)) + (bcStrings (6 "-0.7" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.3" a31 F)) + (bcStrings (6 "-1.4" a32 F)) + (bcStrings (6 "0.5" a33 F)) + (bcStrings (6 "0.0" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-2.6" a41 F)) + (bcStrings (6 "-0.7" a42 F)) + (bcStrings (6 "0.0" a43 F)) + (bcStrings (6 "0.5" a44 F))) + htMakeDoneButton('"Continue",'f02bbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'alb,alb) + htpSetProperty(page,'ub,ub) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02bbfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + alb := htpProperty(htPage,'alb) + ub := htpProperty(htPage,'ub) + -- ia should be = n, unlike the example program + -- where ia = nmax +-- ia := htpProperty(htPage,'ia) +-- iv := htpProperty(htPage,'iv) + ia := n + iv := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f02bbf(",STRINGIMAGE ia,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,alb,", ",ub,", ",STRINGIMAGE m,", ",STRINGIMAGE iv) + prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") + linkGen prefix + +f02bjf() == + htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02bjf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02bjf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates all the eigenvalues and, if required, all the ") + (text . "eigenvectors of Ax = \lambda Bx, where A and B are real ") + (text . "symmetric matrices of order n and B using the QZ algorithm. ") + (text . "The routine does not actually produce the eigenvalues ") + (text . "\inputbitmap{\htbmdir{}/lamdaj.bitmap}, but instead returns ") + (text . "\inputbitmap{\htbmdir{}/alphaj.bitmap} and ") + (text . "\inputbitmap{\htbmdir{}/betaj.bitmap} ") + (text . "such that \inputbitmap{\htbmdir{}/lamdaj.bitmap} = ") + (text . "\inputbitmap{\htbmdir{}/alphaj.bitmap} / ") + (text . "\inputbitmap{\htbmdir{}/betaj.bitmap}, ") + (text . "for j = 1,2,...,n. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Order of matrices A and B, {\it n}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 4 n PI)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it ia}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "\newline First dimension of B, {\it ib}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 4 ia PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 4 ib F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of V, {\it iv}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "\newline Tolerance, {\it eps}: ") + (text . "\newline \tab{2} ") +-- (bcStrings (6 4 iv PI)) +-- (text . "\tab{34} ") + (bcStrings (6 "1.0e-4" eps F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Are eigenvectors required: ") + (radioButtons matv + ("" " true" true) + ("" " false" false)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02bjfSolve) + htShowPage() + +f02bjfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + ib := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) +-- objValUnwrap htpLabelSpadValue(htPage, 'ib) + iv := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iv) +-- objValUnwrap htpLabelSpadValue(htPage, 'iv) + eps := htpLabelInputString(htPage,'eps) + bool := htpButtonValue(htPage,'matv) + matv := + bool = 'true => '"true" + '"false" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '4 => f02bjfDefaultSolve(htPage,ia,ib,iv,eps,matv,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k,n) for k in 1..ib] where h(k,n) == + bList := + "append"/[l(k,p) for p in 1..n] where l(k,p) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE k,STRINGIMAGE p) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + bList := [['text,:prefix],:bList] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02bjfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'matv,matv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f02bjfDefaultSolve (htPage,ia,ib,iv,eps,matv,ifail) == + n := '4 + page := htInitPage('"F02BJF - All eigenvalues and optionally eigenvectors of generalized eigenproblem by {\it QZ} algorithm, real matrices (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "3.9" a11 F)) + (bcStrings (6 "12.5" a12 F)) + (bcStrings (6 "-34.5" a13 F)) + (bcStrings (6 "-0.5" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "4.3" a21 F)) + (bcStrings (6 "21.5" a22 F)) + (bcStrings (6 "-47.5" a23 F)) + (bcStrings (6 "7.5" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "4.3" a31 F)) + (bcStrings (6 "21.5" a32 F)) + (bcStrings (6 "-43.5" a33 F)) + (bcStrings (6 "3.5" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "4.4" a41 F)) + (bcStrings (6 "26.0" a42 F)) + (bcStrings (6 "-46.0" a43 F)) + (bcStrings (6 "6.0" a44 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 b11 F)) + (bcStrings (6 2 b12 F)) + (bcStrings (6 "-3" b13 F)) + (bcStrings (6 1 b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 1 b21 F)) + (bcStrings (6 3 b22 F)) + (bcStrings (6 "-5" b23 F)) + (bcStrings (6 4b24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 1 b31 F)) + (bcStrings (6 3 b32 F)) + (bcStrings (6 -4 b33 F)) + (bcStrings (6 3 b34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 1 b41 F)) + (bcStrings (6 3 b42 F)) + (bcStrings (6 -4 b43 F)) + (bcStrings (6 4 b44 F))) + htMakeDoneButton('"Continue",'f02bjfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'iv,iv) + htpSetProperty(page,'eps,eps) + htpSetProperty(page,'matv,matv) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02bjfGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) +-- ib := htpProperty(htPage,'ib) +-- iv := htpProperty(htPage,'iv) + ia := n + ib := n + iv := n + eps := htpProperty(htPage,'eps) + matv := htpProperty(htPage,'matv) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..ia repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..ib repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02bjf(",STRINGIMAGE n,", ",STRINGIMAGE ia,", ") + prefix := STRCONC(prefix,STRINGIMAGE ib,", ",eps,", ",matv,", ") + prefix := STRCONC(prefix,STRINGIMAGE iv,", ",matstring,", ",bstring,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + linkGen prefix + + +f02fjf() == + htInitPage('"F02FJF - Selected eigenvalues and eigenvectors of sparse symmetric eigenproblem",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02fjf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02fjf| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Finds the {\it m} eigenvalues of largest absolute value and the ") + (text . "corresponding eigenvectors for the eigenvalue problem ") + (text . "{\it Cx = \htbitmap{lambda}x}, where {\it C} is a real matrix ") + (text . "of order {\it n} such that {\it BC = \htbitmap{ctb}} for a ") + (text . "given positive-definite matrix {\it B}. ") + (text . "\blankline ") + (text . "\newline ") + (text . "Read the input file to see the example program. ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\spadcommand{)read f02fjf \bound{s0}} ")) + htShowPage() + + +f02wef() == + htInitPage('"F02WEF - SVD of real matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02wef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02wef| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns all or part of the singular value decomposition of a ") + (text . "real {\it m} by {\it n} matrix {\it A}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) + (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of B, {\it ldb}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 5 ldb PI)) +-- (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Number of columns of matrix B, {\it ncolb}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 ncolb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Is the matrix {\it Q} required, {\it wantq}:") + (radioButtons wantq + (" " " true" qtrue) + (" " " false" qfalse)) + (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of {\it Q}, {\it ldq}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of {\it PT}, {\it ldpt}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 1 ldq PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 5 ldpt PI)) +-- (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Is the matrix {\it PT} required, {\it wantp}:") + (radioButtons wantp + (" " " true" ptrue) + (" " " false" pfalse)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02wefSolve) + htShowPage() + +f02wefSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + ncolb := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) + objValUnwrap htpLabelSpadValue(htPage, 'ncolb) + operation := htpButtonValue(htPage,'wantq) + wantq := + operation = 'qtrue => '"true" + '"false" + ldq := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldq) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldq) + ldpt := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldpt) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldpt) + elements := htpButtonValue(htPage,'wantp) + wantp := + elements = 'ptrue => '"true" + '"false" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolb = '1) => + f02wefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldpt,wantp,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[10, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bList := + "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == + pre := ("\newline \tab{2} ") + labelList := + "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", bnam, 'F]]] + labelList := [['text,:pre],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bList] + page := htInitPage('"F02WEF - SVD of real matrix",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02wefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'wantq,wantq) +-- htpSetProperty(page,'ldq,ldq) +-- htpSetProperty(page,'ldpt,ldpt) + htpSetProperty(page,'wantp,wantp) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02wefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldpt,wantp,ifail) == + n := '3 + m := '5 + ncolb := '1 + page := htInitPage('"F02WEF - SVD of real matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a11 F)) + (bcStrings (6 "2.5" a12 F)) + (bcStrings (6 "2.5" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a21 F)) + (bcStrings (6 "2.5" a22 F)) + (bcStrings (6 "2.5" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.6" a31 F)) + (bcStrings (6 "-0.4" a32 F)) + (bcStrings (6 "2.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a41 F)) + (bcStrings (6 "-0.5" a42 F)) + (bcStrings (6 "0.5" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.2" a51 F)) + (bcStrings (6 "-0.3" a52 F)) + (bcStrings (6 "-2.9" a53 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.1" b11 F)) + (bcStrings (6 "0.9" b12 F)) + (bcStrings (6 "0.6" b13 F)) + (bcStrings (6 "0.0" b14 F)) + (bcStrings (6 "-0.8" b15 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f02wefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'wantq,wantq) + htpSetProperty(page,'ldq,ldq) + htpSetProperty(page,'ldpt,ldpt) + htpSetProperty(page,'wantp,wantp) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02wefGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + lda := htpProperty(htPage,'lda) + ldb := htpProperty(htPage,'ldb) + ncolb := htpProperty(htPage,'ncolb) + wantq := htpProperty(htPage,'wantq) + ldq := htpProperty(htPage,'ldq) + ldpt := htpProperty(htPage,'ldpt) + wantp := htpProperty(htPage,'wantp) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + for i in 1..ldb repeat + for j in 1..ncolb repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02wef(",STRINGIMAGE m,",",STRINGIMAGE n,",") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE ncolb,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",wantq,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldq,", ",wantp,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldpt,", ",matstring,", ",bstring," ,") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + +f02xef() == + htInitPage('"F02XEF - SVD of complex matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf02xef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f02xef| '|NagEigenPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns all or part of the singular value decomposition of a ") + (text . "complex {\it m} by {\it n} matrix {\it A}.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 5 m PI)) + (text . "\tab{34} ") + (bcStrings (6 3 n PI)) + (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it lda}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of B, {\it ldb}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 lda PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 5 ldb PI)) +-- (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Number of columns of matrix B, {\it ncolb}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 ncolb PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Is the matrix {\it Q} required, {\it wantq}:") + (radioButtons wantq + (" " " true" qtrue) + (" " " false" qfalse)) + (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of {\it Q}, {\it ldq}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") +-- (text . "First dimension of {\it PH}, {\it ldph}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 5 ldq PI)) +-- (text . "\tab{34} ") +-- (bcStrings (6 3 ldph PI)) +-- (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Is the matrix {\it PH} required, {\it wantp}:") + (radioButtons wantp + (" " " true" ptrue) + (" " " false" pfalse)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f02xefSolve) + htShowPage() + +f02xefSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + ncolb := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ncolb) + objValUnwrap htpLabelSpadValue(htPage, 'ncolb) + operation := htpButtonValue(htPage,'wantq) + wantq := + operation = 'qtrue => '"true" + '"false" + ldq := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldq) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldq) + ldph := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldph) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldph) + elements := htpButtonValue(htPage,'wantp) + wantp := + elements = 'ptrue => '"true" + '"false" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + ((m = '5 and n = '3) and ncolb = '1) => + f02xefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldph,wantp,ifail) + matList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[ga(i,j) for j in 1..n] where ga(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[15, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bList := + "append"/[fb(i,ncolb) for i in 1..ldb] where fb(i,ncolb) == + pre := ("\newline \tab{2} ") + labelList := + "append"/[gb(i,j) for j in 1..ncolb] where gb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[15, "0.0", bnam, 'F]]] + labelList := [['text,:pre],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter values of {\it B}: ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bList] + page := htInitPage('"F02XEF - SVD of complex matrix",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f02xefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'wantq,wantq) + htpSetProperty(page,'ldq,ldq) + htpSetProperty(page,'ldph,ldph) + htpSetProperty(page,'wantp,wantp) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02xefDefaultSolve(htPage,lda,ldb,wantq,ldq,ldph,wantp,ifail) == + n := '3 + m := '5 + ncolb := '1 + page := htInitPage('"F02XEF - SVD of complex matrix",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (15 "0.5*%i" a11 F)) + (bcStrings (15 "-0.5 + 1.5*%i" a12 F)) + (bcStrings (15 "-1 + 1*%i" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4 + 0.3*%i" a21 F)) + (bcStrings (15 "0.9 + 1.3*%i" a22 F)) + (bcStrings (15 "0.2 + 1.4*%i" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.4" a31 F)) + (bcStrings (15 "-0.4 + 0.4*%i" a32 F)) + (bcStrings (15 "1.8" a33 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.3 - 0.4*%i" a41 F)) + (bcStrings (15 "0.1 + 0.7*%i" a42 F)) + (bcStrings (15 "0.0" a43 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "-0.3*%i" a51 F)) + (bcStrings (15 "0.3 + 0.3*%i" a52 F)) + (bcStrings (15 "2.4*%i" a53 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it B}: ") + (text . "\newline \tab{2} ") + (bcStrings (15 "-0.55+1.05*%i" b11 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.49+0.93*%i" b12 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.56-0.16*%i" b13 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "0.39+0.23*%i" b14 F)) + (text . "\newline \tab{2} ") + (bcStrings (15 "1.13+0.83*%i" b15 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f02xefGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) + htpSetProperty(page,'lda,lda) + htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'ncolb,ncolb) + htpSetProperty(page,'wantq,wantq) + htpSetProperty(page,'ldq,ldq) + htpSetProperty(page,'ldph,ldph) + htpSetProperty(page,'wantp,wantp) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f02xefGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) + lda := htpProperty(htPage,'lda) + ldb := htpProperty(htPage,'ldb) + ncolb := htpProperty(htPage,'ncolb) + wantq := htpProperty(htPage,'wantq) + ldq := htpProperty(htPage,'ldq) + ldph := htpProperty(htPage,'ldph) + wantp := htpProperty(htPage,'wantp) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + y := REVERSE y + for i in 1..lda repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + for i in 1..ldb repeat + for j in 1..ncolb repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + bform := [:bform,rowList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bform] + prefix := STRCONC('"f02xef(",STRINGIMAGE m,",",STRINGIMAGE n,",") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",STRINGIMAGE ncolb,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",wantq,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldq,", ",wantp,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldph,", ",matstring,", ",bstring," ,") + linkGen STRCONC(prefix,STRINGIMAGE ifail,")") + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-f04.boot b/src/interp/nag-f04.boot deleted file mode 100644 index 31950c8a..00000000 --- a/src/interp/nag-f04.boot +++ /dev/null @@ -1,2309 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -f04adf() == - htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain I (Integer))) - (text . "\windowlink{Manual Page}{manpageXXf04adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04adf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Calculates the approximate solution of a set of complex linear ") - (text . "equations {\it AX = B} using an {\it LU} factorization with ") - (text . "partial pivoting, where {\it A} is an n * n matrix, {\it X} is ") - (text . "an {\it n} by {\it m} matrix of unknowns and {\it B} is an ") - (text . "{\it n} by {\it m} matrix of right-hand sides.") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "{\it n} order of matrix A:") - (text . "\tab{28} \menuitemstyle{}\tab{30} ") - (text . "{\it m} number of right-hand sides \htbitmap{great=} 0 :") - (text . "\newline\tab{2} ") - (bcStrings (10 3 n I)) - (text . "\tab{30} ") - (bcStrings (10 1 m I)) --- (text . "\blankline ") --- (text . "\newline \menuitemstyle{}\tab{2} ") --- (text . "{\it IA} first dimension of A:") --- (text . "\tab{32} \menuitemstyle{}\tab{34} ") --- (text . "{\it IB} first dimension of B:") --- (text . "\newline\tab{2} ") --- (bcStrings (10 3 ia I)) --- (text . "\tab{34} ") --- (bcStrings (10 3 ib I)) --- (text . "\blankline ") --- (text . "\newline \menuitemstyle{}\tab{2} ") --- (text . "{\it IC} first dimension of C:") --- (text . "\newline\tab{2} ") --- (bcStrings (10 3 ic I)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04adfSolve) - htShowPage() - -f04adfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - ib := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) --- objValUnwrap htpLabelSpadValue(htPage, 'ib) - ic := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ic) --- objValUnwrap htpLabelSpadValue(htPage, 'ic) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '3 and m = '1) => f04adfDefaultSolve(htPage,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - ianam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[12, "0.0 + 0.0*%i", ianam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[fb(i,m) for i in 1..ib] where fb(i,m) == - blabelList := - "append"/[gb(i,j) for j in 1..m] where gb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[12, "0.0 + 0.0*%i", bnam, 'F]]] - prefix := ('"\newline \tab{2} ") - blabelList := [['text,:prefix],:blabelList] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :matList,:bmatList] - page := htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04adfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'ic,ic) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - -f04adfDefaultSolve (htPage, ifail) == - n := '3 - m := '1 - ia := '3 - ib := '3 - ic := '3 - page := htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (12 "1" a11 F)) - (bcStrings (12 "1 + 2*%i" a12 F)) - (bcStrings (12 "2 + 10*%i" a13 F)) - (text . "\newline \tab{2} ") - (bcStrings (12 "1 + %i" a21 F)) - (bcStrings (12 "3*%i" a22 F)) - (bcStrings (12 "-5 + 14*%i" a23 F)) - (text . "\newline \tab{2} ") - (bcStrings (12 "1 + %i" a31 F)) - (bcStrings (12 "5*%i" a32 F)) - (bcStrings (12 "-8 + 20*%i" a33 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (12 "1" b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (12 "0" b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (12 "0" b3 F))) - htMakeDoneButton('"Continue",'f04adfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'ib,ib) --- htpSetProperty(page,'ic,ic) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04adfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- ia := htpProperty(htPage,'ia) --- ib := htpProperty(htPage,'ib) --- ic := htpProperty(htPage,'ic) - ia := n - ib := n - ic := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - -- will probably need to change this as its a vector not an array - for i in 1..m repeat - for j in 1..ib repeat - right := STRCONC((first y).1," ") - y := rest y - bList := [right,:bList] - bstring := bcwords2liststring bList - boutList := [bstring,:boutList] - bList := [] - boutstring := bcwords2liststring boutList - y := REVERSE y - k := -1 - matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f04adf(",STRINGIMAGE ia,",",boutstring,",") - prefix := STRCONC(prefix,STRINGIMAGE ib,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE m,", ",STRINGIMAGE ic) - prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") - bcGen prefix - -f04arf() == - htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain I (Integer))) - (text . "\windowlink{Manual Page}{manpageXXf04arf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04arf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates the approximate solution of a set of real linear ") - (text . "equations {\it Ax = b} using an {\it LU} factorization with ") - (text . "pivoting, where {\it A} is an n * n matrix, {\it x} is an n ") - (text . "element vector of unknowns and {\it b} is an n element ") - (text . "right-hand side vector.") - (text . "\blankline ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") --- (text . "{\it IA} first dimension of A:") --- (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\it n} order of matrix A:") - (text . "\newline\tab{2} ") --- (bcStrings (10 8 ia I)) --- (text . "\tab{34} ") - (bcStrings (10 3 n I)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04arfSolve) - htShowPage() - -f04arfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '3 => f04arfDefaultSolve(htPage,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", ianam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k) for k in 1..n] where h(k) == - prefix := ('"\newline \tab{2} ") - bnam := INTERN STRCONC ('"b",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :matList,:bmatList] - page := htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04arfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - -f04arfDefaultSolve (htPage, ifail) == - n := '3 - ia := '3 - page := htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 33 ia11 F)) - (bcStrings (6 16 ia12 F)) - (bcStrings (6 72 ia13 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-24" ia21 F)) - (bcStrings (6 "-10" ia22 F)) - (bcStrings (6 "-57" ia23 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-8" ia31 F)) - (bcStrings (6 "-4" ia32 F)) - (bcStrings (6 "-17" ia33 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia41 F)) --- (bcStrings (6 0 ia42 F)) --- (bcStrings (6 0 ia43 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia51 F)) --- (bcStrings (6 0 ia52 F)) --- (bcStrings (6 0 ia53 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia61 F)) --- (bcStrings (6 0 ia62 F)) --- (bcStrings (6 0 ia63 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia71 F)) --- (bcStrings (6 0 ia72 F)) --- (bcStrings (6 0 ia73 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia81 F)) --- (bcStrings (6 0 ia82 F)) --- (bcStrings (6 0 ia83 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-359" b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "281" b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "85" b3 F))) - htMakeDoneButton('"Continue",'f04arfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04arfGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) - ia := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - right := STRCONC((first y).1," ") - y := rest y - bList := [right,:bList] - bstring := bcwords2liststring bList - y := REVERSE y - k := -1 - matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f04arf(",STRINGIMAGE ia,", [",bstring,"],",STRINGIMAGE n) - prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") - bcGen prefix - -f04asf() == - htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain I (Integer))) - (text . "\windowlink{Manual Page}{manpageXXf04asf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04asf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates the accurate solution of a set of real symmetric ") - (text . "positive-definite linear equations {\it Ax = b} using an a ") - (text . "Cholesky factorization and iterative refinement, ") - (text . "where {\it A} is an n * n matrix, {\it x} is an n ") - (text . "element vector of unknowns and {\it b} is an n element ") - (text . "right-hand side vector.") - (text . "\blankline ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") --- (text . "{\it IA} first dimension of A:") --- (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\it n} order of matrix A:") - (text . "\newline\tab{2} ") --- (bcStrings (10 8 ia I)) --- (text . "\tab{34} ") - (bcStrings (10 4 n I)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04asfSolve) - htShowPage() - -f04asfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 --- (n = '4 and ia = '8) => f04asfDefaultSolve(htPage,ifail) - n = '4 => f04asfDefaultSolve(htPage,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", ianam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k) for k in 1..n] where h(k) == - prefix := ('"\newline \tab{2} ") - bnam := INTERN STRCONC ('"b",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :matList,:bmatList] - page := htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04asfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - -f04asfDefaultSolve (htPage, ifail) == - n := '4 - ia := '4 - page := htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 5 ia11 F)) - (bcStrings (6 7 ia12 F)) - (bcStrings (6 6 ia13 F)) - (bcStrings (6 5 ia14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 7 ia21 F)) - (bcStrings (6 10 ia22 F)) - (bcStrings (6 8 ia23 F)) - (bcStrings (6 7 ia24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 6 ia31 F)) - (bcStrings (6 8 ia32 F)) - (bcStrings (6 10 ia33 F)) - (bcStrings (6 9 ia34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 5 ia41 F)) - (bcStrings (6 7 ia42 F)) - (bcStrings (6 9 ia43 F)) - (bcStrings (6 10 ia44 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia51 F)) --- (bcStrings (6 0 ia52 F)) --- (bcStrings (6 0 ia53 F)) --- (bcStrings (6 0 ia54 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia61 F)) --- (bcStrings (6 0 ia62 F)) --- (bcStrings (6 0 ia63 F)) --- (bcStrings (6 0 ia64 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia71 F)) --- (bcStrings (6 0 ia72 F)) --- (bcStrings (6 0 ia73 F)) --- (bcStrings (6 0 ia74 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia81 F)) --- (bcStrings (6 0 ia82 F)) --- (bcStrings (6 0 ia83 F)) --- (bcStrings (6 0 ia84 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 23 b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 32 b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 33 b3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 31 b4 F))) - htMakeDoneButton('"Continue",'f04asfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04asfGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) - ia := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - right := STRCONC((first y).1," ") - y := rest y - bList := [right,:bList] - bstring := bcwords2liststring bList - y := REVERSE y - k := -1 - matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f04asf(",STRINGIMAGE ia,", [",bstring,"],",STRINGIMAGE n) - prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") - bcGen prefix - -f04atf() == - htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain I (Integer))) - (text . "\windowlink{Manual Page}{manpageXXf04atf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04atf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates the approximate solution of a set of real linear ") - (text . "equations {\it Ax = b} using an {\it LU} factorization with ") - (text . "pivoting and iterative refinement, ") - (text . "where {\it A} is an n * n matrix, {\it x} is an n ") - (text . "element vector of unknowns and {\it b} is an n element ") - (text . "right-hand side vector.") - (text . "\blankline ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") --- (text . "{\it IA} first dimension of A:") --- (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "{\it n} order of matrix A:") - (text . "\newline\tab{2} ") --- (bcStrings (10 8 ia I)) --- (text . "\tab{34} ") - (bcStrings (10 3 n I)) --- (text . "\blankline ") --- (text . "\newline \menuitemstyle{} \tab{2} ") --- (text . "{\it IAA} first dimension of AA:") --- (text . "\newline \tab{2} ") --- (bcStrings (10 8 iaa I)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{} \tab{2} ") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04atfSolve) - htShowPage() - -f04atfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - ia := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) --- objValUnwrap htpLabelSpadValue(htPage, 'ia) - iaa := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaa) --- objValUnwrap htpLabelSpadValue(htPage, 'iaa) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 --- (n = '3 and ia = '8) => f04atfDefaultSolve(htPage,iaa,ifail) - n = '3 => f04atfDefaultSolve(htPage,iaa,ifail) - matList := - "append"/[f(i,n) for i in 1..ia] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", ianam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k) for k in 1..n] where h(k) == - prefix := ('"\newline \tab{2} ") - bnam := INTERN STRCONC ('"b",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :matList,:bmatList] - page := htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04atfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iaa,iaa) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - -f04atfDefaultSolve (htPage, iaa, ifail) == - n := '3 - ia := '3 - page := htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 33 ia11 F)) - (bcStrings (6 16 ia12 F)) - (bcStrings (6 72 ia13 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-24" ia21 F)) - (bcStrings (6 "-10" ia22 F)) - (bcStrings (6 "-57" ia23 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-8" ia31 F)) - (bcStrings (6 "-4" ia32 F)) - (bcStrings (6 "-17" ia33 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia41 F)) --- (bcStrings (6 0 ia42 F)) --- (bcStrings (6 0 ia43 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia51 F)) --- (bcStrings (6 0 ia52 F)) --- (bcStrings (6 0 ia53 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia61 F)) --- (bcStrings (6 0 ia62 F)) --- (bcStrings (6 0 ia63 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia71 F)) --- (bcStrings (6 0 ia72 F)) --- (bcStrings (6 0 ia73 F)) --- (text . "\newline \tab{2} ") --- (bcStrings (6 0 ia81 F)) --- (bcStrings (6 0 ia82 F)) --- (bcStrings (6 0 ia83 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "-359" b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "281" b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "85" b3 F))) - htMakeDoneButton('"Continue",'f04atfGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'ia,ia) --- htpSetProperty(page,'iaa,iaa) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04atfGen htPage == - n := htpProperty(htPage,'n) --- ia := htpProperty(htPage,'ia) --- iaa := htpProperty(htPage,'iaa) - ia := n - iaa := n - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - right := STRCONC((first y).1," ") - y := rest y - bList := [right,:bList] - bstring := bcwords2liststring bList - y := REVERSE y - k := -1 - matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f04atf(",matstring,", ",STRINGIMAGE ia,", [",bstring) - prefix := STRCONC(prefix,"],",STRINGIMAGE n,", ",STRINGIMAGE iaa,", ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - bcGen prefix - - -f04faf() == - htInitPage('"F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf04adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04faf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Calculates the approximate solution of a set of real symmetric ") - (text . "positive-definite tridiagonal linear equations {\it Tx = b} ") - (text . "using a modified symmetric Gaussian Elimination algorithm, ") - (text . "where {\it T} is an n * n matrix, {\it x} is an n ") - (text . "element vector of unknowns and {\it b} is an n element ") - (text . "right-hand side vector. {\it T} is factorized as ") - (text . "\inputbitmap{\htbmdir{}/mkm.bitmap}, where {\it K} is a diagonal matrix ") - (text . "and {\it M} is a matrix of multipliers. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "{\it JOB} to be performed by f04faf: ") - (radioButtons job - ("" " = 0. {\it T} is factorized and equations {\it Tx = b} are solved for x." jobZero) - ("" " = 1. {\it T} assumed to be already factorized by previous call to f04faf, the equations {\it Tx = b} are solved for x." jobOne)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Order of the matrix T {\it n}:") - (text . "\newline \tab{2} ") - (bcStrings (6 5 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04fafSolve) - htShowPage() - -f04fafSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - number := htpButtonValue(htPage,'job) - job := - number = 'jobOne => '1 - '0 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - n = '5 => f04fafDefaultSolve(htPage,job,ifail) - dList := - "append"/[f(i) for i in 1..n] where f(i) == - prefix := ('"\newline \tab{2} ") - dnam := INTERN STRCONC ('"d",STRINGIMAGE i) - [['text,:prefix],['bcStrings,[10, 0.0, dnam, 'F]]] - prefix := ('"\menuitemstyle{}\tab{2} {\it D} Diagonal elements of T: ") - prefix := STRCONC(prefix,"\newline \tab{2} ") - dList := [['text,:prefix],:dList] - eList := - "append"/[g(j) for j in 1..(n-1)] where g(j) == - prefix := ('"\newline \tab{2} ") - enam := INTERN STRCONC ('"e",STRINGIMAGE j) - [['text,:prefix],['bcStrings,[10, 0.0, enam, 'F]]] - prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} {\it E} E(2) ") - prefix := STRCONC(prefix,"to E(N)\newline \tab{2} Job = 0 => super-diagonal") - prefix := STRCONC(prefix," elements of {\it T}. \newline \tab{2} Job = 1 =>") - prefix := STRCONC(prefix," off-diagonal elements of {\it M} from previous ") - prefix := STRCONC(prefix,"call to F04FAF. ") - eList := [['text,:prefix],:eList] - bList := - "append"/[h(k) for k in 1..n] where h(k) == - prefix := ('"\newline \tab{2} ") - bnam := INTERN STRCONC ('"b",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[10, 0.0, bnam, 'F]]] - prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} {\it B} Right-hand") - prefix := STRCONC(prefix," side vector b: ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :dList,:eList,:bList] - page := htInitPage("F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) - htMakePage equationPart - htMakeDoneButton('"Continue",'f04fafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'job,job) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f04fafDefaultSolve (htPage,job,ifail) == - n := '5 - page := htInitPage('"F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} {\it D} Diagonal elements of T:") - (text . "\newline \tab{2} ") - (bcStrings (10 4 d1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 10 d2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 29 d3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 25 d4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 5 d5 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} {\it E}\space{1} E(2) to E(N) ") - (text . "\newline \tab{2} ") - (text . "Job = 0 => super-diagonal elements of {\it T}. \newline \tab{2}") - (text . "Job = 1 => off-diagonal elements of {\it M} from ") - (text . "previous call to F04FAF \newline \tab{2} ") - (bcStrings (10 "-2" e2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 "-6" e3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 15 e4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 8 e5 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} {\it B} Right-hand side vector b:") - (text . "\newline \tab{2} ") - (bcStrings (10 6 b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 9 b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 2 b3 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 14 b4 F)) - (text . "\newline \tab{2} ") - (bcStrings (10 7 b5 F))) - htMakeDoneButton('"Continue",'f04fafGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'job,job) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04fafGen htPage == - n := htpProperty(htPage,'n) - job := htpProperty(htPage,'job) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - b := STRCONC((first y).1," ") - bList := [b,:bList] - y := rest y - bstring := bcwords2liststring bList - for i in 1..(n-1) repeat - e := STRCONC((first y).1," ") - eList := [e,:eList] - y := rest y - eList := ['"0",:eList] - estring := bcwords2liststring eList - for i in 1..n repeat - d := STRCONC((first y).1," ") - dList := [d,:dList] - y := rest y - dstring := bcwords2liststring dList - prefix := STRCONC('"f04faf(",STRINGIMAGE job,", ",STRINGIMAGE n,",[") - prefix := STRCONC(prefix,dstring,"], [",estring,"], [",bstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - bcGen prefix - - -f04jgf() == - htInitPage('"F04JGF - Least-squares (if rank = n) or minimal least-squares (if rank < n) solution of m real equations in n unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} it n, m \inputbitmap{\htbmdir{}/great=.bitmap} n",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf04jgf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04jgf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Finds the solution of a linear least squares problem {\it Ax=b},") - (text . " where A is a real m by n matrix, (m \inputbitmap{\htbmdir{}/great=.bitmap}") - (text . " n), x is an n element vector of unknowns and b is an m element ") - (text . "right-hand side vector. The routine uses a QU factorization if ") - (text . "rank A = n and the SVD if A < n. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline Rows of matrix A, {\it m}: ") - (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") - (bcStrings (6 6 m PI)) - (text . "\tab{34} ") - (bcStrings (6 4 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") --- (text . "\newline First dimension of A, {\it nra}: ") --- (text . "\tab{32} \menuitemstyle{} \tab{34} ") - (text . "Tolerance, {\it tol}: ") - (text . "\newline \tab{2} ") --- (bcStrings (6 8 nra PI)) --- (text . "\tab{34} ") - (bcStrings (8 "5.0e-4" tol F)) --- (text . "\blankline ") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Dimension of workspace array {\it lwork}: ") --- (text . "\newline \tab{2} ") --- (bcStrings (6 32 lwork PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04jgfSolve) - htShowPage() - -f04jgfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nra := m --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nra) --- objValUnwrap htpLabelSpadValue(htPage, 'nra) - lwork := 4*n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) --- objValUnwrap htpLabelSpadValue(htPage, 'lwork) - tol := htpLabelInputString(htPage,'tol) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '6 and n = '4) => f04jgfDefaultSolve(htPage,nra,lwork,tol,ifail) - matList := - "append"/[f(i,n) for i in 1..m] where f(i,n) == - labelList := - "append"/[g(i,j) for j in 1..n] where g(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - labelList := [['text,:prefix],:labelList] - bmatList := - "append"/[h(k) for k in 1..m] where h(k) == - prefix := ('"\newline \tab{2} ") - bnam := INTERN STRCONC ('"b",STRINGIMAGE k) - [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] - start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") - bmatList := [['text,:start],:bmatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :matList,:bmatList] - page := htInitPage("F04JGF - Least-squares (if rank = {\it n}) or minimal least-squares (if rank < {\it n}) solution of {\it m} real equations in {\it n} unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} {\it n}, {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} {\it n}",nil) - htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04jgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'nra,nra) --- htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f04jgfDefaultSolve (htPage,nra,lwork,tol,ifail) == - n := '4 - m := '6 - page := htInitPage('"F04JGF - Least-squares (if rank = n) or minimal least-squares (if rank < n) solution of m real equations in n unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} n, m \inputbitmap{\htbmdir{}/great=.bitmap} n",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.05" a11 F)) - (bcStrings (6 "0.05" a12 F)) - (bcStrings (6 "0.25" a13 F)) - (bcStrings (6 "-0.25" a14 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.25" a21 F)) - (bcStrings (6 "0.25" a22 F)) - (bcStrings (6 "0.05" a23 F)) - (bcStrings (6 "-0.05" a24 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.35" a31 F)) - (bcStrings (6 "0.35" a32 F)) - (bcStrings (6 "1.75" a33 F)) - (bcStrings (6 "-1.75" a34 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.75" a41 F)) - (bcStrings (6 "1.75" a42 F)) - (bcStrings (6 "0.35" a43 F)) - (bcStrings (6 "-0.35" a44 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.30" a51 F)) - (bcStrings (6 "-0.30" a52 F)) - (bcStrings (6 "0.30" a53 F)) - (bcStrings (6 "0.30" a54 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.40" a61 F)) - (bcStrings (6 "-0.40" a62 F)) - (bcStrings (6 "0.40" a63 F)) - (bcStrings (6 "0.40" a64 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 1 b1 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 2 b2 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 3 b3 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 4 b4 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 5 b5 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 6 b6 F))) - htMakeDoneButton('"Continue",'f04jgfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'nra,nra) --- htpSetProperty(page,'lwork,lwork) - htpSetProperty(page,'tol,tol) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04jgfGen htPage == - n := htpProperty(htPage,'n) - m := htpProperty(htPage,'m) --- nra := htpProperty(htPage,'nra) --- lwork := htpProperty(htPage,'lwork) - nra := m - lwork := 4*n - tol := htpProperty(htPage,'tol) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..m repeat - b := STRCONC((first y).1," ") - bList := [b,:bList] - y := rest y - bstring := bcwords2liststring bList - y := REVERSE y - for i in 1..m repeat - for j in 1..n repeat - elm := STRCONC((first y).1," ") - rowList := [:rowList,elm] - y := rest y - matform := [:matform,rowList] - rowList := [] - for i in 1..n repeat - null := STRCONC('"0.0"," ") - nullList := [:nullList,null] - for i in m..(nra-1) repeat - matform := [:matform,nullList] - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - prefix := STRCONC('"f04jgf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE nra,", ",tol,", ",STRINGIMAGE lwork) - prefix := STRCONC(prefix,", ",matstring,", [",bstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE ifail,")") - bcGen prefix - -f04mcf() == - htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf04mcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mcf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "Computes the approximate solution of a system of real linear ") - (text . "equations AX = B, where the n by n symmetric positive-definite ") - (text . "variable-bandwidth matrix A has previously been factorized as ") - (text . "\htbitmap{ldlt} by F01MCF, X is an n by r matrix of unknowns ") - (text . "and B is an n by r matrix of right-hand sides. Related systems ") - (text . "may also be solved. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the order of the matrix A, {\it n} ") - (text ."\htbitmap{great=} 1:") - (text . "\newline\tab{2} ") - (bcStrings (9 6 n PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Enter the dimension of AL, {\it lal}: ") - (text . "\newline\tab{2} ") - (bcStrings (9 14 lal PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "\newline Enter the number of right-hand sides, {\it ir}: ") - (text . "\newline\tab{2} ") - (bcStrings (9 2 ir PI)) --- (text . "\blankline") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Enter the first dimension of B, {\it nrb}: ") --- (text . "\newline\tab{2} ") --- (bcStrings (9 6 nrb PI)) --- (text . "\blankline") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\newline Enter the first dimension of X, {\it nrx}: ") --- (text . "\newline\tab{2} ") --- (bcStrings (9 6 nrx PI)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Type of system to be solved, {\it iselct}:") - (radioButtons iselct - ("" " {\em \htbitmap{ldlt}X = B} is solved" selone) - ("" " {\em LDX = B} is solved" seltwo) - ("" " {\em D\htbitmap{lt}X = B} is solved" selthree) - ("" " {\em L\htbitmap{lt}X = B} is solved" selfour) - ("" " {\em LX = B} is solved" selfive) - ("" " {\em \htbitmap{lt}X = B} is solved" selsix)) - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04mcfSolve) - htShowPage() - -f04mcfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lal := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lal) - objValUnwrap htpLabelSpadValue(htPage, 'lal) - ir := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ir) - objValUnwrap htpLabelSpadValue(htPage, 'ir) - nrb := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrb) --- objValUnwrap htpLabelSpadValue(htPage, 'nrb) - nrx := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrx) --- objValUnwrap htpLabelSpadValue(htPage, 'nrx) - select := htpButtonValue(htPage,'iselct) - iselct := - select = 'selone => '1 - select = 'seltwo => '2 - select = 'selthree => '3 - select = 'selfour => '4 - select = 'selfive => '5 - '6 - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '6 and lal = '14 and ir = '2) => f04mcfDefaultSolve(htPage,iselct,ifail) - labelList := - "append"/[fal(i) for i in 1..lal] where fal(i) == - xnam := INTERN STRCONC ('"x",STRINGIMAGE i) - [['bcStrings,[6, "0.0", xnam, 'F]]] - dList := - "append"/[fd(i) for i in 1..n] where fd(i) == - dnam := INTERN STRCONC ('"d",STRINGIMAGE i) - [['bcStrings,[6, "0.0", dnam, 'F]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} Diagonal elements of diagon") - prefix := STRCONC(prefix,"al matrix D as returned by F01MCF: \newline") - dList := [['text,:prefix],:dList] - nrowList := - "append"/[gj(j) for j in 1..n] where gj(j) == - nam := INTERN STRCONC ('"n",STRINGIMAGE j) - [['bcStrings,[6, 0, nam, 'PI]]] - prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it NROW(n)} the width ") - prefix := STRCONC(prefix,"of the ith row of A: \newline ") - nrowList := [['text,:prefix],:nrowList] - bList := - "append"/[f(i,ir) for i in 1..nrb] where f(i,ir) == - labelList := - "append"/[g(i,j) for j in 1..ir] where g(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) - [['bcStrings,[6, "0.0", bnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - prefix := ('"\blankline \menuitemstyle{}\tab{2} The n by r right-hand side ") - prefix := STRCONC(prefix,"matrix B: \newline ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain PI (PositiveInteger))), - :labelList,:dList,:nrowList,:bList] - page := htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) - htSay '"\menuitemstyle{}\tab{2} Elements of matrix {\it AL} in row by row " - htSay '"order as returned by F01MCF: \newline " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04mcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'lal,lal) - htpSetProperty(page,'ir,ir) --- htpSetProperty(page,'nrb,nrb) --- htpSetProperty(page,'nrx,nrx) - htpSetProperty(page,'iselct,iselct) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - -f04mcfDefaultSolve (htPage,iselct,ifail) == - n := '6 - lal := '14 - ir := '2 - nrb := '6 - nrx := '6 - page := htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) - htMakePage '( - (domainConditions - (isDomain PI (Positive Integer)) - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} Elements of matrix {\it AL} in row by ") - (text . "row order as returned by F01MCF: ") - (text . "\newline ") - (bcStrings (6 "1.0" x1 F)) - (bcStrings (6 "2.0" x2 F)) - (bcStrings (6 "1.0" x3 F)) - (bcStrings (6 "3.0" x4 F)) - (bcStrings (6 "1.0" x5 F)) - (bcStrings (6 "1.0" x6 F)) - (bcStrings (6 "5.0" x7 F)) - (bcStrings (6 "4.0" x8 F)) - (bcStrings (6 "1.5" x9 F)) - (bcStrings (6 "0.5" x10 F)) - (bcStrings (6 "1.0" x11 F)) - (bcStrings (6 "1.5" x12 F)) - (bcStrings (6 "5.0" x13 F)) - (bcStrings (6 "1.0" x14 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} Diagonal elements of diagonal matrix ") - (text . "D as returned by F01MCF: ") - (text . "\newline ") - (bcStrings (6 "1.0" d1 F)) - (bcStrings (6 "1.0" d2 F)) - (bcStrings (6 "4.0" d3 F)) - (bcStrings (6 "16.0" d4 F)) - (bcStrings (6 "1.0" d5 F)) - (bcStrings (6 "16.0" d6 F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} {\it NROW(n)} the width of the ith row ") - (text . "of A: ") - (text . "\newline ") - (bcStrings (6 1 n1 PI)) - (bcStrings (6 2 n2 PI)) - (bcStrings (6 2 n3 PI)) - (bcStrings (6 1 n4 PI)) - (bcStrings (6 5 n5 PI)) - (bcStrings (6 3 n6 PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2} The n by r right-hand side matrix B:") - (text . "\newline ") - (bcStrings (6 "6" b11 F)) - (text . "\tab{10} ") - (bcStrings (6 "-10" b12 PI)) - (text . "\newline ") - (bcStrings (6 "15" b21 F)) - (text . "\tab{10} ") - (bcStrings (6 "-21" b22 PI)) - (text . "\newline ") - (bcStrings (6 "11" b31 F)) - (text . "\tab{10} ") - (bcStrings (6 "-3" b32 PI)) - (text . "\newline ") - (bcStrings (6 "0" b41 F)) - (text . "\tab{10} ") - (bcStrings (6 "24" b42 PI)) - (text . "\newline ") - (bcStrings (6 "51" b51 F)) - (text . "\tab{10} ") - (bcStrings (6 "-39" b52 PI)) - (text . "\newline ") - (bcStrings (6 "46" b61 F)) - (text . "\tab{10} ") - (bcStrings (6 "67" b62 PI)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f04mcfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'lal,lal) - htpSetProperty(page,'ir,ir) --- htpSetProperty(page,'nrb,nrb) --- htpSetProperty(page,'nrx,nrx) - htpSetProperty(page,'iselct,iselct) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04mcfGen htPage == - n := htpProperty(htPage,'n) - lal := htpProperty(htPage,'lal) - ir := htpProperty(htPage,'ir) --- nrb := htpProperty(htPage,'nrb) --- nrx := htpProperty(htPage,'nrx) - nrb := n - nrx := n - iselct := htpProperty(htPage,'iselct) - ifail := htpProperty(htPage,'ifail) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..nrb repeat - for j in 1..ir repeat - elm := STRCONC((first y).1," ") - rowList := [elm,:rowList] - y := rest y - matform := [rowList,:matform] - rowList := [] - matfrom := REVERSE matform - matstring := bcwords2liststring [bcwords2liststring x for x in matform] - for i in 1..n repeat - right := STRCONC ((first y).1," ") - y := rest y - nrowList := [right,:nrowList] - nrowstring := bcwords2liststring nrowList - for i in 1..n repeat - right := STRCONC ((first y).1," ") - y := rest y - dList := [right,:dList] - dstring := bcwords2liststring dList - while y repeat - right := STRCONC ((first y).1," ") - y := rest y - alList := [right,:alList] - alstring := bcwords2liststring alList - prefix := STRCONC('"f04mcf(",STRINGIMAGE n,", [",alstring,"], ") - prefix := STRCONC(prefix,STRINGIMAGE lal,", [",dstring,"],[",nrowstring) - prefix := STRCONC(prefix,"]::Matrix Integer,") - prefix := STRCONC(prefix,STRINGIMAGE ir,", ",matstring,", ",STRINGIMAGE nrb) - prefix := STRCONC(prefix,", ",STRINGIMAGE iselct,", ",STRINGIMAGE nrx,", ") - bcGen STRCONC(prefix,STRINGIMAGE ifail,")") - - -f04axf() == - htInitPage('"F04AXF - Approximate solution of a a set of real sparse linear equations after factorization by F01BRF or by F01BSF",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf04axf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04axf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F04AXF calculates the approximate solution of a set of real ") - (text . "sparse linear equations {\it Ax=b} or ") - (text . "\htbitmap{aTx=b}, where the {\it n} by {\it n} matrix ") - (text . "{\it A} has been factorized by F01BRF or F01BSF, {\it x} ") - (text . "is an {\it n} element vector of unknowns and {\it b} is an ") - (text . "{\it n} element right-hand side vector. ") - (text . "\blankline") - (text . "\newline ") - (text . "Read the input file to see the example program. ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\spadcommand{)read f04axf \bound{s0}} ")) - htShowPage() - -f04maf() == - htInitPage('"F04MAF - Solution of a real sparse symmetric positive-definite system of linear equations after factorization by F01MAF",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf04maf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04maf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F04MAF solves a real sparse symmetric positive-definite system ") - (text . "of linear equations {\it Ax=b} using a pre-conditioned ") - (text . "conjugate gradient method, where the {\it n} by {\it n} ") - (text . "matrix {\it A} has been factorized by F01MAF, {\it x} is an ") - (text . "{\it n} element vector of unknowns and {\it b} is an {\it n} ") - (text . "element right-hand side vector. ") - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "\spadcommand{)read f04maf \bound{s0}} ")) - htShowPage() - -f04mbf() == - htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf04mbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mbf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F04MBF solve a system of real symmetric linear equations ") - (text . "({\it A} - \lambda {\it I}){\it x} = {\it b} using a Lanczos ") - (text . "algorithm, where {\it A} is an {\it n} by {\it n} sparse ") - (text . "symmetric matrix, {\it x} is an {\it n} vector of unknowns ") - (text . "and {\it b} is an {\it n} element right-hand side vector. ") - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the order {\it n} of matrix {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 10 n PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Is preconditioning required? ") - (radioButtons precon - ("" " Yes" true) - ("" " No" false)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the shift in the equations \lambda, {\it shift} : ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" shift F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the tolerance for convergence, {\it rtol}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.00001" rtol F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter an upper limit for the number of iterations, {\it itnlim}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 100 itnlim PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the printing level, {\it msglvl}: ") - (text . "\newline \tab{2} ") - (bcStrings (10 1 msglvl PI)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04mbfSolve) - htShowPage() - -f04mbfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - msolve := htpButtonValue(htPage,'precon) - precon := - msolve = 'true => 'true - 'false - shift := htpLabelInputString(htPage,'shift) - rtol := htpLabelInputString(htPage,'rtol) - itnlim := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itnlim) - objValUnwrap htpLabelSpadValue(htPage, 'itnlim) - msglvl := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'msglvl) - objValUnwrap htpLabelSpadValue(htPage, 'msglvl) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (n = '10 and precon ='true) => f04mbfDefaultSolve(htPage,shift,rtol,itnlim,msglvl,ifail) - bmatList := - "append"/[f(i) for i in 1..n] where f(i) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i) - [['bcStrings,[6, "0.0", bnam, 'F]]] - amatList := - "append"/[h(ia,n) for ia in 1..n] where h(ia,n) == - alabelList := - "append"/[k(ia,ja) for ja in 1..n] where k(ia,ja) == - anam := INTERN STRCONC ('"a",STRINGIMAGE ia,STRINGIMAGE ja) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - alabelList := [['text,:prefix],:alabelList] - start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it A}: ") - amatList := [['text,:start],:amatList] - mmatList:= - precon = 'true => - alabelList:= - "append"/[l(im,n) for im in 1..n] where l(im,n) == - mlabelList := - "append"/[o(im,jm) for jm in 1..n] where o(im,jm) == - mnam := INTERN STRCONC ('"m",STRINGIMAGE im,STRINGIMAGE jm) - [['bcStrings,[6, "0.0", mnam, 'F]]] - prefix := ('"\newline \tab{2} ") - mlabelList := [['text,:prefix],:mlabelList] - start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it m}: ") - [['text,:start],:alabelList] - [] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :bmatList,:amatList,:mmatList] - page := htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) - htSay '"\newline \menuitemstyle{}\tab{2} " - htSay '"Enter the right-hand side vector {\it b(n)}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04mbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'precon,precon) - htpSetProperty(page,'shift,shift) - htpSetProperty(page,'rtol,rtol) - htpSetProperty(page,'itnlim,itnlim) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04mbfDefaultSolve (htPage,shift,rtol,itnlim,msglvl,ifail) == - n := '10 - precon := 'true - page := htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the right-hand side vector {\it b(n)}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "6.0" b1 F)) - (bcStrings (6 "4.0" b2 F)) - (bcStrings (6 "4.0" b3 F)) - (bcStrings (6 "4.0" b4 F)) - (bcStrings (6 "4.0" b5 F)) - (bcStrings (6 "4.0" b6 F)) - (bcStrings (6 "4.0" b7 F)) - (bcStrings (6 "4.0" b8 F)) - (bcStrings (6 "4.0" b9 F)) - (bcStrings (6 "6.0" b10 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the matrix {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" a11 F)) - (bcStrings (6 "1.0" a12 F)) - (bcStrings (6 "0.0" a13 F)) - (bcStrings (6 "0.0" a14 F)) - (bcStrings (6 "0.0" a15 F)) - (bcStrings (6 "0.0" a16 F)) - (bcStrings (6 "0.0" a17 F)) - (bcStrings (6 "0.0" a18 F)) - (bcStrings (6 "0.0" a19 F)) - (bcStrings (6 "3.0" a110 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.0" a21 F)) - (bcStrings (6 "2.0" a22 F)) - (bcStrings (6 "1.0" a23 F)) - (bcStrings (6 "0.0" a24 F)) - (bcStrings (6 "0.0" a25 F)) - (bcStrings (6 "0.0" a26 F)) - (bcStrings (6 "0.0" a27 F)) - (bcStrings (6 "0.0" a28 F)) - (bcStrings (6 "0.0" a29 F)) - (bcStrings (6 "0.0" a210 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a31 F)) - (bcStrings (6 "1.0" a32 F)) - (bcStrings (6 "2.0" a33 F)) - (bcStrings (6 "1.0" a34 F)) - (bcStrings (6 "0.0" a35 F)) - (bcStrings (6 "0.0" a36 F)) - (bcStrings (6 "0.0" a37 F)) - (bcStrings (6 "0.0" a38 F)) - (bcStrings (6 "0.0" a39 F)) - (bcStrings (6 "0.0" a310 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a41 F)) - (bcStrings (6 "0.0" a42 F)) - (bcStrings (6 "1.0" a43 F)) - (bcStrings (6 "2.0" a44 F)) - (bcStrings (6 "1.0" a45 F)) - (bcStrings (6 "0.0" a46 F)) - (bcStrings (6 "0.0" a47 F)) - (bcStrings (6 "0.0" a48 F)) - (bcStrings (6 "0.0" a49 F)) - (bcStrings (6 "0.0" a410 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a51 F)) - (bcStrings (6 "0.0" a52 F)) - (bcStrings (6 "0.0" a53 F)) - (bcStrings (6 "1.0" a54 F)) - (bcStrings (6 "2.0" a55 F)) - (bcStrings (6 "1.0" a56 F)) - (bcStrings (6 "0.0" a57 F)) - (bcStrings (6 "0.0" a58 F)) - (bcStrings (6 "0.0" a59 F)) - (bcStrings (6 "0.0" a510 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a61 F)) - (bcStrings (6 "0.0" a62 F)) - (bcStrings (6 "0.0" a63 F)) - (bcStrings (6 "0.0" a64 F)) - (bcStrings (6 "1.0" a65 F)) - (bcStrings (6 "2.0" a66 F)) - (bcStrings (6 "1.0" a67 F)) - (bcStrings (6 "0.0" a68 F)) - (bcStrings (6 "0.0" a69 F)) - (bcStrings (6 "0.0" a610 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a71 F)) - (bcStrings (6 "0.0" a72 F)) - (bcStrings (6 "0.0" a73 F)) - (bcStrings (6 "0.0" a74 F)) - (bcStrings (6 "0.0" a75 F)) - (bcStrings (6 "1.0" a76 F)) - (bcStrings (6 "2.0" a77 F)) - (bcStrings (6 "1.0" a78 F)) - (bcStrings (6 "0.0" a79 F)) - (bcStrings (6 "0.0" a710 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a81 F)) - (bcStrings (6 "0.0" a82 F)) - (bcStrings (6 "0.0" a83 F)) - (bcStrings (6 "0.0" a84 F)) - (bcStrings (6 "0.0" a85 F)) - (bcStrings (6 "0.0" a86 F)) - (bcStrings (6 "1.0" a87 F)) - (bcStrings (6 "2.0" a88 F)) - (bcStrings (6 "1.0" a89 F)) - (bcStrings (6 "0.0" a810 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a91 F)) - (bcStrings (6 "0.0" a92 F)) - (bcStrings (6 "0.0" a93 F)) - (bcStrings (6 "0.0" a94 F)) - (bcStrings (6 "0.0" a95 F)) - (bcStrings (6 "0.0" a96 F)) - (bcStrings (6 "0.0" a97 F)) - (bcStrings (6 "1.0" a98 F)) - (bcStrings (6 "2.0" a99 F)) - (bcStrings (6 "1.0" a910 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "3.0" a101 F)) - (bcStrings (6 "0.0" a102 F)) - (bcStrings (6 "0.0" a103 F)) - (bcStrings (6 "0.0" a104 F)) - (bcStrings (6 "0.0" a105 F)) - (bcStrings (6 "0.0" a106 F)) - (bcStrings (6 "0.0" a107 F)) - (bcStrings (6 "0.0" a108 F)) - (bcStrings (6 "1.0" a109 F)) - (bcStrings (6 "2.0" a1010 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the matrix {\it m}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "2.0" m11 F)) - (bcStrings (6 "1.0" m12 F)) - (bcStrings (6 "0.0" m13 F)) - (bcStrings (6 "0.0" m14 F)) - (bcStrings (6 "0.0" m15 F)) - (bcStrings (6 "0.0" m16 F)) - (bcStrings (6 "0.0" m17 F)) - (bcStrings (6 "0.0" m18 F)) - (bcStrings (6 "0.0" m19 F)) - (bcStrings (6 "0.0" m110 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.0" m21 F)) - (bcStrings (6 "2.0" m22 F)) - (bcStrings (6 "1.0" m23 F)) - (bcStrings (6 "0.0" m24 F)) - (bcStrings (6 "0.0" m25 F)) - (bcStrings (6 "0.0" m26 F)) - (bcStrings (6 "0.0" m27 F)) - (bcStrings (6 "0.0" m28 F)) - (bcStrings (6 "0.0" m29 F)) - (bcStrings (6 "0.0" m210 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m31 F)) - (bcStrings (6 "1.0" m32 F)) - (bcStrings (6 "2.0" m33 F)) - (bcStrings (6 "1.0" m34 F)) - (bcStrings (6 "0.0" m35 F)) - (bcStrings (6 "0.0" m36 F)) - (bcStrings (6 "0.0" m37 F)) - (bcStrings (6 "0.0" m38 F)) - (bcStrings (6 "0.0" m39 F)) - (bcStrings (6 "0.0" m310 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m41 F)) - (bcStrings (6 "0.0" m42 F)) - (bcStrings (6 "1.0" m43 F)) - (bcStrings (6 "2.0" m44 F)) - (bcStrings (6 "1.0" m45 F)) - (bcStrings (6 "0.0" m46 F)) - (bcStrings (6 "0.0" m47 F)) - (bcStrings (6 "0.0" m48 F)) - (bcStrings (6 "0.0" m49 F)) - (bcStrings (6 "0.0" m410 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m51 F)) - (bcStrings (6 "0.0" m52 F)) - (bcStrings (6 "0.0" m53 F)) - (bcStrings (6 "1.0" m54 F)) - (bcStrings (6 "2.0" m55 F)) - (bcStrings (6 "1.0" m56 F)) - (bcStrings (6 "0.0" m57 F)) - (bcStrings (6 "0.0" m58 F)) - (bcStrings (6 "0.0" m59 F)) - (bcStrings (6 "0.0" m510 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m61 F)) - (bcStrings (6 "0.0" m62 F)) - (bcStrings (6 "0.0" m63 F)) - (bcStrings (6 "0.0" m64 F)) - (bcStrings (6 "1.0" m65 F)) - (bcStrings (6 "2.0" m66 F)) - (bcStrings (6 "1.0" m67 F)) - (bcStrings (6 "0.0" m68 F)) - (bcStrings (6 "0.0" m69 F)) - (bcStrings (6 "0.0" m610 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m71 F)) - (bcStrings (6 "0.0" m72 F)) - (bcStrings (6 "0.0" m73 F)) - (bcStrings (6 "0.0" m74 F)) - (bcStrings (6 "0.0" m75 F)) - (bcStrings (6 "1.0" m76 F)) - (bcStrings (6 "2.0" m77 F)) - (bcStrings (6 "1.0" m78 F)) - (bcStrings (6 "0.0" m79 F)) - (bcStrings (6 "0.0" m710 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m81 F)) - (bcStrings (6 "0.0" m82 F)) - (bcStrings (6 "0.0" m83 F)) - (bcStrings (6 "0.0" m84 F)) - (bcStrings (6 "0.0" m85 F)) - (bcStrings (6 "0.0" m86 F)) - (bcStrings (6 "1.0" m87 F)) - (bcStrings (6 "2.0" m88 F)) - (bcStrings (6 "1.0" m89 F)) - (bcStrings (6 "0.0" m810 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m91 F)) - (bcStrings (6 "0.0" m92 F)) - (bcStrings (6 "0.0" m93 F)) - (bcStrings (6 "0.0" m94 F)) - (bcStrings (6 "0.0" m95 F)) - (bcStrings (6 "0.0" m96 F)) - (bcStrings (6 "0.0" m97 F)) - (bcStrings (6 "1.0" m98 F)) - (bcStrings (6 "2.0" m99 F)) - (bcStrings (6 "1.0" m910 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" m101 F)) - (bcStrings (6 "0.0" m102 F)) - (bcStrings (6 "0.0" m103 F)) - (bcStrings (6 "0.0" m104 F)) - (bcStrings (6 "0.0" m105 F)) - (bcStrings (6 "0.0" m106 F)) - (bcStrings (6 "0.0" m107 F)) - (bcStrings (6 "0.0" m108 F)) - (bcStrings (6 "1.0" m109 F)) - (bcStrings (6 "2.0" m1010 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f04mbfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'precon,precon) - htpSetProperty(page,'shift,shift) - htpSetProperty(page,'rtol,rtol) - htpSetProperty(page,'itnlim,itnlim) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04mbfGen htPage == - n := htpProperty(htPage,'n) - precon := htpProperty(htPage,'precon) - shift := htpProperty(htPage,'shift) - rtol := htpProperty(htPage,'rtol) - itnlim := htpProperty(htPage,'itnlim) - msglvl := htpProperty(htPage,'msglvl) - ifail := htpProperty(htPage,'ifail) - lrwork := '1 - liwork := '1 - alist := htpInputAreaAlist htPage - y := alist - if (precon = 'true) then - for i in 1..n repeat - for j in 1..n repeat - melm := STRCONC((first y).1," ") - mrowlist := [melm,:mrowlist] - y := rest y - matm := [mrowlist,:matm] - mrowlist := [] - mstring := bcwords2liststring [bcwords2liststring x for x in matm] - for k in 1..n repeat - for l in 1..n repeat - aelm := STRCONC((first y).1," ") - arowlist := [aelm,:arowlist] - y := rest y - mata := [arowlist,:mata] - arowlist := [] - astring := bcwords2liststring [bcwords2liststring y for y in mata] - for z in 1..n repeat - belm := STRCONC((first y).1," ") - blist := [belm,:blist] - y := rest y - bstring := bcwords2liststring blist - if (precon = 'false) then - mstring := astring - prefix := STRCONC('"f04mbf(",STRINGIMAGE n,",[",bstring,"]::Matrix DoubleFloat,",precon,",") - prefix := STRCONC(prefix,STRINGIMAGE shift,",",STRINGIMAGE itnlim,",",STRINGIMAGE msglvl,",") - prefix := STRCONC(prefix,STRINGIMAGE lrwork,",",STRINGIMAGE liwork,",") - prefix := STRCONC(prefix,STRINGIMAGE rtol,",",STRINGIMAGE ifail,",((") - prefix := STRCONC(prefix,astring,"::Matrix MachineFloat)::ASP28(APROD)),((") - prefix := STRCONC(prefix,mstring,"::Matrix MachineFloat)::ASP34(MSOLVE)))") - linkGen prefix - - --- f04qaf() == --- htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) --- htMakePage '( --- (domainConditions --- (isDomain EM $EmptyMode) --- (isDomain F (Float))) --- (text . "\windowlink{Manual Page}{manpageXXf04qaf} for this routine ") --- (text . "\newline ") --- (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04qaf| '|NagLinearEquationSolvingPackage|)} for this routine") --- (text . "\newline \horizontalline ") --- (text . "\newline ") --- (text . "F04QAF solves sparse unsymmetric equations, sparse linear ") --- (text . "least-squares problems and sparse damped least-squares ") --- (text . "problems, using a Lanczos algorithm. Specifically, the ") --- (text . "routine can be used to solve a system of linear equations ") --- (text . "{\it Ax=b}, where {\it A} is an {\it n} by {\it n} real ") --- (text . "sparse unsymmetric matrix, or can be used to solve linear ") --- (text . "least-squares problems, so that it minimizes the the value ") --- (text . "{\htbitmap{newrho}} given by {\htbitmap{rho=r}}, ") --- (text . "{\it r=b-AX} where {\it A} is an {\it m} by {\it n} real ") --- (text . "sparse matrix. A damping parameter \lambda may ") --- (text . "be included in the least squares problem in which case the ") --- (text . "routine minimizes the value {\htbitmap{newrho}} given by ") --- (text . "{\htbitmap{rhosq=}}. \newline ") --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "\spadcommand{)read f04qaf \bound{s0}} ")) --- htShowPage() - --- f04mbf() == --- htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) --- htMakePage '( --- (domainConditions --- (isDomain EM $EmptyMode) --- (isDomain F (Float))) --- (text . "\windowlink{Manual Page}{manpageXXf04mbf} for this routine ") --- (text . "\newline ") --- (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mbf| '|NagLinearEquationSolvingPackage|)} for this routine") --- (text . "\newline \horizontalline ") --- (text . "\newline ") --- (text . "\newline ") --- (text . "F04MBF solve a system of real symmetric linear equations ") --- (text . "({\it A} - \lambda {\it I}){\it x} = {\it b} using a Lanczos ") --- (text . "algorithm, where {\it A} is an {\it n} by {\it n} sparse ") --- (text . "symmetric matrix, {\it x} is an {\it n} vector of unknowns ") --- (text . "and {\it b} is an {\it n} element right-hand side vector. ") --- (text . "\blankline") --- (text . "\newline ") --- (text . "\menuitemstyle{}\tab{2} ") --- (text . "\spadcommand{)read f04mbf \bound{s0}} ")) --- htShowPage() - -f04qaf() == - htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain PI (PositiveInteger)) - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXf04qaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04qaf| '|NagLinearEquationSolvingPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F04QAF solves sparse unsymmetric equations, sparse linear ") - (text . "least-squares problems and sparse damped least-squares ") - (text . "problems, using a Lanczos algorithm. Specifically, the ") - (text . "routine can be used to solve a system of linear equations ") - (text . "{\it Ax=b}, where {\it A} is an {\it n} by {\it n} real ") - (text . "sparse unsymmetric matrix, or can be used to solve linear ") - (text . "least-squares problems, so that it minimizes the the value ") - (text . "{\htbitmap{newrho}} given by {\htbitmap{rho=r}}, ") - (text . "{\it r=b-AX} where {\it A} is an {\it m} by {\it n} real ") - (text . "sparse matrix. A damping parameter \lambda may ") - (text . "be included in the least squares problem in which case the ") - (text . "routine minimizes the value {\htbitmap{newrho}} given by ") - (text . "{\htbitmap{rhosq=}}. \newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of rows of the matrix {\it A}, {\it m}:") - (text . "\newline \tab{2}") - (bcStrings (10 13 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the number of columns of the matrix {\it A}, {\it n}:") - (text . "\newline \tab{2}") - (bcStrings (10 12 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the damping parameter \lambda, {\it damp}:") - (text . "\newline \tab{2}") - (bcStrings (10 "0.0" damp F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the tolerance for elements of {\it A}, {\it atol}:") - (text . "\newline \tab{2}") - (bcStrings (10 "0.00001" atol F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the tolerance for elements of {\it b}, {\it btol}:") - (text . "\newline \tab{2}") - (bcStrings (10 "0.0001" btol F)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the maximum number of iterations {\it itnlim}:") - (text . "\newline \tab{2}") - (bcStrings (10 100 itnlim PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the printing level {\it msglvl}:") - (text . "\newline \tab{2}") - (bcStrings (10 1 msglvl PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'f04qafSolve) - htShowPage() - -f04qafSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - damp := htpLabelInputString(htPage,'damp) - atol := htpLabelInputString(htPage,'atol) - btol := htpLabelInputString(htPage,'btol) - itnlim := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itnlim) - objValUnwrap htpLabelSpadValue(htPage, 'itnlim) - msglvl := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'msglvl) - objValUnwrap htpLabelSpadValue(htPage, 'msglvl) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => '1 - '-1 - (m = '13 and n = '12) => f04qafDefaultSolve(htPage,damp,atol,btol,itnlim,msglvl,ifail) - bmatList := - "append"/[f(i) for i in 1..m] where f(i) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i) - [['bcStrings,[6, "0.0", bnam, 'F]]] - amatList := - "append"/[h(ia,n) for ia in 1..m] where h(ia,n) == - alabelList := - "append"/[k(ia,ja) for ja in 1..n] where k(ia,ja) == - anam := INTERN STRCONC ('"a",STRINGIMAGE ia,STRINGIMAGE ja) - [['bcStrings,[6, "0.0", anam, 'F]]] - prefix := ('"\newline \tab{2} ") - alabelList := [['text,:prefix],:alabelList] - start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it A}: ") - amatList := [['text,:start],:amatList] - equationPart := [ - '(domainConditions - (isDomain P (Polynomial $EmptyMode)) - (isDomain F (Float))), - :bmatList,:amatList] - page := htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) - htSay '"\newline \menuitemstyle{}\tab{2} " - htSay '"Enter the right-hand side vector {\it b(m)}: " - htSay '"\newline \tab{2} " - htMakePage equationPart - htSay '"\blankline " - htMakeDoneButton('"Continue",'f04qafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'n,n) - htpSetProperty(page,'damp,damp) - htpSetProperty(page,'atol,atol) - htpSetProperty(page,'btol,btol) - htpSetProperty(page,'itnlim,itnlim) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - - - -f04qafDefaultSolve (htPage,damp,atol,btol,itnlim,msglvl,ifail) == - m := '13 - n := '12 - page := htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the right-hand side vector {\it b(n)}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" b1 F)) - (bcStrings (6 "0.0" b2 F)) - (bcStrings (6 "0.0" b3 F)) - (bcStrings (6 "-0.01" b4 F)) - (bcStrings (6 "-0.01" b5 F)) - (bcStrings (6 "0.0" b6 F)) - (bcStrings (6 "0.0" b7 F)) - (bcStrings (6 "-0.01" b8 F)) - (bcStrings (6 "-0.01" b9 F)) - (bcStrings (6 "0.0" b10 F)) - (bcStrings (6 "0.0" b11 F)) - (bcStrings (6 "0.0" b12 F)) - (bcStrings (6 "10.0" b13 F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2} ") - (text . "Enter the matrix {\it A}: ") - (text . "\newline \tab{2} ") - (bcStrings (6 "1.0" a0101 F)) - (bcStrings (6 "0.0" a0102 F)) - (bcStrings (6 "0.0" a0103 F)) - (bcStrings (6 "-1.0" a0104 F)) - (bcStrings (6 "0.0" a0105 F)) - (bcStrings (6 "0.0" a0106 F)) - (bcStrings (6 "0.0" a0107 F)) - (bcStrings (6 "0.0" a0108 F)) - (bcStrings (6 "0.0" a0109 F)) - (bcStrings (6 "0.0" a0110 F)) - (bcStrings (6 "0.0" a0111 F)) - (bcStrings (6 "0.0" a0112 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0201 F)) - (bcStrings (6 "1.0" a0202 F)) - (bcStrings (6 "0.0" a0203 F)) - (bcStrings (6 "0.0" a0204 F)) - (bcStrings (6 "-1.0" a0205 F)) - (bcStrings (6 "0.0" a0206 F)) - (bcStrings (6 "0.0" a0207 F)) - (bcStrings (6 "0.0" a0208 F)) - (bcStrings (6 "0.0" a0209 F)) - (bcStrings (6 "0.0" a0210 F)) - (bcStrings (6 "0.0" a0211 F)) - (bcStrings (6 "0.0" a0212 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0301 F)) - (bcStrings (6 "0.0" a0302 F)) - (bcStrings (6 "1.0" a0303 F)) - (bcStrings (6 "-1.0" a0304 F)) - (bcStrings (6 "0.0" a0305 F)) - (bcStrings (6 "0.0" a0306 F)) - (bcStrings (6 "0.0" a0307 F)) - (bcStrings (6 "0.0" a0308 F)) - (bcStrings (6 "0.0" a0309 F)) - (bcStrings (6 "0.0" a0310 F)) - (bcStrings (6 "0.0" a0311 F)) - (bcStrings (6 "0.0" a0312 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "-1.0" a0401 F)) - (bcStrings (6 "0.0" a0402 F)) - (bcStrings (6 "-1.0" a0403 F)) - (bcStrings (6 "4.0" a0404 F)) - (bcStrings (6 "-1.0" a0405 F)) - (bcStrings (6 "0.0" a0406 F)) - (bcStrings (6 "0.0" a0407 F)) - (bcStrings (6 "-1.0" a0408 F)) - (bcStrings (6 "0.0" a0409 F)) - (bcStrings (6 "0.0" a0410 F)) - (bcStrings (6 "0.0" a0411 F)) - (bcStrings (6 "0.0" a0412 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0501 F)) - (bcStrings (6 "-1.0" a0502 F)) - (bcStrings (6 "0.0" a0503 F)) - (bcStrings (6 "-1.0" a0504 F)) - (bcStrings (6 "4.0" a0505 F)) - (bcStrings (6 "-1.0" a0506 F)) - (bcStrings (6 "0.0" a0507 F)) - (bcStrings (6 "0.0" a0508 F)) - (bcStrings (6 "-1.0" a0509 F)) - (bcStrings (6 "0.0" a0510 F)) - (bcStrings (6 "0.0" a0511 F)) - (bcStrings (6 "0.0" a0512 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0601 F)) - (bcStrings (6 "0.0" a0602 F)) - (bcStrings (6 "0.0" a0603 F)) - (bcStrings (6 "0.0" a0604 F)) - (bcStrings (6 "-1.0" a0605 F)) - (bcStrings (6 "1.0" a0606 F)) - (bcStrings (6 "0.0" a0607 F)) - (bcStrings (6 "0.0" a0608 F)) - (bcStrings (6 "0.0" a0609 F)) - (bcStrings (6 "0.0" a0610 F)) - (bcStrings (6 "0.0" a0611 F)) - (bcStrings (6 "0.0" a0612 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0701 F)) - (bcStrings (6 "0.0" a0702 F)) - (bcStrings (6 "0.0" a0703 F)) - (bcStrings (6 "0.0" a0704 F)) - (bcStrings (6 "0.0" a0705 F)) - (bcStrings (6 "0.0" a0706 F)) - (bcStrings (6 "1.0" a0707 F)) - (bcStrings (6 "-1.0" a0708 F)) - (bcStrings (6 "0.0" a0709 F)) - (bcStrings (6 "0.0" a0710 F)) - (bcStrings (6 "0.0" a0711 F)) - (bcStrings (6 "0.0" a0712 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0801 F)) - (bcStrings (6 "0.0" a0802 F)) - (bcStrings (6 "0.0" a0803 F)) - (bcStrings (6 "-1.0" a0804 F)) - (bcStrings (6 "0.0" a0805 F)) - (bcStrings (6 "0.0" a0806 F)) - (bcStrings (6 "-1.0" a0807 F)) - (bcStrings (6 "4.0" a0808 F)) - (bcStrings (6 "-1.0" a0809 F)) - (bcStrings (6 "0.0" a0810 F)) - (bcStrings (6 "-1.0" a0811 F)) - (bcStrings (6 "0.0" a0812 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a0901 F)) - (bcStrings (6 "0.0" a0902 F)) - (bcStrings (6 "0.0" a0903 F)) - (bcStrings (6 "0.0" a0904 F)) - (bcStrings (6 "-1.0" a0905 F)) - (bcStrings (6 "0.0" a0906 F)) - (bcStrings (6 "0.0" a0907 F)) - (bcStrings (6 "-1.0" a0908 F)) - (bcStrings (6 "4.0" a0909 F)) - (bcStrings (6 "-1.0" a0910 F)) - (bcStrings (6 "0.0" a0911 F)) - (bcStrings (6 "-1.0" a0912 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a1001 F)) - (bcStrings (6 "0.0" a1002 F)) - (bcStrings (6 "0.0" a1003 F)) - (bcStrings (6 "0.0" a1004 F)) - (bcStrings (6 "0.0" a1005 F)) - (bcStrings (6 "0.0" a1006 F)) - (bcStrings (6 "0.0" a1007 F)) - (bcStrings (6 "0.0" a1008 F)) - (bcStrings (6 "-1.0" a1009 F)) - (bcStrings (6 "1.0" a1010 F)) - (bcStrings (6 "0.0" a1011 F)) - (bcStrings (6 "0.0" a1012 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a1101 F)) - (bcStrings (6 "0.0" a1102 F)) - (bcStrings (6 "0.0" a1103 F)) - (bcStrings (6 "0.0" a1104 F)) - (bcStrings (6 "0.0" a1105 F)) - (bcStrings (6 "0.0" a1106 F)) - (bcStrings (6 "0.0" a1107 F)) - (bcStrings (6 "-1.0" a1108 F)) - (bcStrings (6 "0.0" a1109 F)) - (bcStrings (6 "0.0" a1110 F)) - (bcStrings (6 "1.0" a1111 F)) - (bcStrings (6 "0.0" a1112 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "0.0" a1201 F)) - (bcStrings (6 "0.0" a1202 F)) - (bcStrings (6 "0.0" a1203 F)) - (bcStrings (6 "0.0" a1204 F)) - (bcStrings (6 "0.0" a1205 F)) - (bcStrings (6 "0.0" a1206 F)) - (bcStrings (6 "0.0" a1207 F)) - (bcStrings (6 "0.0" a1208 F)) - (bcStrings (6 "-1.0" a1209 F)) - (bcStrings (6 "0.0" a1210 F)) - (bcStrings (6 "0.0" a1211 F)) - (bcStrings (6 "1.0" a1212 F)) - (text . "\newline \tab{2} ") - (bcStrings (6 "1.0" a1301 F)) - (bcStrings (6 "1.0" a1302 F)) - (bcStrings (6 "1.0" a1303 F)) - (bcStrings (6 "0.0" a1304 F)) - (bcStrings (6 "0.0" a1305 F)) - (bcStrings (6 "1.0" a1306 F)) - (bcStrings (6 "1.0" a1307 F)) - (bcStrings (6 "0.0" a1308 F)) - (bcStrings (6 "0.0" a1309 F)) - (bcStrings (6 "1.0" a1310 F)) - (bcStrings (6 "1.0" a1311 F)) - (bcStrings (6 "1.0" a1312 F)) - (text . "\blankline ")) - htMakeDoneButton('"Continue",'f04qafGen) - htpSetProperty(page,'m,m) - htpSetProperty(page,'n,n) - htpSetProperty(page,'damp,damp) - htpSetProperty(page,'atol,atol) - htpSetProperty(page,'btol,btol) - htpSetProperty(page,'itnlim,itnlim) - htpSetProperty(page,'msglvl,msglvl) - htpSetProperty(page,'ifail,ifail) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f04qafGen htPage == - m := htpProperty(htPage,'m) - n := htpProperty(htPage,'n) - damp := htpProperty(htPage,'damp) - atol := htpProperty(htPage,'atol) - btol := htpProperty(htPage,'btol) - divisor := READ_-FROM_-STRING(atol) - if (divisor < 1.0e-7) then divisor:=1.0e-7 - conlim := 1.0/divisor - itnlim := htpProperty(htPage,'itnlim) - msglvl := htpProperty(htPage,'msglvl) - ifail := htpProperty(htPage,'ifail) - lrwork := 1 - liwork := 1 - alist := htpInputAreaAlist htPage - y := alist - for k in 1..m repeat - for l in 1..n repeat - aelm := STRCONC((first y).1," ") - arowlist := [aelm,:arowlist] - y := rest y - mata := [arowlist,:mata] - arowlist := [] - astring := bcwords2liststring [bcwords2liststring y for y in mata] - for z in 1..m repeat - belm := STRCONC((first y).1," ") - blist := [belm,:blist] - y := rest y - bstring := bcwords2liststring blist - prefix := STRCONC('"f04qaf(",STRINGIMAGE m,",",STRINGIMAGE n,",") - prefix := STRCONC(prefix,STRINGIMAGE damp,",") - prefix := STRCONC(prefix,STRINGIMAGE atol,",",STRINGIMAGE btol,",") - prefix := STRCONC(prefix,STRINGIMAGE conlim,",",STRINGIMAGE itnlim,",",STRINGIMAGE msglvl,",") - prefix := STRCONC(prefix,STRINGIMAGE lrwork,",",STRINGIMAGE liwork,",") - prefix := STRCONC(prefix,"[",bstring,"]::Matrix DoubleFloat,") - prefix := STRCONC(prefix,STRINGIMAGE ifail,",((",astring,"::Matrix MachineFloat)::ASP30(APROD)))") - linkGen prefix - - - - - diff --git a/src/interp/nag-f04.boot.pamphlet b/src/interp/nag-f04.boot.pamphlet new file mode 100644 index 00000000..da36ae78 --- /dev/null +++ b/src/interp/nag-f04.boot.pamphlet @@ -0,0 +1,2331 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-f04.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +f04adf() == + htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain I (Integer))) + (text . "\windowlink{Manual Page}{manpageXXf04adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04adf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Calculates the approximate solution of a set of complex linear ") + (text . "equations {\it AX = B} using an {\it LU} factorization with ") + (text . "partial pivoting, where {\it A} is an n * n matrix, {\it X} is ") + (text . "an {\it n} by {\it m} matrix of unknowns and {\it B} is an ") + (text . "{\it n} by {\it m} matrix of right-hand sides.") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "{\it n} order of matrix A:") + (text . "\tab{28} \menuitemstyle{}\tab{30} ") + (text . "{\it m} number of right-hand sides \htbitmap{great=} 0 :") + (text . "\newline\tab{2} ") + (bcStrings (10 3 n I)) + (text . "\tab{30} ") + (bcStrings (10 1 m I)) +-- (text . "\blankline ") +-- (text . "\newline \menuitemstyle{}\tab{2} ") +-- (text . "{\it IA} first dimension of A:") +-- (text . "\tab{32} \menuitemstyle{}\tab{34} ") +-- (text . "{\it IB} first dimension of B:") +-- (text . "\newline\tab{2} ") +-- (bcStrings (10 3 ia I)) +-- (text . "\tab{34} ") +-- (bcStrings (10 3 ib I)) +-- (text . "\blankline ") +-- (text . "\newline \menuitemstyle{}\tab{2} ") +-- (text . "{\it IC} first dimension of C:") +-- (text . "\newline\tab{2} ") +-- (bcStrings (10 3 ic I)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04adfSolve) + htShowPage() + +f04adfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + ib := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ib) +-- objValUnwrap htpLabelSpadValue(htPage, 'ib) + ic := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ic) +-- objValUnwrap htpLabelSpadValue(htPage, 'ic) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '3 and m = '1) => f04adfDefaultSolve(htPage,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + ianam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[12, "0.0 + 0.0*%i", ianam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[fb(i,m) for i in 1..ib] where fb(i,m) == + blabelList := + "append"/[gb(i,j) for j in 1..m] where gb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[12, "0.0 + 0.0*%i", bnam, 'F]]] + prefix := ('"\newline \tab{2} ") + blabelList := [['text,:prefix],:blabelList] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :matList,:bmatList] + page := htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04adfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'ic,ic) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + +f04adfDefaultSolve (htPage, ifail) == + n := '3 + m := '1 + ia := '3 + ib := '3 + ic := '3 + page := htInitPage("F04ADF - Solution of complex simultaneous linear equations, with multiple right-hand sides (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (12 "1" a11 F)) + (bcStrings (12 "1 + 2*%i" a12 F)) + (bcStrings (12 "2 + 10*%i" a13 F)) + (text . "\newline \tab{2} ") + (bcStrings (12 "1 + %i" a21 F)) + (bcStrings (12 "3*%i" a22 F)) + (bcStrings (12 "-5 + 14*%i" a23 F)) + (text . "\newline \tab{2} ") + (bcStrings (12 "1 + %i" a31 F)) + (bcStrings (12 "5*%i" a32 F)) + (bcStrings (12 "-8 + 20*%i" a33 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (12 "1" b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (12 "0" b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (12 "0" b3 F))) + htMakeDoneButton('"Continue",'f04adfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'ib,ib) +-- htpSetProperty(page,'ic,ic) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04adfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- ia := htpProperty(htPage,'ia) +-- ib := htpProperty(htPage,'ib) +-- ic := htpProperty(htPage,'ic) + ia := n + ib := n + ic := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + -- will probably need to change this as its a vector not an array + for i in 1..m repeat + for j in 1..ib repeat + right := STRCONC((first y).1," ") + y := rest y + bList := [right,:bList] + bstring := bcwords2liststring bList + boutList := [bstring,:boutList] + bList := [] + boutstring := bcwords2liststring boutList + y := REVERSE y + k := -1 + matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f04adf(",STRINGIMAGE ia,",",boutstring,",") + prefix := STRCONC(prefix,STRINGIMAGE ib,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE m,", ",STRINGIMAGE ic) + prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") + bcGen prefix + +f04arf() == + htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain I (Integer))) + (text . "\windowlink{Manual Page}{manpageXXf04arf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04arf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates the approximate solution of a set of real linear ") + (text . "equations {\it Ax = b} using an {\it LU} factorization with ") + (text . "pivoting, where {\it A} is an n * n matrix, {\it x} is an n ") + (text . "element vector of unknowns and {\it b} is an n element ") + (text . "right-hand side vector.") + (text . "\blankline ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") +-- (text . "{\it IA} first dimension of A:") +-- (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\it n} order of matrix A:") + (text . "\newline\tab{2} ") +-- (bcStrings (10 8 ia I)) +-- (text . "\tab{34} ") + (bcStrings (10 3 n I)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04arfSolve) + htShowPage() + +f04arfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '3 => f04arfDefaultSolve(htPage,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", ianam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k) for k in 1..n] where h(k) == + prefix := ('"\newline \tab{2} ") + bnam := INTERN STRCONC ('"b",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :matList,:bmatList] + page := htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04arfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + +f04arfDefaultSolve (htPage, ifail) == + n := '3 + ia := '3 + page := htInitPage("F04ARF - Solution of real simultaneous linear equations, one right-hand side (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 33 ia11 F)) + (bcStrings (6 16 ia12 F)) + (bcStrings (6 72 ia13 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-24" ia21 F)) + (bcStrings (6 "-10" ia22 F)) + (bcStrings (6 "-57" ia23 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-8" ia31 F)) + (bcStrings (6 "-4" ia32 F)) + (bcStrings (6 "-17" ia33 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia41 F)) +-- (bcStrings (6 0 ia42 F)) +-- (bcStrings (6 0 ia43 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia51 F)) +-- (bcStrings (6 0 ia52 F)) +-- (bcStrings (6 0 ia53 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia61 F)) +-- (bcStrings (6 0 ia62 F)) +-- (bcStrings (6 0 ia63 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia71 F)) +-- (bcStrings (6 0 ia72 F)) +-- (bcStrings (6 0 ia73 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia81 F)) +-- (bcStrings (6 0 ia82 F)) +-- (bcStrings (6 0 ia83 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-359" b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "281" b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "85" b3 F))) + htMakeDoneButton('"Continue",'f04arfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04arfGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) + ia := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + right := STRCONC((first y).1," ") + y := rest y + bList := [right,:bList] + bstring := bcwords2liststring bList + y := REVERSE y + k := -1 + matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f04arf(",STRINGIMAGE ia,", [",bstring,"],",STRINGIMAGE n) + prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") + bcGen prefix + +f04asf() == + htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain I (Integer))) + (text . "\windowlink{Manual Page}{manpageXXf04asf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04asf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates the accurate solution of a set of real symmetric ") + (text . "positive-definite linear equations {\it Ax = b} using an a ") + (text . "Cholesky factorization and iterative refinement, ") + (text . "where {\it A} is an n * n matrix, {\it x} is an n ") + (text . "element vector of unknowns and {\it b} is an n element ") + (text . "right-hand side vector.") + (text . "\blankline ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") +-- (text . "{\it IA} first dimension of A:") +-- (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\it n} order of matrix A:") + (text . "\newline\tab{2} ") +-- (bcStrings (10 8 ia I)) +-- (text . "\tab{34} ") + (bcStrings (10 4 n I)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04asfSolve) + htShowPage() + +f04asfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 +-- (n = '4 and ia = '8) => f04asfDefaultSolve(htPage,ifail) + n = '4 => f04asfDefaultSolve(htPage,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", ianam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k) for k in 1..n] where h(k) == + prefix := ('"\newline \tab{2} ") + bnam := INTERN STRCONC ('"b",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :matList,:bmatList] + page := htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04asfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + +f04asfDefaultSolve (htPage, ifail) == + n := '4 + ia := '4 + page := htInitPage("F04ASF - Solution of real symmetric positive-definite simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 5 ia11 F)) + (bcStrings (6 7 ia12 F)) + (bcStrings (6 6 ia13 F)) + (bcStrings (6 5 ia14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 7 ia21 F)) + (bcStrings (6 10 ia22 F)) + (bcStrings (6 8 ia23 F)) + (bcStrings (6 7 ia24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 6 ia31 F)) + (bcStrings (6 8 ia32 F)) + (bcStrings (6 10 ia33 F)) + (bcStrings (6 9 ia34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 5 ia41 F)) + (bcStrings (6 7 ia42 F)) + (bcStrings (6 9 ia43 F)) + (bcStrings (6 10 ia44 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia51 F)) +-- (bcStrings (6 0 ia52 F)) +-- (bcStrings (6 0 ia53 F)) +-- (bcStrings (6 0 ia54 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia61 F)) +-- (bcStrings (6 0 ia62 F)) +-- (bcStrings (6 0 ia63 F)) +-- (bcStrings (6 0 ia64 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia71 F)) +-- (bcStrings (6 0 ia72 F)) +-- (bcStrings (6 0 ia73 F)) +-- (bcStrings (6 0 ia74 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia81 F)) +-- (bcStrings (6 0 ia82 F)) +-- (bcStrings (6 0 ia83 F)) +-- (bcStrings (6 0 ia84 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 23 b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 32 b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 33 b3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 31 b4 F))) + htMakeDoneButton('"Continue",'f04asfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04asfGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) + ia := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + right := STRCONC((first y).1," ") + y := rest y + bList := [right,:bList] + bstring := bcwords2liststring bList + y := REVERSE y + k := -1 + matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f04asf(",STRINGIMAGE ia,", [",bstring,"],",STRINGIMAGE n) + prefix := STRCONC(prefix,", ",matstring,", ",STRINGIMAGE ifail,")") + bcGen prefix + +f04atf() == + htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain I (Integer))) + (text . "\windowlink{Manual Page}{manpageXXf04atf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04atf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates the approximate solution of a set of real linear ") + (text . "equations {\it Ax = b} using an {\it LU} factorization with ") + (text . "pivoting and iterative refinement, ") + (text . "where {\it A} is an n * n matrix, {\it x} is an n ") + (text . "element vector of unknowns and {\it b} is an n element ") + (text . "right-hand side vector.") + (text . "\blankline ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") +-- (text . "{\it IA} first dimension of A:") +-- (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "{\it n} order of matrix A:") + (text . "\newline\tab{2} ") +-- (bcStrings (10 8 ia I)) +-- (text . "\tab{34} ") + (bcStrings (10 3 n I)) +-- (text . "\blankline ") +-- (text . "\newline \menuitemstyle{} \tab{2} ") +-- (text . "{\it IAA} first dimension of AA:") +-- (text . "\newline \tab{2} ") +-- (bcStrings (10 8 iaa I)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{} \tab{2} ") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04atfSolve) + htShowPage() + +f04atfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + ia := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ia) +-- objValUnwrap htpLabelSpadValue(htPage, 'ia) + iaa := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'iaa) +-- objValUnwrap htpLabelSpadValue(htPage, 'iaa) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 +-- (n = '3 and ia = '8) => f04atfDefaultSolve(htPage,iaa,ifail) + n = '3 => f04atfDefaultSolve(htPage,iaa,ifail) + matList := + "append"/[f(i,n) for i in 1..ia] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + ianam := INTERN STRCONC ('"ia",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", ianam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k) for k in 1..n] where h(k) == + prefix := ('"\newline \tab{2} ") + bnam := INTERN STRCONC ('"b",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :matList,:bmatList] + page := htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04atfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iaa,iaa) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + +f04atfDefaultSolve (htPage, iaa, ifail) == + n := '3 + ia := '3 + page := htInitPage("F04ATF - Solution of real simultaneous linear equations, one right-hand side using iterative refinement (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 33 ia11 F)) + (bcStrings (6 16 ia12 F)) + (bcStrings (6 72 ia13 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-24" ia21 F)) + (bcStrings (6 "-10" ia22 F)) + (bcStrings (6 "-57" ia23 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-8" ia31 F)) + (bcStrings (6 "-4" ia32 F)) + (bcStrings (6 "-17" ia33 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia41 F)) +-- (bcStrings (6 0 ia42 F)) +-- (bcStrings (6 0 ia43 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia51 F)) +-- (bcStrings (6 0 ia52 F)) +-- (bcStrings (6 0 ia53 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia61 F)) +-- (bcStrings (6 0 ia62 F)) +-- (bcStrings (6 0 ia63 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia71 F)) +-- (bcStrings (6 0 ia72 F)) +-- (bcStrings (6 0 ia73 F)) +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 0 ia81 F)) +-- (bcStrings (6 0 ia82 F)) +-- (bcStrings (6 0 ia83 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "-359" b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "281" b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "85" b3 F))) + htMakeDoneButton('"Continue",'f04atfGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'ia,ia) +-- htpSetProperty(page,'iaa,iaa) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04atfGen htPage == + n := htpProperty(htPage,'n) +-- ia := htpProperty(htPage,'ia) +-- iaa := htpProperty(htPage,'iaa) + ia := n + iaa := n + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + right := STRCONC((first y).1," ") + y := rest y + bList := [right,:bList] + bstring := bcwords2liststring bList + y := REVERSE y + k := -1 + matform := [[y.(k := k + 1).1 for j in 0..(n-1)] for i in 0..(ia-1)] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f04atf(",matstring,", ",STRINGIMAGE ia,", [",bstring) + prefix := STRCONC(prefix,"],",STRINGIMAGE n,", ",STRINGIMAGE iaa,", ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + bcGen prefix + + +f04faf() == + htInitPage('"F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf04adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04faf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Calculates the approximate solution of a set of real symmetric ") + (text . "positive-definite tridiagonal linear equations {\it Tx = b} ") + (text . "using a modified symmetric Gaussian Elimination algorithm, ") + (text . "where {\it T} is an n * n matrix, {\it x} is an n ") + (text . "element vector of unknowns and {\it b} is an n element ") + (text . "right-hand side vector. {\it T} is factorized as ") + (text . "\inputbitmap{\htbmdir{}/mkm.bitmap}, where {\it K} is a diagonal matrix ") + (text . "and {\it M} is a matrix of multipliers. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "{\it JOB} to be performed by f04faf: ") + (radioButtons job + ("" " = 0. {\it T} is factorized and equations {\it Tx = b} are solved for x." jobZero) + ("" " = 1. {\it T} assumed to be already factorized by previous call to f04faf, the equations {\it Tx = b} are solved for x." jobOne)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Order of the matrix T {\it n}:") + (text . "\newline \tab{2} ") + (bcStrings (6 5 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04fafSolve) + htShowPage() + +f04fafSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + number := htpButtonValue(htPage,'job) + job := + number = 'jobOne => '1 + '0 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + n = '5 => f04fafDefaultSolve(htPage,job,ifail) + dList := + "append"/[f(i) for i in 1..n] where f(i) == + prefix := ('"\newline \tab{2} ") + dnam := INTERN STRCONC ('"d",STRINGIMAGE i) + [['text,:prefix],['bcStrings,[10, 0.0, dnam, 'F]]] + prefix := ('"\menuitemstyle{}\tab{2} {\it D} Diagonal elements of T: ") + prefix := STRCONC(prefix,"\newline \tab{2} ") + dList := [['text,:prefix],:dList] + eList := + "append"/[g(j) for j in 1..(n-1)] where g(j) == + prefix := ('"\newline \tab{2} ") + enam := INTERN STRCONC ('"e",STRINGIMAGE j) + [['text,:prefix],['bcStrings,[10, 0.0, enam, 'F]]] + prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} {\it E} E(2) ") + prefix := STRCONC(prefix,"to E(N)\newline \tab{2} Job = 0 => super-diagonal") + prefix := STRCONC(prefix," elements of {\it T}. \newline \tab{2} Job = 1 =>") + prefix := STRCONC(prefix," off-diagonal elements of {\it M} from previous ") + prefix := STRCONC(prefix,"call to F04FAF. ") + eList := [['text,:prefix],:eList] + bList := + "append"/[h(k) for k in 1..n] where h(k) == + prefix := ('"\newline \tab{2} ") + bnam := INTERN STRCONC ('"b",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[10, 0.0, bnam, 'F]]] + prefix := ('"\blankline \newline \menuitemstyle{}\tab{2} {\it B} Right-hand") + prefix := STRCONC(prefix," side vector b: ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :dList,:eList,:bList] + page := htInitPage("F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) + htMakePage equationPart + htMakeDoneButton('"Continue",'f04fafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'job,job) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f04fafDefaultSolve (htPage,job,ifail) == + n := '5 + page := htInitPage('"F04FAF - Solution of real symmetric positive-definite tridiagonal simultaneous linear equations, one right-hand side (Black box)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} {\it D} Diagonal elements of T:") + (text . "\newline \tab{2} ") + (bcStrings (10 4 d1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 10 d2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 29 d3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 25 d4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 5 d5 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} {\it E}\space{1} E(2) to E(N) ") + (text . "\newline \tab{2} ") + (text . "Job = 0 => super-diagonal elements of {\it T}. \newline \tab{2}") + (text . "Job = 1 => off-diagonal elements of {\it M} from ") + (text . "previous call to F04FAF \newline \tab{2} ") + (bcStrings (10 "-2" e2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 "-6" e3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 15 e4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 8 e5 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} {\it B} Right-hand side vector b:") + (text . "\newline \tab{2} ") + (bcStrings (10 6 b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 9 b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 2 b3 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 14 b4 F)) + (text . "\newline \tab{2} ") + (bcStrings (10 7 b5 F))) + htMakeDoneButton('"Continue",'f04fafGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'job,job) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04fafGen htPage == + n := htpProperty(htPage,'n) + job := htpProperty(htPage,'job) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + b := STRCONC((first y).1," ") + bList := [b,:bList] + y := rest y + bstring := bcwords2liststring bList + for i in 1..(n-1) repeat + e := STRCONC((first y).1," ") + eList := [e,:eList] + y := rest y + eList := ['"0",:eList] + estring := bcwords2liststring eList + for i in 1..n repeat + d := STRCONC((first y).1," ") + dList := [d,:dList] + y := rest y + dstring := bcwords2liststring dList + prefix := STRCONC('"f04faf(",STRINGIMAGE job,", ",STRINGIMAGE n,",[") + prefix := STRCONC(prefix,dstring,"], [",estring,"], [",bstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + bcGen prefix + + +f04jgf() == + htInitPage('"F04JGF - Least-squares (if rank = n) or minimal least-squares (if rank < n) solution of m real equations in n unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} it n, m \inputbitmap{\htbmdir{}/great=.bitmap} n",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf04jgf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04jgf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Finds the solution of a linear least squares problem {\it Ax=b},") + (text . " where A is a real m by n matrix, (m \inputbitmap{\htbmdir{}/great=.bitmap}") + (text . " n), x is an n element vector of unknowns and b is an m element ") + (text . "right-hand side vector. The routine uses a QU factorization if ") + (text . "rank A = n and the SVD if A < n. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline Rows of matrix A, {\it m}: ") + (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Columns of matrix A, {\it n}: \newline \tab{2} ") + (bcStrings (6 6 m PI)) + (text . "\tab{34} ") + (bcStrings (6 4 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") +-- (text . "\newline First dimension of A, {\it nra}: ") +-- (text . "\tab{32} \menuitemstyle{} \tab{34} ") + (text . "Tolerance, {\it tol}: ") + (text . "\newline \tab{2} ") +-- (bcStrings (6 8 nra PI)) +-- (text . "\tab{34} ") + (bcStrings (8 "5.0e-4" tol F)) +-- (text . "\blankline ") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Dimension of workspace array {\it lwork}: ") +-- (text . "\newline \tab{2} ") +-- (bcStrings (6 32 lwork PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04jgfSolve) + htShowPage() + +f04jgfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nra := m +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nra) +-- objValUnwrap htpLabelSpadValue(htPage, 'nra) + lwork := 4*n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lwork) +-- objValUnwrap htpLabelSpadValue(htPage, 'lwork) + tol := htpLabelInputString(htPage,'tol) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '6 and n = '4) => f04jgfDefaultSolve(htPage,nra,lwork,tol,ifail) + matList := + "append"/[f(i,n) for i in 1..m] where f(i,n) == + labelList := + "append"/[g(i,j) for j in 1..n] where g(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + labelList := [['text,:prefix],:labelList] + bmatList := + "append"/[h(k) for k in 1..m] where h(k) == + prefix := ('"\newline \tab{2} ") + bnam := INTERN STRCONC ('"b",STRINGIMAGE k) + [['text,:prefix],['bcStrings,[6, "0.0", bnam, 'F]]] + start := ('"\blankline \menuitemstyle{} \tab{2} Enter values of {\it b}:") + bmatList := [['text,:start],:bmatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :matList,:bmatList] + page := htInitPage("F04JGF - Least-squares (if rank = {\it n}) or minimal least-squares (if rank < {\it n}) solution of {\it m} real equations in {\it n} unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} {\it n}, {\it m} \inputbitmap{\htbmdir{}/great=.bitmap} {\it n}",nil) + htSay '"\newline \menuitemstyle{}\tab{2} Enter values of {\it A}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04jgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'nra,nra) +-- htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f04jgfDefaultSolve (htPage,nra,lwork,tol,ifail) == + n := '4 + m := '6 + page := htInitPage('"F04JGF - Least-squares (if rank = n) or minimal least-squares (if rank < n) solution of m real equations in n unknowns, rank \inputbitmap{\htbmdir{}/less=.bitmap} n, m \inputbitmap{\htbmdir{}/great=.bitmap} n",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.05" a11 F)) + (bcStrings (6 "0.05" a12 F)) + (bcStrings (6 "0.25" a13 F)) + (bcStrings (6 "-0.25" a14 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.25" a21 F)) + (bcStrings (6 "0.25" a22 F)) + (bcStrings (6 "0.05" a23 F)) + (bcStrings (6 "-0.05" a24 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.35" a31 F)) + (bcStrings (6 "0.35" a32 F)) + (bcStrings (6 "1.75" a33 F)) + (bcStrings (6 "-1.75" a34 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.75" a41 F)) + (bcStrings (6 "1.75" a42 F)) + (bcStrings (6 "0.35" a43 F)) + (bcStrings (6 "-0.35" a44 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.30" a51 F)) + (bcStrings (6 "-0.30" a52 F)) + (bcStrings (6 "0.30" a53 F)) + (bcStrings (6 "0.30" a54 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.40" a61 F)) + (bcStrings (6 "-0.40" a62 F)) + (bcStrings (6 "0.40" a63 F)) + (bcStrings (6 "0.40" a64 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Enter values of {\it b}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 1 b1 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 2 b2 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 3 b3 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 4 b4 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 5 b5 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 6 b6 F))) + htMakeDoneButton('"Continue",'f04jgfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'nra,nra) +-- htpSetProperty(page,'lwork,lwork) + htpSetProperty(page,'tol,tol) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04jgfGen htPage == + n := htpProperty(htPage,'n) + m := htpProperty(htPage,'m) +-- nra := htpProperty(htPage,'nra) +-- lwork := htpProperty(htPage,'lwork) + nra := m + lwork := 4*n + tol := htpProperty(htPage,'tol) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..m repeat + b := STRCONC((first y).1," ") + bList := [b,:bList] + y := rest y + bstring := bcwords2liststring bList + y := REVERSE y + for i in 1..m repeat + for j in 1..n repeat + elm := STRCONC((first y).1," ") + rowList := [:rowList,elm] + y := rest y + matform := [:matform,rowList] + rowList := [] + for i in 1..n repeat + null := STRCONC('"0.0"," ") + nullList := [:nullList,null] + for i in m..(nra-1) repeat + matform := [:matform,nullList] + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + prefix := STRCONC('"f04jgf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE nra,", ",tol,", ",STRINGIMAGE lwork) + prefix := STRCONC(prefix,", ",matstring,", [",bstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE ifail,")") + bcGen prefix + +f04mcf() == + htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf04mcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mcf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "Computes the approximate solution of a system of real linear ") + (text . "equations AX = B, where the n by n symmetric positive-definite ") + (text . "variable-bandwidth matrix A has previously been factorized as ") + (text . "\htbitmap{ldlt} by F01MCF, X is an n by r matrix of unknowns ") + (text . "and B is an n by r matrix of right-hand sides. Related systems ") + (text . "may also be solved. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the order of the matrix A, {\it n} ") + (text ."\htbitmap{great=} 1:") + (text . "\newline\tab{2} ") + (bcStrings (9 6 n PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Enter the dimension of AL, {\it lal}: ") + (text . "\newline\tab{2} ") + (bcStrings (9 14 lal PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "\newline Enter the number of right-hand sides, {\it ir}: ") + (text . "\newline\tab{2} ") + (bcStrings (9 2 ir PI)) +-- (text . "\blankline") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Enter the first dimension of B, {\it nrb}: ") +-- (text . "\newline\tab{2} ") +-- (bcStrings (9 6 nrb PI)) +-- (text . "\blankline") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\newline Enter the first dimension of X, {\it nrx}: ") +-- (text . "\newline\tab{2} ") +-- (bcStrings (9 6 nrx PI)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Type of system to be solved, {\it iselct}:") + (radioButtons iselct + ("" " {\em \htbitmap{ldlt}X = B} is solved" selone) + ("" " {\em LDX = B} is solved" seltwo) + ("" " {\em D\htbitmap{lt}X = B} is solved" selthree) + ("" " {\em L\htbitmap{lt}X = B} is solved" selfour) + ("" " {\em LX = B} is solved" selfive) + ("" " {\em \htbitmap{lt}X = B} is solved" selsix)) + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04mcfSolve) + htShowPage() + +f04mcfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lal := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lal) + objValUnwrap htpLabelSpadValue(htPage, 'lal) + ir := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ir) + objValUnwrap htpLabelSpadValue(htPage, 'ir) + nrb := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrb) +-- objValUnwrap htpLabelSpadValue(htPage, 'nrb) + nrx := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrx) +-- objValUnwrap htpLabelSpadValue(htPage, 'nrx) + select := htpButtonValue(htPage,'iselct) + iselct := + select = 'selone => '1 + select = 'seltwo => '2 + select = 'selthree => '3 + select = 'selfour => '4 + select = 'selfive => '5 + '6 + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '6 and lal = '14 and ir = '2) => f04mcfDefaultSolve(htPage,iselct,ifail) + labelList := + "append"/[fal(i) for i in 1..lal] where fal(i) == + xnam := INTERN STRCONC ('"x",STRINGIMAGE i) + [['bcStrings,[6, "0.0", xnam, 'F]]] + dList := + "append"/[fd(i) for i in 1..n] where fd(i) == + dnam := INTERN STRCONC ('"d",STRINGIMAGE i) + [['bcStrings,[6, "0.0", dnam, 'F]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} Diagonal elements of diagon") + prefix := STRCONC(prefix,"al matrix D as returned by F01MCF: \newline") + dList := [['text,:prefix],:dList] + nrowList := + "append"/[gj(j) for j in 1..n] where gj(j) == + nam := INTERN STRCONC ('"n",STRINGIMAGE j) + [['bcStrings,[6, 0, nam, 'PI]]] + prefix := ('"\blankline \menuitemstyle{}\tab{2} {\it NROW(n)} the width ") + prefix := STRCONC(prefix,"of the ith row of A: \newline ") + nrowList := [['text,:prefix],:nrowList] + bList := + "append"/[f(i,ir) for i in 1..nrb] where f(i,ir) == + labelList := + "append"/[g(i,j) for j in 1..ir] where g(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i, STRINGIMAGE j) + [['bcStrings,[6, "0.0", bnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + prefix := ('"\blankline \menuitemstyle{}\tab{2} The n by r right-hand side ") + prefix := STRCONC(prefix,"matrix B: \newline ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain PI (PositiveInteger))), + :labelList,:dList,:nrowList,:bList] + page := htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) + htSay '"\menuitemstyle{}\tab{2} Elements of matrix {\it AL} in row by row " + htSay '"order as returned by F01MCF: \newline " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04mcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'lal,lal) + htpSetProperty(page,'ir,ir) +-- htpSetProperty(page,'nrb,nrb) +-- htpSetProperty(page,'nrx,nrx) + htpSetProperty(page,'iselct,iselct) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + +f04mcfDefaultSolve (htPage,iselct,ifail) == + n := '6 + lal := '14 + ir := '2 + nrb := '6 + nrx := '6 + page := htInitPage("F04MCF - Approximate solution of real symmetric positive-definite variable-bandwidth simultaneous linear equations (coefficient matrix already factorized)",nil) + htMakePage '( + (domainConditions + (isDomain PI (Positive Integer)) + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} Elements of matrix {\it AL} in row by ") + (text . "row order as returned by F01MCF: ") + (text . "\newline ") + (bcStrings (6 "1.0" x1 F)) + (bcStrings (6 "2.0" x2 F)) + (bcStrings (6 "1.0" x3 F)) + (bcStrings (6 "3.0" x4 F)) + (bcStrings (6 "1.0" x5 F)) + (bcStrings (6 "1.0" x6 F)) + (bcStrings (6 "5.0" x7 F)) + (bcStrings (6 "4.0" x8 F)) + (bcStrings (6 "1.5" x9 F)) + (bcStrings (6 "0.5" x10 F)) + (bcStrings (6 "1.0" x11 F)) + (bcStrings (6 "1.5" x12 F)) + (bcStrings (6 "5.0" x13 F)) + (bcStrings (6 "1.0" x14 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} Diagonal elements of diagonal matrix ") + (text . "D as returned by F01MCF: ") + (text . "\newline ") + (bcStrings (6 "1.0" d1 F)) + (bcStrings (6 "1.0" d2 F)) + (bcStrings (6 "4.0" d3 F)) + (bcStrings (6 "16.0" d4 F)) + (bcStrings (6 "1.0" d5 F)) + (bcStrings (6 "16.0" d6 F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} {\it NROW(n)} the width of the ith row ") + (text . "of A: ") + (text . "\newline ") + (bcStrings (6 1 n1 PI)) + (bcStrings (6 2 n2 PI)) + (bcStrings (6 2 n3 PI)) + (bcStrings (6 1 n4 PI)) + (bcStrings (6 5 n5 PI)) + (bcStrings (6 3 n6 PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2} The n by r right-hand side matrix B:") + (text . "\newline ") + (bcStrings (6 "6" b11 F)) + (text . "\tab{10} ") + (bcStrings (6 "-10" b12 PI)) + (text . "\newline ") + (bcStrings (6 "15" b21 F)) + (text . "\tab{10} ") + (bcStrings (6 "-21" b22 PI)) + (text . "\newline ") + (bcStrings (6 "11" b31 F)) + (text . "\tab{10} ") + (bcStrings (6 "-3" b32 PI)) + (text . "\newline ") + (bcStrings (6 "0" b41 F)) + (text . "\tab{10} ") + (bcStrings (6 "24" b42 PI)) + (text . "\newline ") + (bcStrings (6 "51" b51 F)) + (text . "\tab{10} ") + (bcStrings (6 "-39" b52 PI)) + (text . "\newline ") + (bcStrings (6 "46" b61 F)) + (text . "\tab{10} ") + (bcStrings (6 "67" b62 PI)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f04mcfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'lal,lal) + htpSetProperty(page,'ir,ir) +-- htpSetProperty(page,'nrb,nrb) +-- htpSetProperty(page,'nrx,nrx) + htpSetProperty(page,'iselct,iselct) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04mcfGen htPage == + n := htpProperty(htPage,'n) + lal := htpProperty(htPage,'lal) + ir := htpProperty(htPage,'ir) +-- nrb := htpProperty(htPage,'nrb) +-- nrx := htpProperty(htPage,'nrx) + nrb := n + nrx := n + iselct := htpProperty(htPage,'iselct) + ifail := htpProperty(htPage,'ifail) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..nrb repeat + for j in 1..ir repeat + elm := STRCONC((first y).1," ") + rowList := [elm,:rowList] + y := rest y + matform := [rowList,:matform] + rowList := [] + matfrom := REVERSE matform + matstring := bcwords2liststring [bcwords2liststring x for x in matform] + for i in 1..n repeat + right := STRCONC ((first y).1," ") + y := rest y + nrowList := [right,:nrowList] + nrowstring := bcwords2liststring nrowList + for i in 1..n repeat + right := STRCONC ((first y).1," ") + y := rest y + dList := [right,:dList] + dstring := bcwords2liststring dList + while y repeat + right := STRCONC ((first y).1," ") + y := rest y + alList := [right,:alList] + alstring := bcwords2liststring alList + prefix := STRCONC('"f04mcf(",STRINGIMAGE n,", [",alstring,"], ") + prefix := STRCONC(prefix,STRINGIMAGE lal,", [",dstring,"],[",nrowstring) + prefix := STRCONC(prefix,"]::Matrix Integer,") + prefix := STRCONC(prefix,STRINGIMAGE ir,", ",matstring,", ",STRINGIMAGE nrb) + prefix := STRCONC(prefix,", ",STRINGIMAGE iselct,", ",STRINGIMAGE nrx,", ") + bcGen STRCONC(prefix,STRINGIMAGE ifail,")") + + +f04axf() == + htInitPage('"F04AXF - Approximate solution of a a set of real sparse linear equations after factorization by F01BRF or by F01BSF",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf04axf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04axf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F04AXF calculates the approximate solution of a set of real ") + (text . "sparse linear equations {\it Ax=b} or ") + (text . "\htbitmap{aTx=b}, where the {\it n} by {\it n} matrix ") + (text . "{\it A} has been factorized by F01BRF or F01BSF, {\it x} ") + (text . "is an {\it n} element vector of unknowns and {\it b} is an ") + (text . "{\it n} element right-hand side vector. ") + (text . "\blankline") + (text . "\newline ") + (text . "Read the input file to see the example program. ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\spadcommand{)read f04axf \bound{s0}} ")) + htShowPage() + +f04maf() == + htInitPage('"F04MAF - Solution of a real sparse symmetric positive-definite system of linear equations after factorization by F01MAF",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf04maf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04maf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F04MAF solves a real sparse symmetric positive-definite system ") + (text . "of linear equations {\it Ax=b} using a pre-conditioned ") + (text . "conjugate gradient method, where the {\it n} by {\it n} ") + (text . "matrix {\it A} has been factorized by F01MAF, {\it x} is an ") + (text . "{\it n} element vector of unknowns and {\it b} is an {\it n} ") + (text . "element right-hand side vector. ") + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "\spadcommand{)read f04maf \bound{s0}} ")) + htShowPage() + +f04mbf() == + htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf04mbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mbf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F04MBF solve a system of real symmetric linear equations ") + (text . "({\it A} - \lambda {\it I}){\it x} = {\it b} using a Lanczos ") + (text . "algorithm, where {\it A} is an {\it n} by {\it n} sparse ") + (text . "symmetric matrix, {\it x} is an {\it n} vector of unknowns ") + (text . "and {\it b} is an {\it n} element right-hand side vector. ") + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the order {\it n} of matrix {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 10 n PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Is preconditioning required? ") + (radioButtons precon + ("" " Yes" true) + ("" " No" false)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the shift in the equations \lambda, {\it shift} : ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" shift F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the tolerance for convergence, {\it rtol}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.00001" rtol F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter an upper limit for the number of iterations, {\it itnlim}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 100 itnlim PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the printing level, {\it msglvl}: ") + (text . "\newline \tab{2} ") + (bcStrings (10 1 msglvl PI)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04mbfSolve) + htShowPage() + +f04mbfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + msolve := htpButtonValue(htPage,'precon) + precon := + msolve = 'true => 'true + 'false + shift := htpLabelInputString(htPage,'shift) + rtol := htpLabelInputString(htPage,'rtol) + itnlim := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itnlim) + objValUnwrap htpLabelSpadValue(htPage, 'itnlim) + msglvl := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'msglvl) + objValUnwrap htpLabelSpadValue(htPage, 'msglvl) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (n = '10 and precon ='true) => f04mbfDefaultSolve(htPage,shift,rtol,itnlim,msglvl,ifail) + bmatList := + "append"/[f(i) for i in 1..n] where f(i) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i) + [['bcStrings,[6, "0.0", bnam, 'F]]] + amatList := + "append"/[h(ia,n) for ia in 1..n] where h(ia,n) == + alabelList := + "append"/[k(ia,ja) for ja in 1..n] where k(ia,ja) == + anam := INTERN STRCONC ('"a",STRINGIMAGE ia,STRINGIMAGE ja) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + alabelList := [['text,:prefix],:alabelList] + start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it A}: ") + amatList := [['text,:start],:amatList] + mmatList:= + precon = 'true => + alabelList:= + "append"/[l(im,n) for im in 1..n] where l(im,n) == + mlabelList := + "append"/[o(im,jm) for jm in 1..n] where o(im,jm) == + mnam := INTERN STRCONC ('"m",STRINGIMAGE im,STRINGIMAGE jm) + [['bcStrings,[6, "0.0", mnam, 'F]]] + prefix := ('"\newline \tab{2} ") + mlabelList := [['text,:prefix],:mlabelList] + start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it m}: ") + [['text,:start],:alabelList] + [] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :bmatList,:amatList,:mmatList] + page := htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) + htSay '"\newline \menuitemstyle{}\tab{2} " + htSay '"Enter the right-hand side vector {\it b(n)}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04mbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'precon,precon) + htpSetProperty(page,'shift,shift) + htpSetProperty(page,'rtol,rtol) + htpSetProperty(page,'itnlim,itnlim) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04mbfDefaultSolve (htPage,shift,rtol,itnlim,msglvl,ifail) == + n := '10 + precon := 'true + page := htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the right-hand side vector {\it b(n)}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "6.0" b1 F)) + (bcStrings (6 "4.0" b2 F)) + (bcStrings (6 "4.0" b3 F)) + (bcStrings (6 "4.0" b4 F)) + (bcStrings (6 "4.0" b5 F)) + (bcStrings (6 "4.0" b6 F)) + (bcStrings (6 "4.0" b7 F)) + (bcStrings (6 "4.0" b8 F)) + (bcStrings (6 "4.0" b9 F)) + (bcStrings (6 "6.0" b10 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the matrix {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" a11 F)) + (bcStrings (6 "1.0" a12 F)) + (bcStrings (6 "0.0" a13 F)) + (bcStrings (6 "0.0" a14 F)) + (bcStrings (6 "0.0" a15 F)) + (bcStrings (6 "0.0" a16 F)) + (bcStrings (6 "0.0" a17 F)) + (bcStrings (6 "0.0" a18 F)) + (bcStrings (6 "0.0" a19 F)) + (bcStrings (6 "3.0" a110 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.0" a21 F)) + (bcStrings (6 "2.0" a22 F)) + (bcStrings (6 "1.0" a23 F)) + (bcStrings (6 "0.0" a24 F)) + (bcStrings (6 "0.0" a25 F)) + (bcStrings (6 "0.0" a26 F)) + (bcStrings (6 "0.0" a27 F)) + (bcStrings (6 "0.0" a28 F)) + (bcStrings (6 "0.0" a29 F)) + (bcStrings (6 "0.0" a210 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a31 F)) + (bcStrings (6 "1.0" a32 F)) + (bcStrings (6 "2.0" a33 F)) + (bcStrings (6 "1.0" a34 F)) + (bcStrings (6 "0.0" a35 F)) + (bcStrings (6 "0.0" a36 F)) + (bcStrings (6 "0.0" a37 F)) + (bcStrings (6 "0.0" a38 F)) + (bcStrings (6 "0.0" a39 F)) + (bcStrings (6 "0.0" a310 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a41 F)) + (bcStrings (6 "0.0" a42 F)) + (bcStrings (6 "1.0" a43 F)) + (bcStrings (6 "2.0" a44 F)) + (bcStrings (6 "1.0" a45 F)) + (bcStrings (6 "0.0" a46 F)) + (bcStrings (6 "0.0" a47 F)) + (bcStrings (6 "0.0" a48 F)) + (bcStrings (6 "0.0" a49 F)) + (bcStrings (6 "0.0" a410 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a51 F)) + (bcStrings (6 "0.0" a52 F)) + (bcStrings (6 "0.0" a53 F)) + (bcStrings (6 "1.0" a54 F)) + (bcStrings (6 "2.0" a55 F)) + (bcStrings (6 "1.0" a56 F)) + (bcStrings (6 "0.0" a57 F)) + (bcStrings (6 "0.0" a58 F)) + (bcStrings (6 "0.0" a59 F)) + (bcStrings (6 "0.0" a510 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a61 F)) + (bcStrings (6 "0.0" a62 F)) + (bcStrings (6 "0.0" a63 F)) + (bcStrings (6 "0.0" a64 F)) + (bcStrings (6 "1.0" a65 F)) + (bcStrings (6 "2.0" a66 F)) + (bcStrings (6 "1.0" a67 F)) + (bcStrings (6 "0.0" a68 F)) + (bcStrings (6 "0.0" a69 F)) + (bcStrings (6 "0.0" a610 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a71 F)) + (bcStrings (6 "0.0" a72 F)) + (bcStrings (6 "0.0" a73 F)) + (bcStrings (6 "0.0" a74 F)) + (bcStrings (6 "0.0" a75 F)) + (bcStrings (6 "1.0" a76 F)) + (bcStrings (6 "2.0" a77 F)) + (bcStrings (6 "1.0" a78 F)) + (bcStrings (6 "0.0" a79 F)) + (bcStrings (6 "0.0" a710 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a81 F)) + (bcStrings (6 "0.0" a82 F)) + (bcStrings (6 "0.0" a83 F)) + (bcStrings (6 "0.0" a84 F)) + (bcStrings (6 "0.0" a85 F)) + (bcStrings (6 "0.0" a86 F)) + (bcStrings (6 "1.0" a87 F)) + (bcStrings (6 "2.0" a88 F)) + (bcStrings (6 "1.0" a89 F)) + (bcStrings (6 "0.0" a810 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a91 F)) + (bcStrings (6 "0.0" a92 F)) + (bcStrings (6 "0.0" a93 F)) + (bcStrings (6 "0.0" a94 F)) + (bcStrings (6 "0.0" a95 F)) + (bcStrings (6 "0.0" a96 F)) + (bcStrings (6 "0.0" a97 F)) + (bcStrings (6 "1.0" a98 F)) + (bcStrings (6 "2.0" a99 F)) + (bcStrings (6 "1.0" a910 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "3.0" a101 F)) + (bcStrings (6 "0.0" a102 F)) + (bcStrings (6 "0.0" a103 F)) + (bcStrings (6 "0.0" a104 F)) + (bcStrings (6 "0.0" a105 F)) + (bcStrings (6 "0.0" a106 F)) + (bcStrings (6 "0.0" a107 F)) + (bcStrings (6 "0.0" a108 F)) + (bcStrings (6 "1.0" a109 F)) + (bcStrings (6 "2.0" a1010 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the matrix {\it m}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "2.0" m11 F)) + (bcStrings (6 "1.0" m12 F)) + (bcStrings (6 "0.0" m13 F)) + (bcStrings (6 "0.0" m14 F)) + (bcStrings (6 "0.0" m15 F)) + (bcStrings (6 "0.0" m16 F)) + (bcStrings (6 "0.0" m17 F)) + (bcStrings (6 "0.0" m18 F)) + (bcStrings (6 "0.0" m19 F)) + (bcStrings (6 "0.0" m110 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.0" m21 F)) + (bcStrings (6 "2.0" m22 F)) + (bcStrings (6 "1.0" m23 F)) + (bcStrings (6 "0.0" m24 F)) + (bcStrings (6 "0.0" m25 F)) + (bcStrings (6 "0.0" m26 F)) + (bcStrings (6 "0.0" m27 F)) + (bcStrings (6 "0.0" m28 F)) + (bcStrings (6 "0.0" m29 F)) + (bcStrings (6 "0.0" m210 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m31 F)) + (bcStrings (6 "1.0" m32 F)) + (bcStrings (6 "2.0" m33 F)) + (bcStrings (6 "1.0" m34 F)) + (bcStrings (6 "0.0" m35 F)) + (bcStrings (6 "0.0" m36 F)) + (bcStrings (6 "0.0" m37 F)) + (bcStrings (6 "0.0" m38 F)) + (bcStrings (6 "0.0" m39 F)) + (bcStrings (6 "0.0" m310 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m41 F)) + (bcStrings (6 "0.0" m42 F)) + (bcStrings (6 "1.0" m43 F)) + (bcStrings (6 "2.0" m44 F)) + (bcStrings (6 "1.0" m45 F)) + (bcStrings (6 "0.0" m46 F)) + (bcStrings (6 "0.0" m47 F)) + (bcStrings (6 "0.0" m48 F)) + (bcStrings (6 "0.0" m49 F)) + (bcStrings (6 "0.0" m410 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m51 F)) + (bcStrings (6 "0.0" m52 F)) + (bcStrings (6 "0.0" m53 F)) + (bcStrings (6 "1.0" m54 F)) + (bcStrings (6 "2.0" m55 F)) + (bcStrings (6 "1.0" m56 F)) + (bcStrings (6 "0.0" m57 F)) + (bcStrings (6 "0.0" m58 F)) + (bcStrings (6 "0.0" m59 F)) + (bcStrings (6 "0.0" m510 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m61 F)) + (bcStrings (6 "0.0" m62 F)) + (bcStrings (6 "0.0" m63 F)) + (bcStrings (6 "0.0" m64 F)) + (bcStrings (6 "1.0" m65 F)) + (bcStrings (6 "2.0" m66 F)) + (bcStrings (6 "1.0" m67 F)) + (bcStrings (6 "0.0" m68 F)) + (bcStrings (6 "0.0" m69 F)) + (bcStrings (6 "0.0" m610 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m71 F)) + (bcStrings (6 "0.0" m72 F)) + (bcStrings (6 "0.0" m73 F)) + (bcStrings (6 "0.0" m74 F)) + (bcStrings (6 "0.0" m75 F)) + (bcStrings (6 "1.0" m76 F)) + (bcStrings (6 "2.0" m77 F)) + (bcStrings (6 "1.0" m78 F)) + (bcStrings (6 "0.0" m79 F)) + (bcStrings (6 "0.0" m710 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m81 F)) + (bcStrings (6 "0.0" m82 F)) + (bcStrings (6 "0.0" m83 F)) + (bcStrings (6 "0.0" m84 F)) + (bcStrings (6 "0.0" m85 F)) + (bcStrings (6 "0.0" m86 F)) + (bcStrings (6 "1.0" m87 F)) + (bcStrings (6 "2.0" m88 F)) + (bcStrings (6 "1.0" m89 F)) + (bcStrings (6 "0.0" m810 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m91 F)) + (bcStrings (6 "0.0" m92 F)) + (bcStrings (6 "0.0" m93 F)) + (bcStrings (6 "0.0" m94 F)) + (bcStrings (6 "0.0" m95 F)) + (bcStrings (6 "0.0" m96 F)) + (bcStrings (6 "0.0" m97 F)) + (bcStrings (6 "1.0" m98 F)) + (bcStrings (6 "2.0" m99 F)) + (bcStrings (6 "1.0" m910 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" m101 F)) + (bcStrings (6 "0.0" m102 F)) + (bcStrings (6 "0.0" m103 F)) + (bcStrings (6 "0.0" m104 F)) + (bcStrings (6 "0.0" m105 F)) + (bcStrings (6 "0.0" m106 F)) + (bcStrings (6 "0.0" m107 F)) + (bcStrings (6 "0.0" m108 F)) + (bcStrings (6 "1.0" m109 F)) + (bcStrings (6 "2.0" m1010 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f04mbfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'precon,precon) + htpSetProperty(page,'shift,shift) + htpSetProperty(page,'rtol,rtol) + htpSetProperty(page,'itnlim,itnlim) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04mbfGen htPage == + n := htpProperty(htPage,'n) + precon := htpProperty(htPage,'precon) + shift := htpProperty(htPage,'shift) + rtol := htpProperty(htPage,'rtol) + itnlim := htpProperty(htPage,'itnlim) + msglvl := htpProperty(htPage,'msglvl) + ifail := htpProperty(htPage,'ifail) + lrwork := '1 + liwork := '1 + alist := htpInputAreaAlist htPage + y := alist + if (precon = 'true) then + for i in 1..n repeat + for j in 1..n repeat + melm := STRCONC((first y).1," ") + mrowlist := [melm,:mrowlist] + y := rest y + matm := [mrowlist,:matm] + mrowlist := [] + mstring := bcwords2liststring [bcwords2liststring x for x in matm] + for k in 1..n repeat + for l in 1..n repeat + aelm := STRCONC((first y).1," ") + arowlist := [aelm,:arowlist] + y := rest y + mata := [arowlist,:mata] + arowlist := [] + astring := bcwords2liststring [bcwords2liststring y for y in mata] + for z in 1..n repeat + belm := STRCONC((first y).1," ") + blist := [belm,:blist] + y := rest y + bstring := bcwords2liststring blist + if (precon = 'false) then + mstring := astring + prefix := STRCONC('"f04mbf(",STRINGIMAGE n,",[",bstring,"]::Matrix DoubleFloat,",precon,",") + prefix := STRCONC(prefix,STRINGIMAGE shift,",",STRINGIMAGE itnlim,",",STRINGIMAGE msglvl,",") + prefix := STRCONC(prefix,STRINGIMAGE lrwork,",",STRINGIMAGE liwork,",") + prefix := STRCONC(prefix,STRINGIMAGE rtol,",",STRINGIMAGE ifail,",((") + prefix := STRCONC(prefix,astring,"::Matrix MachineFloat)::ASP28(APROD)),((") + prefix := STRCONC(prefix,mstring,"::Matrix MachineFloat)::ASP34(MSOLVE)))") + linkGen prefix + + +-- f04qaf() == +-- htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) +-- htMakePage '( +-- (domainConditions +-- (isDomain EM $EmptyMode) +-- (isDomain F (Float))) +-- (text . "\windowlink{Manual Page}{manpageXXf04qaf} for this routine ") +-- (text . "\newline ") +-- (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04qaf| '|NagLinearEquationSolvingPackage|)} for this routine") +-- (text . "\newline \horizontalline ") +-- (text . "\newline ") +-- (text . "F04QAF solves sparse unsymmetric equations, sparse linear ") +-- (text . "least-squares problems and sparse damped least-squares ") +-- (text . "problems, using a Lanczos algorithm. Specifically, the ") +-- (text . "routine can be used to solve a system of linear equations ") +-- (text . "{\it Ax=b}, where {\it A} is an {\it n} by {\it n} real ") +-- (text . "sparse unsymmetric matrix, or can be used to solve linear ") +-- (text . "least-squares problems, so that it minimizes the the value ") +-- (text . "{\htbitmap{newrho}} given by {\htbitmap{rho=r}}, ") +-- (text . "{\it r=b-AX} where {\it A} is an {\it m} by {\it n} real ") +-- (text . "sparse matrix. A damping parameter \lambda may ") +-- (text . "be included in the least squares problem in which case the ") +-- (text . "routine minimizes the value {\htbitmap{newrho}} given by ") +-- (text . "{\htbitmap{rhosq=}}. \newline ") +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "\spadcommand{)read f04qaf \bound{s0}} ")) +-- htShowPage() + +-- f04mbf() == +-- htInitPage('"F04MBF - Real sparse symmetric simultaneous linear equations",nil) +-- htMakePage '( +-- (domainConditions +-- (isDomain EM $EmptyMode) +-- (isDomain F (Float))) +-- (text . "\windowlink{Manual Page}{manpageXXf04mbf} for this routine ") +-- (text . "\newline ") +-- (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04mbf| '|NagLinearEquationSolvingPackage|)} for this routine") +-- (text . "\newline \horizontalline ") +-- (text . "\newline ") +-- (text . "\newline ") +-- (text . "F04MBF solve a system of real symmetric linear equations ") +-- (text . "({\it A} - \lambda {\it I}){\it x} = {\it b} using a Lanczos ") +-- (text . "algorithm, where {\it A} is an {\it n} by {\it n} sparse ") +-- (text . "symmetric matrix, {\it x} is an {\it n} vector of unknowns ") +-- (text . "and {\it b} is an {\it n} element right-hand side vector. ") +-- (text . "\blankline") +-- (text . "\newline ") +-- (text . "\menuitemstyle{}\tab{2} ") +-- (text . "\spadcommand{)read f04mbf \bound{s0}} ")) +-- htShowPage() + +f04qaf() == + htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain PI (PositiveInteger)) + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXf04qaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f04qaf| '|NagLinearEquationSolvingPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F04QAF solves sparse unsymmetric equations, sparse linear ") + (text . "least-squares problems and sparse damped least-squares ") + (text . "problems, using a Lanczos algorithm. Specifically, the ") + (text . "routine can be used to solve a system of linear equations ") + (text . "{\it Ax=b}, where {\it A} is an {\it n} by {\it n} real ") + (text . "sparse unsymmetric matrix, or can be used to solve linear ") + (text . "least-squares problems, so that it minimizes the the value ") + (text . "{\htbitmap{newrho}} given by {\htbitmap{rho=r}}, ") + (text . "{\it r=b-AX} where {\it A} is an {\it m} by {\it n} real ") + (text . "sparse matrix. A damping parameter \lambda may ") + (text . "be included in the least squares problem in which case the ") + (text . "routine minimizes the value {\htbitmap{newrho}} given by ") + (text . "{\htbitmap{rhosq=}}. \newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of rows of the matrix {\it A}, {\it m}:") + (text . "\newline \tab{2}") + (bcStrings (10 13 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the number of columns of the matrix {\it A}, {\it n}:") + (text . "\newline \tab{2}") + (bcStrings (10 12 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the damping parameter \lambda, {\it damp}:") + (text . "\newline \tab{2}") + (bcStrings (10 "0.0" damp F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the tolerance for elements of {\it A}, {\it atol}:") + (text . "\newline \tab{2}") + (bcStrings (10 "0.00001" atol F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the tolerance for elements of {\it b}, {\it btol}:") + (text . "\newline \tab{2}") + (bcStrings (10 "0.0001" btol F)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the maximum number of iterations {\it itnlim}:") + (text . "\newline \tab{2}") + (bcStrings (10 100 itnlim PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the printing level {\it msglvl}:") + (text . "\newline \tab{2}") + (bcStrings (10 1 msglvl PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'f04qafSolve) + htShowPage() + +f04qafSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + damp := htpLabelInputString(htPage,'damp) + atol := htpLabelInputString(htPage,'atol) + btol := htpLabelInputString(htPage,'btol) + itnlim := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'itnlim) + objValUnwrap htpLabelSpadValue(htPage, 'itnlim) + msglvl := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'msglvl) + objValUnwrap htpLabelSpadValue(htPage, 'msglvl) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => '1 + '-1 + (m = '13 and n = '12) => f04qafDefaultSolve(htPage,damp,atol,btol,itnlim,msglvl,ifail) + bmatList := + "append"/[f(i) for i in 1..m] where f(i) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i) + [['bcStrings,[6, "0.0", bnam, 'F]]] + amatList := + "append"/[h(ia,n) for ia in 1..m] where h(ia,n) == + alabelList := + "append"/[k(ia,ja) for ja in 1..n] where k(ia,ja) == + anam := INTERN STRCONC ('"a",STRINGIMAGE ia,STRINGIMAGE ja) + [['bcStrings,[6, "0.0", anam, 'F]]] + prefix := ('"\newline \tab{2} ") + alabelList := [['text,:prefix],:alabelList] + start := ('"\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it A}: ") + amatList := [['text,:start],:amatList] + equationPart := [ + '(domainConditions + (isDomain P (Polynomial $EmptyMode)) + (isDomain F (Float))), + :bmatList,:amatList] + page := htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) + htSay '"\newline \menuitemstyle{}\tab{2} " + htSay '"Enter the right-hand side vector {\it b(m)}: " + htSay '"\newline \tab{2} " + htMakePage equationPart + htSay '"\blankline " + htMakeDoneButton('"Continue",'f04qafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'n,n) + htpSetProperty(page,'damp,damp) + htpSetProperty(page,'atol,atol) + htpSetProperty(page,'btol,btol) + htpSetProperty(page,'itnlim,itnlim) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + + + +f04qafDefaultSolve (htPage,damp,atol,btol,itnlim,msglvl,ifail) == + m := '13 + n := '12 + page := htInitPage('"F04QAF - Solution of sparse unsymmetric equations, linear and damped least-squares problems using a Lanczos algorithm",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the right-hand side vector {\it b(n)}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" b1 F)) + (bcStrings (6 "0.0" b2 F)) + (bcStrings (6 "0.0" b3 F)) + (bcStrings (6 "-0.01" b4 F)) + (bcStrings (6 "-0.01" b5 F)) + (bcStrings (6 "0.0" b6 F)) + (bcStrings (6 "0.0" b7 F)) + (bcStrings (6 "-0.01" b8 F)) + (bcStrings (6 "-0.01" b9 F)) + (bcStrings (6 "0.0" b10 F)) + (bcStrings (6 "0.0" b11 F)) + (bcStrings (6 "0.0" b12 F)) + (bcStrings (6 "10.0" b13 F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2} ") + (text . "Enter the matrix {\it A}: ") + (text . "\newline \tab{2} ") + (bcStrings (6 "1.0" a0101 F)) + (bcStrings (6 "0.0" a0102 F)) + (bcStrings (6 "0.0" a0103 F)) + (bcStrings (6 "-1.0" a0104 F)) + (bcStrings (6 "0.0" a0105 F)) + (bcStrings (6 "0.0" a0106 F)) + (bcStrings (6 "0.0" a0107 F)) + (bcStrings (6 "0.0" a0108 F)) + (bcStrings (6 "0.0" a0109 F)) + (bcStrings (6 "0.0" a0110 F)) + (bcStrings (6 "0.0" a0111 F)) + (bcStrings (6 "0.0" a0112 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0201 F)) + (bcStrings (6 "1.0" a0202 F)) + (bcStrings (6 "0.0" a0203 F)) + (bcStrings (6 "0.0" a0204 F)) + (bcStrings (6 "-1.0" a0205 F)) + (bcStrings (6 "0.0" a0206 F)) + (bcStrings (6 "0.0" a0207 F)) + (bcStrings (6 "0.0" a0208 F)) + (bcStrings (6 "0.0" a0209 F)) + (bcStrings (6 "0.0" a0210 F)) + (bcStrings (6 "0.0" a0211 F)) + (bcStrings (6 "0.0" a0212 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0301 F)) + (bcStrings (6 "0.0" a0302 F)) + (bcStrings (6 "1.0" a0303 F)) + (bcStrings (6 "-1.0" a0304 F)) + (bcStrings (6 "0.0" a0305 F)) + (bcStrings (6 "0.0" a0306 F)) + (bcStrings (6 "0.0" a0307 F)) + (bcStrings (6 "0.0" a0308 F)) + (bcStrings (6 "0.0" a0309 F)) + (bcStrings (6 "0.0" a0310 F)) + (bcStrings (6 "0.0" a0311 F)) + (bcStrings (6 "0.0" a0312 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "-1.0" a0401 F)) + (bcStrings (6 "0.0" a0402 F)) + (bcStrings (6 "-1.0" a0403 F)) + (bcStrings (6 "4.0" a0404 F)) + (bcStrings (6 "-1.0" a0405 F)) + (bcStrings (6 "0.0" a0406 F)) + (bcStrings (6 "0.0" a0407 F)) + (bcStrings (6 "-1.0" a0408 F)) + (bcStrings (6 "0.0" a0409 F)) + (bcStrings (6 "0.0" a0410 F)) + (bcStrings (6 "0.0" a0411 F)) + (bcStrings (6 "0.0" a0412 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0501 F)) + (bcStrings (6 "-1.0" a0502 F)) + (bcStrings (6 "0.0" a0503 F)) + (bcStrings (6 "-1.0" a0504 F)) + (bcStrings (6 "4.0" a0505 F)) + (bcStrings (6 "-1.0" a0506 F)) + (bcStrings (6 "0.0" a0507 F)) + (bcStrings (6 "0.0" a0508 F)) + (bcStrings (6 "-1.0" a0509 F)) + (bcStrings (6 "0.0" a0510 F)) + (bcStrings (6 "0.0" a0511 F)) + (bcStrings (6 "0.0" a0512 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0601 F)) + (bcStrings (6 "0.0" a0602 F)) + (bcStrings (6 "0.0" a0603 F)) + (bcStrings (6 "0.0" a0604 F)) + (bcStrings (6 "-1.0" a0605 F)) + (bcStrings (6 "1.0" a0606 F)) + (bcStrings (6 "0.0" a0607 F)) + (bcStrings (6 "0.0" a0608 F)) + (bcStrings (6 "0.0" a0609 F)) + (bcStrings (6 "0.0" a0610 F)) + (bcStrings (6 "0.0" a0611 F)) + (bcStrings (6 "0.0" a0612 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0701 F)) + (bcStrings (6 "0.0" a0702 F)) + (bcStrings (6 "0.0" a0703 F)) + (bcStrings (6 "0.0" a0704 F)) + (bcStrings (6 "0.0" a0705 F)) + (bcStrings (6 "0.0" a0706 F)) + (bcStrings (6 "1.0" a0707 F)) + (bcStrings (6 "-1.0" a0708 F)) + (bcStrings (6 "0.0" a0709 F)) + (bcStrings (6 "0.0" a0710 F)) + (bcStrings (6 "0.0" a0711 F)) + (bcStrings (6 "0.0" a0712 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0801 F)) + (bcStrings (6 "0.0" a0802 F)) + (bcStrings (6 "0.0" a0803 F)) + (bcStrings (6 "-1.0" a0804 F)) + (bcStrings (6 "0.0" a0805 F)) + (bcStrings (6 "0.0" a0806 F)) + (bcStrings (6 "-1.0" a0807 F)) + (bcStrings (6 "4.0" a0808 F)) + (bcStrings (6 "-1.0" a0809 F)) + (bcStrings (6 "0.0" a0810 F)) + (bcStrings (6 "-1.0" a0811 F)) + (bcStrings (6 "0.0" a0812 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a0901 F)) + (bcStrings (6 "0.0" a0902 F)) + (bcStrings (6 "0.0" a0903 F)) + (bcStrings (6 "0.0" a0904 F)) + (bcStrings (6 "-1.0" a0905 F)) + (bcStrings (6 "0.0" a0906 F)) + (bcStrings (6 "0.0" a0907 F)) + (bcStrings (6 "-1.0" a0908 F)) + (bcStrings (6 "4.0" a0909 F)) + (bcStrings (6 "-1.0" a0910 F)) + (bcStrings (6 "0.0" a0911 F)) + (bcStrings (6 "-1.0" a0912 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a1001 F)) + (bcStrings (6 "0.0" a1002 F)) + (bcStrings (6 "0.0" a1003 F)) + (bcStrings (6 "0.0" a1004 F)) + (bcStrings (6 "0.0" a1005 F)) + (bcStrings (6 "0.0" a1006 F)) + (bcStrings (6 "0.0" a1007 F)) + (bcStrings (6 "0.0" a1008 F)) + (bcStrings (6 "-1.0" a1009 F)) + (bcStrings (6 "1.0" a1010 F)) + (bcStrings (6 "0.0" a1011 F)) + (bcStrings (6 "0.0" a1012 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a1101 F)) + (bcStrings (6 "0.0" a1102 F)) + (bcStrings (6 "0.0" a1103 F)) + (bcStrings (6 "0.0" a1104 F)) + (bcStrings (6 "0.0" a1105 F)) + (bcStrings (6 "0.0" a1106 F)) + (bcStrings (6 "0.0" a1107 F)) + (bcStrings (6 "-1.0" a1108 F)) + (bcStrings (6 "0.0" a1109 F)) + (bcStrings (6 "0.0" a1110 F)) + (bcStrings (6 "1.0" a1111 F)) + (bcStrings (6 "0.0" a1112 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "0.0" a1201 F)) + (bcStrings (6 "0.0" a1202 F)) + (bcStrings (6 "0.0" a1203 F)) + (bcStrings (6 "0.0" a1204 F)) + (bcStrings (6 "0.0" a1205 F)) + (bcStrings (6 "0.0" a1206 F)) + (bcStrings (6 "0.0" a1207 F)) + (bcStrings (6 "0.0" a1208 F)) + (bcStrings (6 "-1.0" a1209 F)) + (bcStrings (6 "0.0" a1210 F)) + (bcStrings (6 "0.0" a1211 F)) + (bcStrings (6 "1.0" a1212 F)) + (text . "\newline \tab{2} ") + (bcStrings (6 "1.0" a1301 F)) + (bcStrings (6 "1.0" a1302 F)) + (bcStrings (6 "1.0" a1303 F)) + (bcStrings (6 "0.0" a1304 F)) + (bcStrings (6 "0.0" a1305 F)) + (bcStrings (6 "1.0" a1306 F)) + (bcStrings (6 "1.0" a1307 F)) + (bcStrings (6 "0.0" a1308 F)) + (bcStrings (6 "0.0" a1309 F)) + (bcStrings (6 "1.0" a1310 F)) + (bcStrings (6 "1.0" a1311 F)) + (bcStrings (6 "1.0" a1312 F)) + (text . "\blankline ")) + htMakeDoneButton('"Continue",'f04qafGen) + htpSetProperty(page,'m,m) + htpSetProperty(page,'n,n) + htpSetProperty(page,'damp,damp) + htpSetProperty(page,'atol,atol) + htpSetProperty(page,'btol,btol) + htpSetProperty(page,'itnlim,itnlim) + htpSetProperty(page,'msglvl,msglvl) + htpSetProperty(page,'ifail,ifail) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f04qafGen htPage == + m := htpProperty(htPage,'m) + n := htpProperty(htPage,'n) + damp := htpProperty(htPage,'damp) + atol := htpProperty(htPage,'atol) + btol := htpProperty(htPage,'btol) + divisor := READ_-FROM_-STRING(atol) + if (divisor < 1.0e-7) then divisor:=1.0e-7 + conlim := 1.0/divisor + itnlim := htpProperty(htPage,'itnlim) + msglvl := htpProperty(htPage,'msglvl) + ifail := htpProperty(htPage,'ifail) + lrwork := 1 + liwork := 1 + alist := htpInputAreaAlist htPage + y := alist + for k in 1..m repeat + for l in 1..n repeat + aelm := STRCONC((first y).1," ") + arowlist := [aelm,:arowlist] + y := rest y + mata := [arowlist,:mata] + arowlist := [] + astring := bcwords2liststring [bcwords2liststring y for y in mata] + for z in 1..m repeat + belm := STRCONC((first y).1," ") + blist := [belm,:blist] + y := rest y + bstring := bcwords2liststring blist + prefix := STRCONC('"f04qaf(",STRINGIMAGE m,",",STRINGIMAGE n,",") + prefix := STRCONC(prefix,STRINGIMAGE damp,",") + prefix := STRCONC(prefix,STRINGIMAGE atol,",",STRINGIMAGE btol,",") + prefix := STRCONC(prefix,STRINGIMAGE conlim,",",STRINGIMAGE itnlim,",",STRINGIMAGE msglvl,",") + prefix := STRCONC(prefix,STRINGIMAGE lrwork,",",STRINGIMAGE liwork,",") + prefix := STRCONC(prefix,"[",bstring,"]::Matrix DoubleFloat,") + prefix := STRCONC(prefix,STRINGIMAGE ifail,",((",astring,"::Matrix MachineFloat)::ASP30(APROD)))") + linkGen prefix + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-f07.boot b/src/interp/nag-f07.boot deleted file mode 100644 index a0551786..00000000 --- a/src/interp/nag-f07.boot +++ /dev/null @@ -1,704 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -f07adf() == - htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf07adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07adf| '|NagLapack|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F07ADF computes the {\it LU} factorization of a real {\it m}") - (text . " by {\it n} matrix ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of rows {\it m}:") - (text . "\newline\tab{2} ") - (bcStrings (5 4 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of columns {\it n}:") - (text . "\newline\tab{2} ") - (bcStrings (5 4 n PI)) - ) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of array A, {\it lda}:") --- (text . "\newline\tab{2} ") --- (bcStrings (5 4 lda PI)) - htMakeDoneButton('"Continue", 'f07adfSolve) - htShowPage() - -f07adfSolve htPage == - m := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) - objValUnwrap htpLabelSpadValue(htPage, 'm) - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := m - (n = '4 and m = '4) => f07adfDefaultSolve(htPage,lda) - aList := - "append"/[fa(i,n) for i in 1..m] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings,[6, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList] - page := htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the array {\it A}:" - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'f07adfGen) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07adfDefaultSolve (htPage,lda) == - n := '4 - m := '4 - page := htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the array {\it A}:") - (text . "\newline ") - (bcStrings (5 "1.8" a11 F)) - (bcStrings (5 "2.88" a12 F)) - (bcStrings (5 "2.05" a13 F)) - (bcStrings (5 "-0.89" a14 F)) - (text . "\newline ") - (bcStrings (5 "5.25" a21 F)) - (bcStrings (5 "-2.95" a22 F)) - (bcStrings (5 "-0.95" a23 F)) - (bcStrings (5 "-3.8" a24 F)) - (text . "\newline ") - (bcStrings (5 "1.58" a31 F)) - (bcStrings (5 "-2.69" a32 F)) - (bcStrings (5 "-2.9" a33 F)) - (bcStrings (5 "-1.04" a34 F)) - (text . "\newline ") - (bcStrings (5 "-1.11" a41 F)) - (bcStrings (5 "-0.66" a42 F)) - (bcStrings (5 "-0.59" a43 F)) - (bcStrings (5 "0.8" a44 F))) - htpSetProperty(page,'n,n) - htpSetProperty(page,'m,m) --- htpSetProperty(page,'lda,lda) - htMakeDoneButton('"Continue",'f07adfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07adfGen htPage == - n := htpProperty(htPage, 'n) - m := htpProperty(htPage, 'm) - lda := m - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - for j in 1..m repeat - a := STRCONC((first y).1," ") - rowList := [a,:rowList] - y := rest y - aList := [rowList,:aList] - rowList := [] - astring := bcwords2liststring [bcwords2liststring x for x in aList] - prefix := STRCONC("f07adf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",astring,")") - linkGen prefix - - -f07aef() == - htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf07aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07aef| '|NagLapack|)} for this routine") - (text . "\newline \horizontalline ") - (text . "F07AEF solves a real system of linear equations with multiple right-hand sides, {\it AX=B} or ") - (text . "\htbitmap{aTx=b} , where {\it a} has been factorized by F07ADF ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Form of the equations:") - (text . "\blankline ") - (radioButtons trans - ("" " N, the equations are {\it AX=B}" norm) - ("" " T, the equations are \htbitmap{aTx=b}" transp)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The order {\it n} of {\it A}: ") - (text . "\newline ") - (bcStrings (5 4 n PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "The order {\it m} of {\it A} used by F07AEF: ") --- (text . "\newline ") --- (bcStrings (5 4 m PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The number of right-hand sides, {\it nrhs}: ") - (text . "\newline ") - (bcStrings (5 2 nrhs PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of {\it A}, {\it lda}: ") --- (text . "\newline ") --- (bcStrings (5 4 lda PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of {\it B}, {\it ldb}: ") --- (text . "\newline ") --- (bcStrings (5 4 ldb PI)) - ) - htMakeDoneButton('"Continue", 'f07aefSolve) - htShowPage() - -f07aefSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) --- m := --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) --- objValUnwrap htpLabelSpadValue(htPage, 'm) - nrhs := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrhs) - objValUnwrap htpLabelSpadValue(htPage, 'nrhs) - lda := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - equa := htpButtonValue(htPage, 'trans) - trans := - equa = 'norm => '"N" - '"T" - (n = '4 and nrhs = '2 ) => f07aefDefaultSolve (htPage,trans) - aList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[faa(i,j) for j in 1..n] where faa(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings, [6, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - ipList := - [fp(i) for i in 1..n] where fp(i) == - ipnam := INTERN STRCONC ('"ip",STRINGIMAGE i) - ['bcStrings,[5, 0, ipnam, 'I]] - middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the pivot ") - middle := STRCONC(middle,'"indices {\it IPIV} from F07ADF: ") - middle := STRCONC(middle,'"\newline ") - ipList := [['text,:middle],:ipList] - bList := - "append"/[fb(i,nrhs) for i in 1..n] where fb(i,nrhs) == - labelList := - "append"/[fbb(i,j) for j in 1..nrhs] where fbb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings, [6, 0, bnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it B}: ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))) - ,:aList,:ipList,:bList] - page := htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the matrix {\it A}:" - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'f07aefGen) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'m,m) - htpSetProperty(page,'nrhs,nrhs) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07aefDefaultSolve (htPage,trans) == - n := '4 - nrhs := '2 - lda := '4 - ldb := '4 - length := '4 - page := htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it A}:") - (text . "\newline ") - (bcStrings (5 "5.25" a11 F)) - (bcStrings (5 "-2.95" a12 F)) - (bcStrings (5 "-0.95" a13 F)) - (bcStrings (5 "-3.8" a14 F)) - (text . "\newline ") - (bcStrings (5 "0.34" a21 F)) - (bcStrings (5 "3.89" a22 F)) - (bcStrings (5 "2.38" a23 F)) - (bcStrings (5 "0.41" a24 F)) - (text . "\newline ") - (bcStrings (5 "0.3" a31 F)) - (bcStrings (5 "-0.46" a32 F)) - (bcStrings (5 "-1.51" a33 F)) - (bcStrings (5 "0.29" a34 F)) - (text . "\newline ") - (bcStrings (5 "-0.21" a41 F)) - (bcStrings (5 "-0.33" a42 F)) - (bcStrings (5 "0.00" a43 F)) - (bcStrings (5 "0.13" a44 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the pivot indices {\it IPIV} from F07ADF: ") - (text . "\newline ") - (bcStrings (5 2 ip1 PI)) - (bcStrings (5 2 ip2 PI)) - (bcStrings (5 3 ip3 PI)) - (bcStrings (5 4 ip4 PI)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it B}:") - (text . "\newline ") - (bcStrings (5 "9.52" b11 F)) - (bcStrings (5 "18.47" b12 F)) - (text . "\newline ") - (bcStrings (5 "24.35" b21 F)) - (bcStrings (5 "2.25" b22 F)) - (text . "\newline ") - (bcStrings (5 "0.77" b31 F)) - (bcStrings (5 "-13.28" b32 F)) - (text . "\newline ") - (bcStrings (5 "-6.22" b41 F)) - (bcStrings (5 "-6.21" b42 F))) - htpSetProperty(page,'trans,trans) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nrhs,nrhs) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'length,length) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htMakeDoneButton('"Continue",'f07aefGen) - htShowPage() - -f07aefGen htPage == - n := htpProperty(htPage, 'n) - nrhs := htpProperty(htPage, 'nrhs) --- lda := htpProperty(htPage, 'lda) --- ldb := htpProperty(htPage, 'ldb) - lda := n - ldb := n - length := htpProperty(htPage, 'length) - trans := htpProperty(htPage,'trans) - aplist := htpInputAreaAlist htPage - y := aplist - for i in 1..n repeat - for j in 1..nrhs repeat - b := STRCONC((first y).1," ") - rowList := [b,:rowList] - y := rest y - bList := [rowList,:bList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bList] - for i in 1..length repeat - ip := STRCONC((first y).1," ") - ipList := [ip,:ipList] - y := rest y - ipstring := bcwords2liststring ipList - for i in 1..lda repeat - for j in 1..n repeat - a := STRCONC((first y).1," ") - rowList := [a,:rowList] - y := rest y - aList := [rowList,:aList] - rowList := [] - astring := bcwords2liststring [bcwords2liststring x for x in aList] - prefix := STRCONC("f07aef(_"", trans,"_", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrhs,", ",astring,"::Matrix DoubleFloat, ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", [",ipstring,"]::Matrix INT, ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,"::Matrix DoubleFloat)") - linkGen prefix - -f07fdf() == - htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf07fdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07fdf| '|NagLapack|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F07FDF computes the Cholesky factorization of a real symmetric positive-definite ") - (text . "matrix {\it A} ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Method of factorization of {\it A}, {\it UPLO}:") - (text . "\blankline ") - (radioButtons uplo - ("" " L, {\it A} factorized as lower triangular" lower) - ("" " U, {\it A} factorized as upper triangular" upper)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The order {\it n} of {\it A}: ") - (text . "\newline ") - (bcStrings (5 4 n PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of {\it A}, {\it lda}:") --- (text . "\newline ") --- (bcStrings (5 4 lda PI))) - ) - htMakeDoneButton('"Continue", 'f07fdfSolve) - htShowPage() - -f07fdfSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - lda := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - upl := htpButtonValue(htPage, 'uplo) - uplo:= - upl = 'lower => '"L" - '"U" - (n = '4 ) => f07fdfDefaultSolve(htPage,uplo) - aList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[fb(i,j) for j in 1..n] where fb(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings, [6, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))), - :aList] - page := htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the matrix {\it A}:" - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'f07fdfGen) - htpSetProperty(page,'uplo,uplo) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'lda,lda) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07fdfDefaultSolve (htPage,uplo) == - n := '4 - lda := '4 - page := htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it A}:") - (text . "\newline ") - (bcStrings (5 "4.16" a11 F)) - (bcStrings (5 "0.0" a12 F)) - (bcStrings (5 "0.0" a13 F)) - (bcStrings (5 "0.0" a14 F)) - (text . "\newline ") - (bcStrings (5 "-3.12" a21 F)) - (bcStrings (5 "5.03" a22 F)) - (bcStrings (5 "0.0" a23 F)) - (bcStrings (5 "0.0" a24 F)) - (text . "\newline ") - (bcStrings (5 "0.56" a31 F)) - (bcStrings (5 "-0.83" a32 F)) - (bcStrings (5 "0.76" a33 F)) - (bcStrings (5 "0.0" a34 F)) - (text . "\newline ") - (bcStrings (5 "-0.1" a41 F)) - (bcStrings (5 "1.18" a42 F)) - (bcStrings (5 "0.34" a43 F)) - (bcStrings (5 "1.18" a44 F))) - htpSetProperty(page,'uplo,uplo) - htpSetProperty(page,'n,n) --- htpSetProperty(page,'lda,lda) - htMakeDoneButton('"Continue",'f07fdfGen) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07fdfGen htPage == - n := htpProperty(htPage, 'n) --- lda := htpProperty(htPage, 'lda) - lda := n - uplo := htpProperty(htPage,'uplo) - alist := htpInputAreaAlist htPage - y := alist - for i in 1..n repeat - for j in 1..n repeat - a := STRCONC((first y).1," ") - rowList := [a,:rowList] - y := rest y - aList := [rowList,:aList] - rowList := [] - astring := bcwords2liststring [bcwords2liststring x for x in aList] - prefix := STRCONC("f07fdf(_"", uplo,"_", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ",astring,")") - linkGen prefix - - -f07fef() == - htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) - htMakePage '( - (domainConditions - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXf07fef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07fef| '|NagLapack|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "F07FEF solves a real symmetric positive-definite system of linear ") - (text . "equations with multiple right-hand sides, {\it AX=B}, where ") - (text . "{\it A} has been factorized by F07FDF ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Method of factorization of {\it A}, {\it UPLO}:") - (text . "\blankline ") - (radioButtons uplo - ("" " L, {\it A} factorized as lower triangular" lower) - ("" " U, {\it A} factorized as upper triangular" upper)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The order {\it n} of {\it A}: ") - (text . "\newline ") - (bcStrings (5 4 n PI)) - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "The number of right-hand sides, {\it nrhs}: ") - (text . "\newline ") - (bcStrings (5 2 nrhs PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of {\it A}, {\it lda}: ") --- (text . "\newline ") --- (bcStrings (5 4 lda PI)) --- (text . "\blankline ") --- (text . "\menuitemstyle{}\tab{2}") --- (text . "First dimension of {\it B}, {\it ldb}: ") --- (text . "\newline ") --- (bcStrings (5 4 ldb PI))) - ) - htMakeDoneButton('"Continue", 'f07fefSolve) - htShowPage() - -f07fefSolve htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - nrhs := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrhs) - objValUnwrap htpLabelSpadValue(htPage, 'nrhs) - lda := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) --- objValUnwrap htpLabelSpadValue(htPage, 'lda) - ldb := n --- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) --- objValUnwrap htpLabelSpadValue(htPage, 'ldb) - upl := htpButtonValue(htPage, 'uplo) - uplo:= - upl = 'lower => '"L" - '"U" - (n = '4 and nrhs = '2) => f07fefDefaultSolve(htPage,uplo) - aList := - "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == - labelList := - "append"/[faa(i,j) for j in 1..n] where faa(i,j) == - anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings, [8, 0, anam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - bList := - "append"/[fb(i,nrhs) for i in 1..n] where fb(i,nrhs) == - labelList := - "append"/[fbb(i,j) for j in 1..nrhs] where fbb(i,j) == - bnam := INTERN STRCONC ('"b",STRINGIMAGE i,STRINGIMAGE j) - [['bcStrings, [8, 0, bnam, 'F]]] - prefix := ('"\newline ") - labelList := [['text,:prefix],:labelList] - prefix := ("\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it B}: ") - bList := [['text,:prefix],:bList] - equationPart := [ - '(domainConditions - (isDomain EM $EmptyMode) - (isDomain S (String)) - (isDomain F (Float)) - (isDomain I (Integer))) - ,:aList,:bList] - page := htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) - htSay '"\menuitemstyle{}\tab{2} " - htSay '"Enter the matrix {\it A}:" - htSay '"\newline " - htMakePage equationPart - htMakeDoneButton('"Continue",'f07fefGen) - htpSetProperty(page,'uplo,uplo) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nrhs,nrhs) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htShowPage() - -f07fefDefaultSolve (htPage,uplo) == - n := '4 - nrhs := '2 - lda := '4 - ldb := '4 - page := htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) - htMakePage '( - (domainConditions - (isDomain EM $EmptyMode) - (isDomain F (Float)) - (isDomain I (Integer))) - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it A}:") - (text . "\newline ") - (bcStrings (8 "2.04" a11 F)) - (bcStrings (8 "0.0" a12 F)) - (bcStrings (8 "0.0" a13 F)) - (bcStrings (8 "0.0" a14 F)) - (text . "\newline ") - (bcStrings (8 "-1.53" a21 F)) - (bcStrings (8 "1.64" a22 F)) - (bcStrings (8 "0.0" a23 F)) - (bcStrings (8 "0.0" a24 F)) - (text . "\newline ") - (bcStrings (8 "0.28" a31 F)) - (bcStrings (8 "-0.25" a32 F)) - (bcStrings (8 "0.79" a33 F)) - (bcStrings (8 "0.0" a34 F)) - (text . "\newline ") - (bcStrings (8 "-0.05" a41 F)) - (bcStrings (8 "0.67" a42 F)) - (bcStrings (8 "0.66" a43 F)) - (bcStrings (8 "0.54" a44 F)) - (text . "\newline ") - (text . "\blankline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the matrix {\it B}:") - (text . "\newline ") - (bcStrings (8 "8.7" b11 F)) - (bcStrings (8 "8.3" b12 F)) - (text . "\newline ") - (bcStrings (8 "-13.35" b21 F)) - (bcStrings (8 "2.13" b22 F)) - (text . "\newline ") - (bcStrings (8 "1.89" b31 F)) - (bcStrings (8 "1.61" b32 F)) - (text . "\newline ") - (bcStrings (8 "-4.14" b41 F)) - (bcStrings (8 "5" b42 F))) - htpSetProperty(page,'uplo,uplo) - htpSetProperty(page,'n,n) - htpSetProperty(page,'nrhs,nrhs) --- htpSetProperty(page,'lda,lda) --- htpSetProperty(page,'ldb,ldb) - htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) - htMakeDoneButton('"Continue",'f07fefGen) - htShowPage() - -f07fefGen htPage == - n := htpProperty(htPage, 'n) - nrhs := htpProperty(htPage, 'nrhs) --- lda := htpProperty(htPage, 'lda) --- ldb := htpProperty(htPage, 'ldb) - lda := n - ldb := n - uplo := htpProperty(htPage,'uplo) - aplist := htpInputAreaAlist htPage - y := aplist - for i in 1..n repeat - for j in 1..nrhs repeat - b := STRCONC((first y).1," ") - rowList := [b,:rowList] - y := rest y - bList := [rowList,:bList] - rowList := [] - bstring := bcwords2liststring [bcwords2liststring x for x in bList] - for i in 1..lda repeat - for j in 1..n repeat - a := STRCONC((first y).1," ") - rowList := [a,:rowList] - y := rest y - aList := [rowList,:aList] - rowList := [] - astring := bcwords2liststring [bcwords2liststring x for x in aList] - prefix := STRCONC("f07fef(_"", uplo,"_", ",STRINGIMAGE n,", ") - prefix := STRCONC(prefix,STRINGIMAGE nrhs,", ",astring,"::Matrix DoubleFloat, ") - prefix := STRCONC(prefix,STRINGIMAGE lda,", ") - prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,"::Matrix DoubleFloat)") - linkGen prefix - diff --git a/src/interp/nag-f07.boot.pamphlet b/src/interp/nag-f07.boot.pamphlet new file mode 100644 index 00000000..3de2bb32 --- /dev/null +++ b/src/interp/nag-f07.boot.pamphlet @@ -0,0 +1,726 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-f07.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +f07adf() == + htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf07adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07adf| '|NagLapack|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F07ADF computes the {\it LU} factorization of a real {\it m}") + (text . " by {\it n} matrix ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of rows {\it m}:") + (text . "\newline\tab{2} ") + (bcStrings (5 4 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of columns {\it n}:") + (text . "\newline\tab{2} ") + (bcStrings (5 4 n PI)) + ) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of array A, {\it lda}:") +-- (text . "\newline\tab{2} ") +-- (bcStrings (5 4 lda PI)) + htMakeDoneButton('"Continue", 'f07adfSolve) + htShowPage() + +f07adfSolve htPage == + m := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) + objValUnwrap htpLabelSpadValue(htPage, 'm) + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := m + (n = '4 and m = '4) => f07adfDefaultSolve(htPage,lda) + aList := + "append"/[fa(i,n) for i in 1..m] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings,[6, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList] + page := htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the array {\it A}:" + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'f07adfGen) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07adfDefaultSolve (htPage,lda) == + n := '4 + m := '4 + page := htInitPage('"F07ADF - {\it LU} factorization of real {\it m} by {\it n} matrix",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the array {\it A}:") + (text . "\newline ") + (bcStrings (5 "1.8" a11 F)) + (bcStrings (5 "2.88" a12 F)) + (bcStrings (5 "2.05" a13 F)) + (bcStrings (5 "-0.89" a14 F)) + (text . "\newline ") + (bcStrings (5 "5.25" a21 F)) + (bcStrings (5 "-2.95" a22 F)) + (bcStrings (5 "-0.95" a23 F)) + (bcStrings (5 "-3.8" a24 F)) + (text . "\newline ") + (bcStrings (5 "1.58" a31 F)) + (bcStrings (5 "-2.69" a32 F)) + (bcStrings (5 "-2.9" a33 F)) + (bcStrings (5 "-1.04" a34 F)) + (text . "\newline ") + (bcStrings (5 "-1.11" a41 F)) + (bcStrings (5 "-0.66" a42 F)) + (bcStrings (5 "-0.59" a43 F)) + (bcStrings (5 "0.8" a44 F))) + htpSetProperty(page,'n,n) + htpSetProperty(page,'m,m) +-- htpSetProperty(page,'lda,lda) + htMakeDoneButton('"Continue",'f07adfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07adfGen htPage == + n := htpProperty(htPage, 'n) + m := htpProperty(htPage, 'm) + lda := m + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + for j in 1..m repeat + a := STRCONC((first y).1," ") + rowList := [a,:rowList] + y := rest y + aList := [rowList,:aList] + rowList := [] + astring := bcwords2liststring [bcwords2liststring x for x in aList] + prefix := STRCONC("f07adf(",STRINGIMAGE m,", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",astring,")") + linkGen prefix + + +f07aef() == + htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf07aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07aef| '|NagLapack|)} for this routine") + (text . "\newline \horizontalline ") + (text . "F07AEF solves a real system of linear equations with multiple right-hand sides, {\it AX=B} or ") + (text . "\htbitmap{aTx=b} , where {\it a} has been factorized by F07ADF ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Form of the equations:") + (text . "\blankline ") + (radioButtons trans + ("" " N, the equations are {\it AX=B}" norm) + ("" " T, the equations are \htbitmap{aTx=b}" transp)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The order {\it n} of {\it A}: ") + (text . "\newline ") + (bcStrings (5 4 n PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "The order {\it m} of {\it A} used by F07AEF: ") +-- (text . "\newline ") +-- (bcStrings (5 4 m PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The number of right-hand sides, {\it nrhs}: ") + (text . "\newline ") + (bcStrings (5 2 nrhs PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of {\it A}, {\it lda}: ") +-- (text . "\newline ") +-- (bcStrings (5 4 lda PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of {\it B}, {\it ldb}: ") +-- (text . "\newline ") +-- (bcStrings (5 4 ldb PI)) + ) + htMakeDoneButton('"Continue", 'f07aefSolve) + htShowPage() + +f07aefSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) +-- m := +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'm) +-- objValUnwrap htpLabelSpadValue(htPage, 'm) + nrhs := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrhs) + objValUnwrap htpLabelSpadValue(htPage, 'nrhs) + lda := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + equa := htpButtonValue(htPage, 'trans) + trans := + equa = 'norm => '"N" + '"T" + (n = '4 and nrhs = '2 ) => f07aefDefaultSolve (htPage,trans) + aList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[faa(i,j) for j in 1..n] where faa(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings, [6, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + ipList := + [fp(i) for i in 1..n] where fp(i) == + ipnam := INTERN STRCONC ('"ip",STRINGIMAGE i) + ['bcStrings,[5, 0, ipnam, 'I]] + middle := ('"\blankline \menuitemstyle{}\tab{2} Enter the pivot ") + middle := STRCONC(middle,'"indices {\it IPIV} from F07ADF: ") + middle := STRCONC(middle,'"\newline ") + ipList := [['text,:middle],:ipList] + bList := + "append"/[fb(i,nrhs) for i in 1..n] where fb(i,nrhs) == + labelList := + "append"/[fbb(i,j) for j in 1..nrhs] where fbb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings, [6, 0, bnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it B}: ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))) + ,:aList,:ipList,:bList] + page := htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the matrix {\it A}:" + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'f07aefGen) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'m,m) + htpSetProperty(page,'nrhs,nrhs) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07aefDefaultSolve (htPage,trans) == + n := '4 + nrhs := '2 + lda := '4 + ldb := '4 + length := '4 + page := htInitPage('"F07AEF - Solution of a real system of linear equations with multiple right-hand sides after factorization by F07ADF",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it A}:") + (text . "\newline ") + (bcStrings (5 "5.25" a11 F)) + (bcStrings (5 "-2.95" a12 F)) + (bcStrings (5 "-0.95" a13 F)) + (bcStrings (5 "-3.8" a14 F)) + (text . "\newline ") + (bcStrings (5 "0.34" a21 F)) + (bcStrings (5 "3.89" a22 F)) + (bcStrings (5 "2.38" a23 F)) + (bcStrings (5 "0.41" a24 F)) + (text . "\newline ") + (bcStrings (5 "0.3" a31 F)) + (bcStrings (5 "-0.46" a32 F)) + (bcStrings (5 "-1.51" a33 F)) + (bcStrings (5 "0.29" a34 F)) + (text . "\newline ") + (bcStrings (5 "-0.21" a41 F)) + (bcStrings (5 "-0.33" a42 F)) + (bcStrings (5 "0.00" a43 F)) + (bcStrings (5 "0.13" a44 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the pivot indices {\it IPIV} from F07ADF: ") + (text . "\newline ") + (bcStrings (5 2 ip1 PI)) + (bcStrings (5 2 ip2 PI)) + (bcStrings (5 3 ip3 PI)) + (bcStrings (5 4 ip4 PI)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it B}:") + (text . "\newline ") + (bcStrings (5 "9.52" b11 F)) + (bcStrings (5 "18.47" b12 F)) + (text . "\newline ") + (bcStrings (5 "24.35" b21 F)) + (bcStrings (5 "2.25" b22 F)) + (text . "\newline ") + (bcStrings (5 "0.77" b31 F)) + (bcStrings (5 "-13.28" b32 F)) + (text . "\newline ") + (bcStrings (5 "-6.22" b41 F)) + (bcStrings (5 "-6.21" b42 F))) + htpSetProperty(page,'trans,trans) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nrhs,nrhs) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'length,length) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htMakeDoneButton('"Continue",'f07aefGen) + htShowPage() + +f07aefGen htPage == + n := htpProperty(htPage, 'n) + nrhs := htpProperty(htPage, 'nrhs) +-- lda := htpProperty(htPage, 'lda) +-- ldb := htpProperty(htPage, 'ldb) + lda := n + ldb := n + length := htpProperty(htPage, 'length) + trans := htpProperty(htPage,'trans) + aplist := htpInputAreaAlist htPage + y := aplist + for i in 1..n repeat + for j in 1..nrhs repeat + b := STRCONC((first y).1," ") + rowList := [b,:rowList] + y := rest y + bList := [rowList,:bList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bList] + for i in 1..length repeat + ip := STRCONC((first y).1," ") + ipList := [ip,:ipList] + y := rest y + ipstring := bcwords2liststring ipList + for i in 1..lda repeat + for j in 1..n repeat + a := STRCONC((first y).1," ") + rowList := [a,:rowList] + y := rest y + aList := [rowList,:aList] + rowList := [] + astring := bcwords2liststring [bcwords2liststring x for x in aList] + prefix := STRCONC("f07aef(_"", trans,"_", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrhs,", ",astring,"::Matrix DoubleFloat, ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", [",ipstring,"]::Matrix INT, ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,"::Matrix DoubleFloat)") + linkGen prefix + +f07fdf() == + htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf07fdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07fdf| '|NagLapack|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F07FDF computes the Cholesky factorization of a real symmetric positive-definite ") + (text . "matrix {\it A} ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Method of factorization of {\it A}, {\it UPLO}:") + (text . "\blankline ") + (radioButtons uplo + ("" " L, {\it A} factorized as lower triangular" lower) + ("" " U, {\it A} factorized as upper triangular" upper)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The order {\it n} of {\it A}: ") + (text . "\newline ") + (bcStrings (5 4 n PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of {\it A}, {\it lda}:") +-- (text . "\newline ") +-- (bcStrings (5 4 lda PI))) + ) + htMakeDoneButton('"Continue", 'f07fdfSolve) + htShowPage() + +f07fdfSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + lda := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + upl := htpButtonValue(htPage, 'uplo) + uplo:= + upl = 'lower => '"L" + '"U" + (n = '4 ) => f07fdfDefaultSolve(htPage,uplo) + aList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[fb(i,j) for j in 1..n] where fb(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings, [6, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))), + :aList] + page := htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the matrix {\it A}:" + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'f07fdfGen) + htpSetProperty(page,'uplo,uplo) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'lda,lda) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07fdfDefaultSolve (htPage,uplo) == + n := '4 + lda := '4 + page := htInitPage('"F07FDF - Cholesky factorization of a real symmmetric positive-definite matrix {\it A}",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it A}:") + (text . "\newline ") + (bcStrings (5 "4.16" a11 F)) + (bcStrings (5 "0.0" a12 F)) + (bcStrings (5 "0.0" a13 F)) + (bcStrings (5 "0.0" a14 F)) + (text . "\newline ") + (bcStrings (5 "-3.12" a21 F)) + (bcStrings (5 "5.03" a22 F)) + (bcStrings (5 "0.0" a23 F)) + (bcStrings (5 "0.0" a24 F)) + (text . "\newline ") + (bcStrings (5 "0.56" a31 F)) + (bcStrings (5 "-0.83" a32 F)) + (bcStrings (5 "0.76" a33 F)) + (bcStrings (5 "0.0" a34 F)) + (text . "\newline ") + (bcStrings (5 "-0.1" a41 F)) + (bcStrings (5 "1.18" a42 F)) + (bcStrings (5 "0.34" a43 F)) + (bcStrings (5 "1.18" a44 F))) + htpSetProperty(page,'uplo,uplo) + htpSetProperty(page,'n,n) +-- htpSetProperty(page,'lda,lda) + htMakeDoneButton('"Continue",'f07fdfGen) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07fdfGen htPage == + n := htpProperty(htPage, 'n) +-- lda := htpProperty(htPage, 'lda) + lda := n + uplo := htpProperty(htPage,'uplo) + alist := htpInputAreaAlist htPage + y := alist + for i in 1..n repeat + for j in 1..n repeat + a := STRCONC((first y).1," ") + rowList := [a,:rowList] + y := rest y + aList := [rowList,:aList] + rowList := [] + astring := bcwords2liststring [bcwords2liststring x for x in aList] + prefix := STRCONC("f07fdf(_"", uplo,"_", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ",astring,")") + linkGen prefix + + +f07fef() == + htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) + htMakePage '( + (domainConditions + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXf07fef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|f07fef| '|NagLapack|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "F07FEF solves a real symmetric positive-definite system of linear ") + (text . "equations with multiple right-hand sides, {\it AX=B}, where ") + (text . "{\it A} has been factorized by F07FDF ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Method of factorization of {\it A}, {\it UPLO}:") + (text . "\blankline ") + (radioButtons uplo + ("" " L, {\it A} factorized as lower triangular" lower) + ("" " U, {\it A} factorized as upper triangular" upper)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The order {\it n} of {\it A}: ") + (text . "\newline ") + (bcStrings (5 4 n PI)) + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "The number of right-hand sides, {\it nrhs}: ") + (text . "\newline ") + (bcStrings (5 2 nrhs PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of {\it A}, {\it lda}: ") +-- (text . "\newline ") +-- (bcStrings (5 4 lda PI)) +-- (text . "\blankline ") +-- (text . "\menuitemstyle{}\tab{2}") +-- (text . "First dimension of {\it B}, {\it ldb}: ") +-- (text . "\newline ") +-- (bcStrings (5 4 ldb PI))) + ) + htMakeDoneButton('"Continue", 'f07fefSolve) + htShowPage() + +f07fefSolve htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + nrhs := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'nrhs) + objValUnwrap htpLabelSpadValue(htPage, 'nrhs) + lda := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'lda) +-- objValUnwrap htpLabelSpadValue(htPage, 'lda) + ldb := n +-- $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'ldb) +-- objValUnwrap htpLabelSpadValue(htPage, 'ldb) + upl := htpButtonValue(htPage, 'uplo) + uplo:= + upl = 'lower => '"L" + '"U" + (n = '4 and nrhs = '2) => f07fefDefaultSolve(htPage,uplo) + aList := + "append"/[fa(i,n) for i in 1..lda] where fa(i,n) == + labelList := + "append"/[faa(i,j) for j in 1..n] where faa(i,j) == + anam := INTERN STRCONC ('"a",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings, [8, 0, anam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + bList := + "append"/[fb(i,nrhs) for i in 1..n] where fb(i,nrhs) == + labelList := + "append"/[fbb(i,j) for j in 1..nrhs] where fbb(i,j) == + bnam := INTERN STRCONC ('"b",STRINGIMAGE i,STRINGIMAGE j) + [['bcStrings, [8, 0, bnam, 'F]]] + prefix := ('"\newline ") + labelList := [['text,:prefix],:labelList] + prefix := ("\blankline \menuitemstyle{}\tab{2} Enter the matrix {\it B}: ") + bList := [['text,:prefix],:bList] + equationPart := [ + '(domainConditions + (isDomain EM $EmptyMode) + (isDomain S (String)) + (isDomain F (Float)) + (isDomain I (Integer))) + ,:aList,:bList] + page := htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) + htSay '"\menuitemstyle{}\tab{2} " + htSay '"Enter the matrix {\it A}:" + htSay '"\newline " + htMakePage equationPart + htMakeDoneButton('"Continue",'f07fefGen) + htpSetProperty(page,'uplo,uplo) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nrhs,nrhs) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htShowPage() + +f07fefDefaultSolve (htPage,uplo) == + n := '4 + nrhs := '2 + lda := '4 + ldb := '4 + page := htInitPage('"F07FEF - Solution of a real symmetric positive-definite system of linear equations with multiple right-hand sides after factorization by F07FDF",nil) + htMakePage '( + (domainConditions + (isDomain EM $EmptyMode) + (isDomain F (Float)) + (isDomain I (Integer))) + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it A}:") + (text . "\newline ") + (bcStrings (8 "2.04" a11 F)) + (bcStrings (8 "0.0" a12 F)) + (bcStrings (8 "0.0" a13 F)) + (bcStrings (8 "0.0" a14 F)) + (text . "\newline ") + (bcStrings (8 "-1.53" a21 F)) + (bcStrings (8 "1.64" a22 F)) + (bcStrings (8 "0.0" a23 F)) + (bcStrings (8 "0.0" a24 F)) + (text . "\newline ") + (bcStrings (8 "0.28" a31 F)) + (bcStrings (8 "-0.25" a32 F)) + (bcStrings (8 "0.79" a33 F)) + (bcStrings (8 "0.0" a34 F)) + (text . "\newline ") + (bcStrings (8 "-0.05" a41 F)) + (bcStrings (8 "0.67" a42 F)) + (bcStrings (8 "0.66" a43 F)) + (bcStrings (8 "0.54" a44 F)) + (text . "\newline ") + (text . "\blankline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the matrix {\it B}:") + (text . "\newline ") + (bcStrings (8 "8.7" b11 F)) + (bcStrings (8 "8.3" b12 F)) + (text . "\newline ") + (bcStrings (8 "-13.35" b21 F)) + (bcStrings (8 "2.13" b22 F)) + (text . "\newline ") + (bcStrings (8 "1.89" b31 F)) + (bcStrings (8 "1.61" b32 F)) + (text . "\newline ") + (bcStrings (8 "-4.14" b41 F)) + (bcStrings (8 "5" b42 F))) + htpSetProperty(page,'uplo,uplo) + htpSetProperty(page,'n,n) + htpSetProperty(page,'nrhs,nrhs) +-- htpSetProperty(page,'lda,lda) +-- htpSetProperty(page,'ldb,ldb) + htpSetProperty(page,'inputArea, htpInputAreaAlist htPage) + htMakeDoneButton('"Continue",'f07fefGen) + htShowPage() + +f07fefGen htPage == + n := htpProperty(htPage, 'n) + nrhs := htpProperty(htPage, 'nrhs) +-- lda := htpProperty(htPage, 'lda) +-- ldb := htpProperty(htPage, 'ldb) + lda := n + ldb := n + uplo := htpProperty(htPage,'uplo) + aplist := htpInputAreaAlist htPage + y := aplist + for i in 1..n repeat + for j in 1..nrhs repeat + b := STRCONC((first y).1," ") + rowList := [b,:rowList] + y := rest y + bList := [rowList,:bList] + rowList := [] + bstring := bcwords2liststring [bcwords2liststring x for x in bList] + for i in 1..lda repeat + for j in 1..n repeat + a := STRCONC((first y).1," ") + rowList := [a,:rowList] + y := rest y + aList := [rowList,:aList] + rowList := [] + astring := bcwords2liststring [bcwords2liststring x for x in aList] + prefix := STRCONC("f07fef(_"", uplo,"_", ",STRINGIMAGE n,", ") + prefix := STRCONC(prefix,STRINGIMAGE nrhs,", ",astring,"::Matrix DoubleFloat, ") + prefix := STRCONC(prefix,STRINGIMAGE lda,", ") + prefix := STRCONC(prefix,STRINGIMAGE ldb,", ",bstring,"::Matrix DoubleFloat)") + linkGen prefix + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nag-s.boot b/src/interp/nag-s.boot deleted file mode 100644 index 21017e3a..00000000 --- a/src/interp/nag-s.boot +++ /dev/null @@ -1,1582 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -s01eaf() == - page := htInitPage("S01EAF - Complex exponential {\em exp(z)} ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs01eaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s01eaf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Evaluates the exponential function, exp(z), for complex z. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "-0.5" x F)) - (text . "\tab{34} ") - (bcStrings (10 "2.0" y F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's01eafGen) - htShowPage() - -s01eafGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC('"s01eaf(complex(",x,",",y,"),",STRINGIMAGE ifail,")") - - - -s13aaf() == - page := htInitPage("S13AAF - Exponential integral \htbitmap{s13aaf2}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs13aaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13aaf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the exponential integral \vspace{-32} ") - (text . "\htbitmap{s13aaf1} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "2.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s13aaf") - htShowPage() - -s13acf() == - page := htInitPage("S13ACF - Cosine integral {\em Ci(x)} ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs13acf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13acf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the cosine integral \space{1} ") - (text . "\htbitmap{s13acf} ") - (text . ", where \gamma denotes Euler's constant. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.2" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s13acf") - htShowPage() - -s13adf() == - page := htInitPage("S13ADF - Sine integral Si(x) ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs13adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the sine integral \space{1} \vspace{-32} ") - (text . "\inputbitmap{\htbmdir{}/s13adf.bitmap} \vspace{-37}. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.2" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s13adf") - htShowPage() - -s14aaf() == - page := htInitPage("S14AAF - Gamma Function \Gamma(x) ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs14aaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14aaf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the gamma function, {\em Gamma(x)}. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "1.25" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s14aaf") - htShowPage() - -s14abf() == - page := htInitPage("S14ABF - Log Gamma Function \Gamma(x) ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs14abf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14abf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the logarithm of the gamma function, ") - (text . "{\em ln Gamma(x)}. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "1.25" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s14abf") - htShowPage() - -s14baf() == - htInitPage("S14BAF - Incomplete Gamma Functions P(a,x) & Q(a,x)",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs14baf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14baf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the incomplete gamma functions, \space{1} ") - (text . "\vspace{-32} \inputbitmap{\htbmdir{}/s14baf.bitmap} \vspace{-37}, ") - (text . "which are normalised such that P(a,x) + Q(a,x) = 1. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Enter the value of {\em a}: > 0.0") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Enter the value of {\em x}: >= 0.0 ") - (text . "\newline\tab{2} ") - (bcStrings (10 "2.0" a F)) - (text . "\tab{34} ") - (bcStrings (10 "3.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the tolerance:") - (text . "\newline\tab{2} ") - (bcStrings (30 "1.1102230246251600E-16" tol F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's14bafGen) - htShowPage() - -s14bafGen htPage == - a := htpLabelInputString(htPage,'a) - x := htpLabelInputString(htPage,'x) - tol := htpLabelInputString(htPage,'tol) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC('"s14baf(",a,",",x,",",tol,",",STRINGIMAGE ifail,")") - -s15adf() == - page := htInitPage("S15ADF - Complement of error function erfc x",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs15adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s15adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the complementary gamma functions, erfc x = ") - (text . "\space{1} \vspace{-32} \inputbitmap{\htbmdir{}/s15adf.bitmap} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-10.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s15adf") - htShowPage() - -s15aef() == - page := htInitPage("S15AEF - Error Function erf x", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs15aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s15aef| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the error function, erf x = \space{1} ") - (text . "\vspace{-32} \inputbitmap{\htbmdir{}/s15aef.bitmap} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-6.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s15aef") - htShowPage() - -s17acf() == - page := htInitPage("S17ACF - Bessel Function \space{1} \htbitmap{s17acf}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17acf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17acf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Bessel function \space{1} \htbitmap{s17acf}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17acf") - htShowPage() - -s17adf() == - page := htInitPage("S17ADF - Bessel Function \space{1} \htbitmap{s17adf}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Bessel function \space{1} \htbitmap{s17adf}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17adf") - htShowPage() - -s17aef() == - page := htInitPage("S17AEF - Bessel Function \space{1} \htbitmap{s17aef}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17aef| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Bessel function \space{1}") - (text . "\htbitmap{s17aef}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17aef") - htShowPage() - -s17aff() == - page := htInitPage("S17AFF - Bessel Function \space{1} \htbitmap{s17aff}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17aff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17aff| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Bessel function \space{1} \htbitmap{s17aff}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17aff") - htShowPage() - -s17agf() == - page := htInitPage("S17AGF - Airy Function {\em Ai(x)}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17agf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17agf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Airy function {\em Ai(x)} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-10.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17agf") - htShowPage() - -s17ahf() == - page := htInitPage("S17AHF - Airy Function {\em Bi(x)}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17ahf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17ahf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Airy function {\em Bi(x)} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-10.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17ahf") - htShowPage() - -s17ajf() == - page := htInitPage("S17AJF - Airy Function {\em Ai'(x)}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17ajf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17ajf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates {\em Ai'(x)}, ") - (text . "the derivative of the Airy function Ai(x) ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-10.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17ajf") - htShowPage() - -s17akf() == - page := htInitPage("S17AKF - Airy Function {\em Bi'(x)}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs17akf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17akf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates {\em Bi'(x)}, ") - (text . "the derivative of the Airy function Bi(x) ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "-10.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s17akf") - htShowPage() - -s17dcf() == - htInitPage('"S17DCF - Bessel function \htbitmap{s17dcf}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs17dcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dcf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns a sequence of values for the Bessel functions ") - (text . "\htbitmap{s17dcf}, for complex z, non-negative v ") - (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Order v of the first member of the sequence of functions ") - (text . "{\it FNU} \htbitmap{great=} 0:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" fnu F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of members required in sequence {\it N} ") - (text . "\htbitmap{great=} 1:") - (text . "\newline \tab{2} ") - (bcStrings (10 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's17dcfGen) - htShowPage() - - -s17dcfGen htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fnu := htpLabelInputString(htPage,'fnu) - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s17dcf(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) - prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - -s17def() == - htInitPage('"S17DEF - Bessel function \htbitmap{s17def}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs17def} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17def| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns a sequence of values for the Bessel functions ") - (text . "\htbitmap{s17def}, for complex z, non-negative v ") - (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Order v of the first member of the sequence of functions ") - (text . "{\it FNU} \htbitmap{great=} 0:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" fnu F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of members required in sequence {\it N} ") - (text . "\htbitmap{great=} 1:") - (text . "\newline \tab{2} ") - (bcStrings (10 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's17defGen) - htShowPage() - - -s17defGen htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fnu := htpLabelInputString(htPage,'fnu) - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s17def(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) - prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - - -s17dgf() == - htInitPage('"S17DGF - Airy functions {\em Ai(z)} and {\em Ai'(z)} ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs17dgf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dgf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Evaluates the Airy function Ai(z) or its derivative Ai'(z), ") - (text . "for complex z, with an option for exponential scaling. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Function or derivative required: ") - (radioButtons deriv - ("" " Function" f) - ("" " Derivative" d)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's17dgfGen) - htShowPage() - - -s17dgfGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - ford := htpButtonValue(htPage,'deriv) - deriv := - ford = 'f => '"f" - '"d" - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s17dgf(_"",deriv,"_",complex(",x,",",y,"),_"") - prefix := STRCONC(prefix,scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - -s17dhf() == - htInitPage('"S17DHF - Airy functions {\em Bi(z)} and {\em Bi'(z)} ",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs17dhf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dhf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Evaluates the Airy function Bi(z) or its derivative Bi'(z), ") - (text . "for complex z, with an option for exponential scaling. ") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Function or derivative required: ") - (radioButtons deriv - ("" " Function" f) - ("" " Derivative" d)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's17dhfGen) - htShowPage() - - -s17dhfGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - ford := htpButtonValue(htPage,'deriv) - deriv := - ford = 'f => '"f" - '"d" - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s17dhf(_"",deriv,"_",complex(",x,",",y,"),_"") - prefix := STRCONC(prefix,scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - - -s17dlf() == - htInitPage('"S17DLF - Hankel function \vspace{-28} \htbitmap{s17dlf} \vspace{-37}, j = 1,2, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs17dlf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dlf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns a sequence of values for the Hankel functions ") - (text . "\htbitmap{s17dlf}, j = 1,2, for complex z, ") - (text . "non-negative v ") - (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Order v of the first member of the sequence of functions ") - (text . "{\it FNU} \htbitmap{great=} 0:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" fnu F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of members required in sequence {\it N} ") - (text . "\htbitmap{great=} 1:") - (text . "\newline \tab{2} ") - (bcStrings (10 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Hankel function {\it m}: ") - (radioButtons hankel - ("" " \htbitmap{s17dlf1}" mone) - ("" " \htbitmap{s17dlf2}" mtwo)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's17dlfGen) - htShowPage() - - -s17dlfGen htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fnu := htpLabelInputString(htPage,'fnu) - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - hankel := htpButtonValue(htPage,'hankel) - m := - hankel = 'mone => '1 - '2 - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s17dlf(",STRINGIMAGE m,", ",fnu,",complex(") - prefix := STRCONC(prefix,x,",",y,"),",STRINGIMAGE n) - prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - - -s18acf() == - page := htInitPage("S18ACF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18acf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs18acf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18acf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") - (text . "\inputbitmap{\htbmdir{}/s18acf.bitmap} \vspace{-40}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.4" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s18acf") - htShowPage() - -s18adf() == - page := htInitPage("S18ADF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18adf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs18adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") - (text . "\inputbitmap{\htbmdir{}/s18adf.bitmap} \vspace{-40}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.4" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s18adf") - htShowPage() - -s18aef() == - page := htInitPage("S18AeF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18aef1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs18aef} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18aef| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") - (text . "\inputbitmap{\htbmdir{}/s18aef.bitmap} \vspace{-40}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s18aef") - htShowPage() - -s18aff() == - page := htInitPage("S18AFF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18aff1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs18aff} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18aff| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") - (text . "\inputbitmap{\htbmdir{}/s18aff.bitmap} \vspace{-40}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s18aff") - htShowPage() - -s18dcf() == - htInitPage('"S18DCF - Bessel function \htbitmap{s18dcf}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs18dcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18dcf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns a sequence of values for the modified Bessel functions ") - (text . "\htbitmap{s18dcf}, for complex z, non-negative v ") - (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Order v of the first member of the sequence of functions ") - (text . "{\it FNU} \htbitmap{great=} 0:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" fnu F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of members required in sequence {\it N} ") - (text . "\htbitmap{great=} 1:") - (text . "\newline \tab{2} ") - (bcStrings (10 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's18dcfGen) - htShowPage() - - -s18dcfGen htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fnu := htpLabelInputString(htPage,'fnu) - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s18dcf(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) - prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - -s18def() == - htInitPage('"S18DEF - Modified bessel function \htbitmap{s18def}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) - htMakePage '( - (domainConditions - (isDomain F (Float)) - (isDomain PI (PositiveInteger))) - (text . "\windowlink{Manual Page}{manpageXXs18def} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18def| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\newline ") - (text . "Returns a sequence of values for the modified Bessel functions ") - (text . "\htbitmap{s18def}, for complex z, non-negative v ") - (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Order v of the first member of the sequence of functions ") - (text . "{\it FNU} \htbitmap{great=} 0:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.0" fnu F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Real part of {\it z}:") - (text . "\tab{32} \menuitemstyle{}\tab{34}") - (text . "Imaginary part of {\it z}:") - (text . "\newline \tab{2} ") - (bcStrings (10 "0.3" x F)) - (text . "\tab{34} ") - (bcStrings (10 "-0.4" y F)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Number of members required in sequence {\it N} ") - (text . "\htbitmap{great=} 1:") - (text . "\newline \tab{2} ") - (bcStrings (10 2 n PI)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Scaling option: ") - (radioButtons scale - ("" " Unscaled" u) - ("" " Scaled" s)) - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{} \tab{2} ") - (text . "\newline \tab{2} ") - (text . "Ifail value: ") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's18defGen) - htShowPage() - - -s18defGen htPage == - n := - $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) - objValUnwrap htpLabelSpadValue(htPage, 'n) - fnu := htpLabelInputString(htPage,'fnu) - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - uors := htpButtonValue(htPage,'scale) - scale := - uors = 'u => '"u" - '"s" - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - prefix := STRCONC('"s18def(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) - prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") - linkGen prefix - - -s19aaf() == - page := htInitPage("S19AAF - Kelvin Function {\em ber x}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs19aaf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19aaf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Kelvin function {\em ber x}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "1.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s19aaf") - htShowPage() - -s19abf() == - page := htInitPage("S19ABF - Kelvin Function {\em bei x}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs19abf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19abf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Kelvin function {\em bei x}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.1" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s19abf") - htShowPage() - -s19acf() == - page := htInitPage("S19ACF - Kelvin Function {\em ker x}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs19acf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19acf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Kelvin function {\em ker x}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x > 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.1" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s19acf") - htShowPage() - -s19adf() == - page := htInitPage("S19AAF - Kelvin Function {\em kei x}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs19adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Kelvin function {\em kei x}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x \inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.0" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s19adf") - htShowPage() - -s20acf() == - page := htInitPage("S20ACF - Fresnel Integral {\em S(x)}",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs20acf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s20acf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Fresnel Integral {\em S(x)}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s20acf") - htShowPage() - -s20adf() == - page := htInitPage("S20ADF - Fresnel Integral {\em C(x)}",nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs20adf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s20adf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the Fresnel Integral {\em C(x)}") - (text . "\blankline ") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument x: ") - (text . "\newline\tab{2} ") - (bcStrings (9 "0.5" x F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 'sGen) - htpSetProperty(page,'routine,"s20adf") - htShowPage() - -s21baf() == - htInitPage("S21BAF - Degenerate Symmetrised Elliptic Integral of 1st Kind \vspace{-28} \inputbitmap{\htbmdir{}/s21baf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs21baf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21baf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the elementary (degenerate symmetrised elliptic) ") - (text . " integral \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21baf.bitmap} ") - (text . "\blankline ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Enter the argument y \notequal 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.5" x F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0" y F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's21bafGen) - htShowPage() - -s21bafGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC("s21baf(",x,'",",y,",",STRINGIMAGE ifail,'")") - -s21bbf() == - htInitPage("S21BBF - Symmetrised Elliptic Integral of 1st Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bbf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs21bbf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bbf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the symmetrised elliptic integral of the first kind ") - (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bbf.bitmap} ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.5" x F)) - (text . "\tab{34} ") - (bcStrings (10 "1.0" y F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument z \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0; ") - (text . "at most one of x,y and z may be equal to 0.0: \newline \tab{2}") - (bcStrings (10 "1.5" z F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's21bbfGen) - htShowPage() - -s21bbfGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - z := htpLabelInputString(htPage,'z) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC("s21bbf(",x,'",",y,",",z,",",STRINGIMAGE ifail,'")") - -s21bcf() == - htInitPage("S21BCF - Symmetrised Elliptic Integral of 2nd Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bcf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs21bcf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bcf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the symmetrised elliptic integral of the second kind ") - (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bcf.bitmap} ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.5" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.5" y F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument z > 0.0; ") - (text . "at most one of x, y and z may be equal to 0.0: \newline \tab{2}") - (bcStrings (10 "1.0" z F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's21bcfGen) - htShowPage() - -s21bcfGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - z := htpLabelInputString(htPage,'z) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC("s21bcf(",x,'",",y,",",z,",",STRINGIMAGE ifail,'")") - -s21bdf() == - htInitPage("S21BDF - Symmetrised Elliptic Integral of 3rd Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bdf1.bitmap}", nil) - htMakePage '( - (domainConditions - (isDomain F (Float))) - (text . "\windowlink{Manual Page}{manpageXXs21bdf} for this routine ") - (text . "\newline ") - (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bdf| '|NagSpecialFunctionsPackage|)} for this routine") - (text . "\newline \horizontalline ") - (text . "\blankline ") - (text . "Evaluates the symmetrised elliptic integral of the third kind ") - (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bdf.bitmap} ") - (text . "\newline ") - (text . "\blankline ") - (text . "\newline \menuitemstyle{}\tab{2} ") - (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\tab{32} \menuitemstyle{}\tab{34} ") - (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") - (text . "\newline\tab{2} ") - (bcStrings (10 "0.5" x F)) - (text . "\tab{34} ") - (bcStrings (10 "0.5" y F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument z \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0; ") - (text . "at most one of x, y and z may be equal to 0.0: \newline \tab{2}") - (bcStrings (10 "0.5" z F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Enter the argument \rho \notequal 0.0: \newline \tab{2} ") - (bcStrings (10 "2.0" r F)) - (text . "\blankline") - (text . "\newline ") - (text . "\menuitemstyle{}\tab{2}") - (text . "Ifail value:") - (radioButtons ifail - ("" " -1, Print error messages" minusOne) - ("" " 1, Suppress error messages" one))) - htMakeDoneButton('"Continue", 's21bdfGen) - htShowPage() - -s21bdfGen htPage == - x := htpLabelInputString(htPage,'x) - y := htpLabelInputString(htPage,'y) - z := htpLabelInputString(htPage,'z) - r := htpLabelInputString(htPage,'r) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC("s21bdf(",x,'",",y,",",z,",",r,",",STRINGIMAGE ifail,'")") - -sGen htPage == - routine := htpProperty(htPage,'routine) - x := htpLabelInputString(htPage,'x) - error := htpButtonValue(htPage,'ifail) - ifail := - error = 'one => 1 - -1 - linkGen STRCONC(routine,"(",x,'",",STRINGIMAGE ifail,'")") - diff --git a/src/interp/nag-s.boot.pamphlet b/src/interp/nag-s.boot.pamphlet new file mode 100644 index 00000000..1e2d0486 --- /dev/null +++ b/src/interp/nag-s.boot.pamphlet @@ -0,0 +1,1604 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nag-s.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +s01eaf() == + page := htInitPage("S01EAF - Complex exponential {\em exp(z)} ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs01eaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s01eaf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Evaluates the exponential function, exp(z), for complex z. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "-0.5" x F)) + (text . "\tab{34} ") + (bcStrings (10 "2.0" y F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's01eafGen) + htShowPage() + +s01eafGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC('"s01eaf(complex(",x,",",y,"),",STRINGIMAGE ifail,")") + + + +s13aaf() == + page := htInitPage("S13AAF - Exponential integral \htbitmap{s13aaf2}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs13aaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13aaf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the exponential integral \vspace{-32} ") + (text . "\htbitmap{s13aaf1} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "2.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s13aaf") + htShowPage() + +s13acf() == + page := htInitPage("S13ACF - Cosine integral {\em Ci(x)} ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs13acf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13acf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the cosine integral \space{1} ") + (text . "\htbitmap{s13acf} ") + (text . ", where \gamma denotes Euler's constant. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.2" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s13acf") + htShowPage() + +s13adf() == + page := htInitPage("S13ADF - Sine integral Si(x) ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs13adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s13adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the sine integral \space{1} \vspace{-32} ") + (text . "\inputbitmap{\htbmdir{}/s13adf.bitmap} \vspace{-37}. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.2" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s13adf") + htShowPage() + +s14aaf() == + page := htInitPage("S14AAF - Gamma Function \Gamma(x) ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs14aaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14aaf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the gamma function, {\em Gamma(x)}. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "1.25" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s14aaf") + htShowPage() + +s14abf() == + page := htInitPage("S14ABF - Log Gamma Function \Gamma(x) ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs14abf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14abf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the logarithm of the gamma function, ") + (text . "{\em ln Gamma(x)}. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "1.25" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s14abf") + htShowPage() + +s14baf() == + htInitPage("S14BAF - Incomplete Gamma Functions P(a,x) & Q(a,x)",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs14baf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s14baf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the incomplete gamma functions, \space{1} ") + (text . "\vspace{-32} \inputbitmap{\htbmdir{}/s14baf.bitmap} \vspace{-37}, ") + (text . "which are normalised such that P(a,x) + Q(a,x) = 1. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Enter the value of {\em a}: > 0.0") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Enter the value of {\em x}: >= 0.0 ") + (text . "\newline\tab{2} ") + (bcStrings (10 "2.0" a F)) + (text . "\tab{34} ") + (bcStrings (10 "3.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the tolerance:") + (text . "\newline\tab{2} ") + (bcStrings (30 "1.1102230246251600E-16" tol F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's14bafGen) + htShowPage() + +s14bafGen htPage == + a := htpLabelInputString(htPage,'a) + x := htpLabelInputString(htPage,'x) + tol := htpLabelInputString(htPage,'tol) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC('"s14baf(",a,",",x,",",tol,",",STRINGIMAGE ifail,")") + +s15adf() == + page := htInitPage("S15ADF - Complement of error function erfc x",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs15adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s15adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the complementary gamma functions, erfc x = ") + (text . "\space{1} \vspace{-32} \inputbitmap{\htbmdir{}/s15adf.bitmap} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-10.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s15adf") + htShowPage() + +s15aef() == + page := htInitPage("S15AEF - Error Function erf x", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs15aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s15aef| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the error function, erf x = \space{1} ") + (text . "\vspace{-32} \inputbitmap{\htbmdir{}/s15aef.bitmap} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-6.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s15aef") + htShowPage() + +s17acf() == + page := htInitPage("S17ACF - Bessel Function \space{1} \htbitmap{s17acf}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17acf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17acf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Bessel function \space{1} \htbitmap{s17acf}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17acf") + htShowPage() + +s17adf() == + page := htInitPage("S17ADF - Bessel Function \space{1} \htbitmap{s17adf}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Bessel function \space{1} \htbitmap{s17adf}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17adf") + htShowPage() + +s17aef() == + page := htInitPage("S17AEF - Bessel Function \space{1} \htbitmap{s17aef}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17aef| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Bessel function \space{1}") + (text . "\htbitmap{s17aef}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17aef") + htShowPage() + +s17aff() == + page := htInitPage("S17AFF - Bessel Function \space{1} \htbitmap{s17aff}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17aff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17aff| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Bessel function \space{1} \htbitmap{s17aff}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17aff") + htShowPage() + +s17agf() == + page := htInitPage("S17AGF - Airy Function {\em Ai(x)}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17agf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17agf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Airy function {\em Ai(x)} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-10.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17agf") + htShowPage() + +s17ahf() == + page := htInitPage("S17AHF - Airy Function {\em Bi(x)}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17ahf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17ahf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Airy function {\em Bi(x)} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-10.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17ahf") + htShowPage() + +s17ajf() == + page := htInitPage("S17AJF - Airy Function {\em Ai'(x)}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17ajf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17ajf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates {\em Ai'(x)}, ") + (text . "the derivative of the Airy function Ai(x) ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-10.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17ajf") + htShowPage() + +s17akf() == + page := htInitPage("S17AKF - Airy Function {\em Bi'(x)}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs17akf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17akf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates {\em Bi'(x)}, ") + (text . "the derivative of the Airy function Bi(x) ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "-10.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s17akf") + htShowPage() + +s17dcf() == + htInitPage('"S17DCF - Bessel function \htbitmap{s17dcf}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs17dcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dcf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns a sequence of values for the Bessel functions ") + (text . "\htbitmap{s17dcf}, for complex z, non-negative v ") + (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Order v of the first member of the sequence of functions ") + (text . "{\it FNU} \htbitmap{great=} 0:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" fnu F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of members required in sequence {\it N} ") + (text . "\htbitmap{great=} 1:") + (text . "\newline \tab{2} ") + (bcStrings (10 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's17dcfGen) + htShowPage() + + +s17dcfGen htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fnu := htpLabelInputString(htPage,'fnu) + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s17dcf(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) + prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + +s17def() == + htInitPage('"S17DEF - Bessel function \htbitmap{s17def}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs17def} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17def| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns a sequence of values for the Bessel functions ") + (text . "\htbitmap{s17def}, for complex z, non-negative v ") + (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Order v of the first member of the sequence of functions ") + (text . "{\it FNU} \htbitmap{great=} 0:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" fnu F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of members required in sequence {\it N} ") + (text . "\htbitmap{great=} 1:") + (text . "\newline \tab{2} ") + (bcStrings (10 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's17defGen) + htShowPage() + + +s17defGen htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fnu := htpLabelInputString(htPage,'fnu) + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s17def(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) + prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + + +s17dgf() == + htInitPage('"S17DGF - Airy functions {\em Ai(z)} and {\em Ai'(z)} ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs17dgf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dgf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Evaluates the Airy function Ai(z) or its derivative Ai'(z), ") + (text . "for complex z, with an option for exponential scaling. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Function or derivative required: ") + (radioButtons deriv + ("" " Function" f) + ("" " Derivative" d)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's17dgfGen) + htShowPage() + + +s17dgfGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + ford := htpButtonValue(htPage,'deriv) + deriv := + ford = 'f => '"f" + '"d" + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s17dgf(_"",deriv,"_",complex(",x,",",y,"),_"") + prefix := STRCONC(prefix,scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + +s17dhf() == + htInitPage('"S17DHF - Airy functions {\em Bi(z)} and {\em Bi'(z)} ",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs17dhf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dhf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Evaluates the Airy function Bi(z) or its derivative Bi'(z), ") + (text . "for complex z, with an option for exponential scaling. ") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Function or derivative required: ") + (radioButtons deriv + ("" " Function" f) + ("" " Derivative" d)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's17dhfGen) + htShowPage() + + +s17dhfGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + ford := htpButtonValue(htPage,'deriv) + deriv := + ford = 'f => '"f" + '"d" + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s17dhf(_"",deriv,"_",complex(",x,",",y,"),_"") + prefix := STRCONC(prefix,scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + + +s17dlf() == + htInitPage('"S17DLF - Hankel function \vspace{-28} \htbitmap{s17dlf} \vspace{-37}, j = 1,2, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs17dlf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s17dlf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns a sequence of values for the Hankel functions ") + (text . "\htbitmap{s17dlf}, j = 1,2, for complex z, ") + (text . "non-negative v ") + (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Order v of the first member of the sequence of functions ") + (text . "{\it FNU} \htbitmap{great=} 0:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" fnu F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of members required in sequence {\it N} ") + (text . "\htbitmap{great=} 1:") + (text . "\newline \tab{2} ") + (bcStrings (10 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Hankel function {\it m}: ") + (radioButtons hankel + ("" " \htbitmap{s17dlf1}" mone) + ("" " \htbitmap{s17dlf2}" mtwo)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's17dlfGen) + htShowPage() + + +s17dlfGen htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fnu := htpLabelInputString(htPage,'fnu) + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + hankel := htpButtonValue(htPage,'hankel) + m := + hankel = 'mone => '1 + '2 + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s17dlf(",STRINGIMAGE m,", ",fnu,",complex(") + prefix := STRCONC(prefix,x,",",y,"),",STRINGIMAGE n) + prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + + +s18acf() == + page := htInitPage("S18ACF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18acf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs18acf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18acf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") + (text . "\inputbitmap{\htbmdir{}/s18acf.bitmap} \vspace{-40}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.4" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s18acf") + htShowPage() + +s18adf() == + page := htInitPage("S18ADF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18adf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs18adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") + (text . "\inputbitmap{\htbmdir{}/s18adf.bitmap} \vspace{-40}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.4" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s18adf") + htShowPage() + +s18aef() == + page := htInitPage("S18AeF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18aef1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs18aef} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18aef| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") + (text . "\inputbitmap{\htbmdir{}/s18aef.bitmap} \vspace{-40}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s18aef") + htShowPage() + +s18aff() == + page := htInitPage("S18AFF - Modified Bessel Function \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s18aff1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs18aff} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18aff| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the modified Bessel function \space{1} \vspace{-28}") + (text . "\inputbitmap{\htbmdir{}/s18aff.bitmap} \vspace{-40}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s18aff") + htShowPage() + +s18dcf() == + htInitPage('"S18DCF - Bessel function \htbitmap{s18dcf}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs18dcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18dcf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns a sequence of values for the modified Bessel functions ") + (text . "\htbitmap{s18dcf}, for complex z, non-negative v ") + (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Order v of the first member of the sequence of functions ") + (text . "{\it FNU} \htbitmap{great=} 0:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" fnu F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of members required in sequence {\it N} ") + (text . "\htbitmap{great=} 1:") + (text . "\newline \tab{2} ") + (bcStrings (10 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's18dcfGen) + htShowPage() + + +s18dcfGen htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fnu := htpLabelInputString(htPage,'fnu) + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s18dcf(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) + prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + +s18def() == + htInitPage('"S18DEF - Modified bessel function \htbitmap{s18def}, real a \space{1} \htbitmap{great=} 0, complex z, v = 0,1,2,...",nil) + htMakePage '( + (domainConditions + (isDomain F (Float)) + (isDomain PI (PositiveInteger))) + (text . "\windowlink{Manual Page}{manpageXXs18def} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s18def| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\newline ") + (text . "Returns a sequence of values for the modified Bessel functions ") + (text . "\htbitmap{s18def}, for complex z, non-negative v ") + (text . "and n = 0,1,...,N-1, with an option for exponential scaling.") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Order v of the first member of the sequence of functions ") + (text . "{\it FNU} \htbitmap{great=} 0:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.0" fnu F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Real part of {\it z}:") + (text . "\tab{32} \menuitemstyle{}\tab{34}") + (text . "Imaginary part of {\it z}:") + (text . "\newline \tab{2} ") + (bcStrings (10 "0.3" x F)) + (text . "\tab{34} ") + (bcStrings (10 "-0.4" y F)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Number of members required in sequence {\it N} ") + (text . "\htbitmap{great=} 1:") + (text . "\newline \tab{2} ") + (bcStrings (10 2 n PI)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Scaling option: ") + (radioButtons scale + ("" " Unscaled" u) + ("" " Scaled" s)) + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{} \tab{2} ") + (text . "\newline \tab{2} ") + (text . "Ifail value: ") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's18defGen) + htShowPage() + + +s18defGen htPage == + n := + $bcParseOnly => PARSE_-INTEGER htpLabelInputString(htPage, 'n) + objValUnwrap htpLabelSpadValue(htPage, 'n) + fnu := htpLabelInputString(htPage,'fnu) + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + uors := htpButtonValue(htPage,'scale) + scale := + uors = 'u => '"u" + '"s" + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + prefix := STRCONC('"s18def(",fnu,",complex(",x,",",y,"),",STRINGIMAGE n) + prefix := STRCONC(prefix,",_"",scale,"_", ",STRINGIMAGE ifail,")") + linkGen prefix + + +s19aaf() == + page := htInitPage("S19AAF - Kelvin Function {\em ber x}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs19aaf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19aaf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Kelvin function {\em ber x}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "1.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s19aaf") + htShowPage() + +s19abf() == + page := htInitPage("S19ABF - Kelvin Function {\em bei x}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs19abf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19abf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Kelvin function {\em bei x}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.1" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s19abf") + htShowPage() + +s19acf() == + page := htInitPage("S19ACF - Kelvin Function {\em ker x}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs19acf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19acf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Kelvin function {\em ker x}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x > 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.1" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s19acf") + htShowPage() + +s19adf() == + page := htInitPage("S19AAF - Kelvin Function {\em kei x}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs19adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s19adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Kelvin function {\em kei x}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x \inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.0" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s19adf") + htShowPage() + +s20acf() == + page := htInitPage("S20ACF - Fresnel Integral {\em S(x)}",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs20acf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s20acf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Fresnel Integral {\em S(x)}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s20acf") + htShowPage() + +s20adf() == + page := htInitPage("S20ADF - Fresnel Integral {\em C(x)}",nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs20adf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s20adf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the Fresnel Integral {\em C(x)}") + (text . "\blankline ") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument x: ") + (text . "\newline\tab{2} ") + (bcStrings (9 "0.5" x F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 'sGen) + htpSetProperty(page,'routine,"s20adf") + htShowPage() + +s21baf() == + htInitPage("S21BAF - Degenerate Symmetrised Elliptic Integral of 1st Kind \vspace{-28} \inputbitmap{\htbmdir{}/s21baf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs21baf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21baf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the elementary (degenerate symmetrised elliptic) ") + (text . " integral \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21baf.bitmap} ") + (text . "\blankline ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Enter the argument y \notequal 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.5" x F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0" y F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's21bafGen) + htShowPage() + +s21bafGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC("s21baf(",x,'",",y,",",STRINGIMAGE ifail,'")") + +s21bbf() == + htInitPage("S21BBF - Symmetrised Elliptic Integral of 1st Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bbf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs21bbf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bbf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the symmetrised elliptic integral of the first kind ") + (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bbf.bitmap} ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.5" x F)) + (text . "\tab{34} ") + (bcStrings (10 "1.0" y F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument z \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0; ") + (text . "at most one of x,y and z may be equal to 0.0: \newline \tab{2}") + (bcStrings (10 "1.5" z F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's21bbfGen) + htShowPage() + +s21bbfGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + z := htpLabelInputString(htPage,'z) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC("s21bbf(",x,'",",y,",",z,",",STRINGIMAGE ifail,'")") + +s21bcf() == + htInitPage("S21BCF - Symmetrised Elliptic Integral of 2nd Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bcf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs21bcf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bcf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the symmetrised elliptic integral of the second kind ") + (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bcf.bitmap} ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.5" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.5" y F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument z > 0.0; ") + (text . "at most one of x, y and z may be equal to 0.0: \newline \tab{2}") + (bcStrings (10 "1.0" z F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's21bcfGen) + htShowPage() + +s21bcfGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + z := htpLabelInputString(htPage,'z) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC("s21bcf(",x,'",",y,",",z,",",STRINGIMAGE ifail,'")") + +s21bdf() == + htInitPage("S21BDF - Symmetrised Elliptic Integral of 3rd Kind \space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bdf1.bitmap}", nil) + htMakePage '( + (domainConditions + (isDomain F (Float))) + (text . "\windowlink{Manual Page}{manpageXXs21bdf} for this routine ") + (text . "\newline ") + (text . "\lispwindowlink{Browser operation page}{(|oPageFrom| '|s21bdf| '|NagSpecialFunctionsPackage|)} for this routine") + (text . "\newline \horizontalline ") + (text . "\blankline ") + (text . "Evaluates the symmetrised elliptic integral of the third kind ") + (text . "\space{1} \vspace{-28} \inputbitmap{\htbmdir{}/s21bdf.bitmap} ") + (text . "\newline ") + (text . "\blankline ") + (text . "\newline \menuitemstyle{}\tab{2} ") + (text . "Enter the argument x \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\tab{32} \menuitemstyle{}\tab{34} ") + (text . "Enter the argument y \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0: ") + (text . "\newline\tab{2} ") + (bcStrings (10 "0.5" x F)) + (text . "\tab{34} ") + (bcStrings (10 "0.5" y F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument z \space{1}\inputbitmap{\htbmdir{}/great=.bitmap} 0.0; ") + (text . "at most one of x, y and z may be equal to 0.0: \newline \tab{2}") + (bcStrings (10 "0.5" z F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Enter the argument \rho \notequal 0.0: \newline \tab{2} ") + (bcStrings (10 "2.0" r F)) + (text . "\blankline") + (text . "\newline ") + (text . "\menuitemstyle{}\tab{2}") + (text . "Ifail value:") + (radioButtons ifail + ("" " -1, Print error messages" minusOne) + ("" " 1, Suppress error messages" one))) + htMakeDoneButton('"Continue", 's21bdfGen) + htShowPage() + +s21bdfGen htPage == + x := htpLabelInputString(htPage,'x) + y := htpLabelInputString(htPage,'y) + z := htpLabelInputString(htPage,'z) + r := htpLabelInputString(htPage,'r) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC("s21bdf(",x,'",",y,",",z,",",r,",",STRINGIMAGE ifail,'")") + +sGen htPage == + routine := htpProperty(htPage,'routine) + x := htpLabelInputString(htPage,'x) + error := htpButtonValue(htPage,'ifail) + ifail := + error = 'one => 1 + -1 + linkGen STRCONC(routine,"(",x,'",",STRINGIMAGE ifail,'")") + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/newfort.boot b/src/interp/newfort.boot deleted file mode 100644 index f5af06f2..00000000 --- a/src/interp/newfort.boot +++ /dev/null @@ -1,945 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Translation of Expression to FORTRAN -assignment2Fortran1(name,e) == - $fortError : fluid := nil - checkLines fortran2Lines statement2Fortran ["=",name,e] - -integerAssignment2Fortran1(name,e) == - $fortError : fluid := nil - $fortInts2Floats : fluid := nil - checkLines fortran2Lines statement2Fortran ["=",name,e] - -statement2Fortran e == - -- takes an object of type Expression and returns a list of - -- strings. Any part of the expression which is a list starting - -- with 'FORTRAN is merely passed on in the list of strings. The - -- list of strings may contain '"%l". - -- This is used when formatting e.g. a DO loop from Lisp - $exp2FortTempVarIndex : local := 0 - $fortName : fluid := "DUMMY" - $fortInts2Floats : fluid := nil - fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e - -expression2Fortran e == - -- takes an object of type Expression and returns a list of - -- strings. Any part of the expression which is a list starting - -- with 'FORTRAN is merely passed on in the list of strings. The - -- list of strings may contain '"%l". - $exp2FortTempVarIndex : local := 0 - $fortName : fluid := newFortranTempVar() - $fortInts2Floats : fluid := nil - fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e - -expression2Fortran1(name,e) == - -- takes an object of type Expression and returns a list of - -- strings. Any part of the expression which is a list starting - -- with 'FORTRAN is merely passed on in the list of strings. The - -- list of strings may contain '"%l". - $exp2FortTempVarIndex : local := 0 - $fortName : fluid := name - fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e - -newFortranTempVar() == - $exp2FortTempVarIndex := 1 + $exp2FortTempVarIndex - newVar := INTERN STRCONC('"T",STRINGIMAGE $exp2FortTempVarIndex) - updateSymbolTable(newVar,$defaultFortranType) - newVar - -fortranCleanUp l == - -- takes reversed list and cleans up a bit, putting it in - -- correct order - oldTok := NIL - m := NIL - for e in l repeat - if not (oldTok = '"-" and e = '"+") then m := [e,:m] - oldTok := e - m - -exp2Fort1 l == - s := nil - for e in l repeat s := [:exp2Fort2(e,0,nil),:s] - s - -exp2Fort2(e,prec,oldOp) == - null e => nil - atom e => [object2String e] - e is [ "=",lhs,rhs] or e is [ '"=",lhs,rhs] => - ['"%l",:exp2Fort2(rhs,prec,'"="),'"=",:exp2Fort2(lhs,prec,'"=")] - - unaryOps := ['"-",'"^",'"~"] - unaryPrecs := [700,260,50] - binaryOps := ['"|",'"**",'"/",'".LT.",'".GT.",'".EQ.",'".LE.",'".GE.", _ - '"OVER",'".AND.",'".OR."] - binaryPrecs := [0, 900, 800, 400, 400, 400, 400, 400, 800, 70, 90] - naryOps := ['"-",'"+",'"*",'",",'" ",'"ROW",'""] - naryPrecs := [700, 700, 800, 110, 0, 0, 0] - nonUnaryOps := append(binaryOps,naryOps) - [op,:args] := e - op := object2String op - nargs := #args - nargs = 0 => exp2FortFn(op,args,0) - nargs = 1 => - (p := position(op,unaryOps)) > -1 => - nprec := unaryPrecs.p - s := [:exp2Fort2(first args,nprec,op),op] - op = '"-" and atom first args => s - op = oldOp and op in ['"*",'"+"] => s - nprec <= prec => ['")",:s,'"("] - s - exp2FortFn(op,args,nargs) - op = '"CMPLX" => - ['")",:exp2Fort2(SECOND args, prec, op),'",",:exp2Fort2(first args,prec,op),'"("] - member(op,nonUnaryOps) => - if nargs > 0 then arg1 := first args - nargs = 1 and op in '("+" "*") => exp2Fort2(arg1,prec,op) - if nargs > 1 then arg2 := first rest args - p := position(op,binaryOps) - if p = -1 - then - p := position(op,naryOps) - nprec := naryPrecs.p - else nprec := binaryPrecs.p - s := nil - for arg in args repeat - op = '"+" and (arg is [m,a]) and m in '(_- "=") => - if not s then s := ['junk] - s:= [op,:exp2Fort2(a,nprec,op),'"-",:rest s] - s := [op,:exp2Fort2(arg,nprec,op),:s] - s := rest s - op = oldOp and op in ['"*",'"+"] => s - nprec <= prec => ['")",:s,'"("] - s - exp2FortFn(op,args,nargs) - - -exp2FortFn(op,args,nargs) == - s := ['"(",op] - while args repeat - s := ['",",:exp2Fort2(first args,0,op),:s] - args := rest args - if nargs > 0 then ['")",:rest s] - else ['")",:s] - - ---% Optimization of Expression - -exp2FortOptimize e == - -- $fortranOptimizationLevel means: - -- 0 just extract arrays - -- 1 extract common subexpressions - -- 2 try to optimize computing of powers - $exprStack : local := NIL - atom e => [e] - $fortranOptimizationLevel = 0 => - e1 := exp2FortOptimizeArray e - NREVERSE [e1,:$exprStack] - e := minimalise e - for e1 in exp2FortOptimizeCS e repeat - e2 := exp2FortOptimizeArray e1 - $exprStack := [e2,:$exprStack] - NREVERSE $exprStack - - -exp2FortOptimizeCS e == - $fortCsList : local := NIL - $fortCsHash : local := MAKE_-HASHTABLE 'EQ - $fortCsExprStack : local := NIL - $fortCsFuncStack : local := NIL - f := exp2FortOptimizeCS1 e - NREVERSE [f,:$fortCsList] - --- bug fix to beenHere --- Thu Nov 05 12:01:46 CUT 1992 , Author: TTT --- Used in exp2FortOprtimizeCS --- Original file : newfort.boot -beenHere(e,n) == - n.0 := n.0 + 1 -- increase count (initially 1) - n.0 = 2 => -- first time back again - var := n.1 := newFortranTempVar() -- stuff n.1 with new var - exprStk := n.2 -- get expression - if exprStk then --- using COPY-TREE : RPLAC does not smash $fortCsList --- which led to inconsistencies in assignment of temp. vars. - $fortCsList := COPY_-TREE [['"=",var,e],:$fortCsList] - loc := CAR exprStk - fun := CAR n.3 - fun = 'CAR => - RPLACA(loc,var) - fun = 'CDR => - if PAIRP QCDR loc - then RPLACD(loc,[var]) - else RPLACD(loc,var) - SAY '"whoops" - var - n.1 -- been here before, so just get variable - - -exp2FortOptimizeCS1 e == - -- we do nothing with atoms or simple lists containing atoms - atom(e) or (atom first e and null rest e) => e - e is [op,arg] and object2Identifier op = "-" and atom arg => e - - -- see if we have been here before - not (object2Identifier QCAR e in '(ROW AGGLST)) and - (n := HGET($fortCsHash,e)) => beenHere(e,n) -- where - - -- descend sucessive CARs of CDRs of e - f := e - while f repeat - pushCsStacks(f,'CAR) where pushCsStacks(x,y) == - $fortCsExprStack := [x,:$fortCsExprStack] - $fortCsFuncStack := [y,:$fortCsFuncStack] - RPLACA(f,exp2FortOptimizeCS1 QCAR f) - popCsStacks(0) where popCsStacks(x) == - $fortCsFuncStack := QCDR $fortCsFuncStack - $fortCsExprStack := QCDR $fortCsExprStack - g := QCDR f - -- check to see of we have an non-NIL atomic CDR - g and atom g => - pushCsStacks(f,'CDR) - RPLACD(f,exp2FortOptimizeCS1 g) - popCsStacks(0) - f := NIL - f := g - - MEMQ(object2Identifier QCAR e,'(ROW AGGLST)) => e - - -- see if we have already seen this expression - n := HGET($fortCsHash,e) - null n => - n := VECTOR(1,NIL,$fortCsExprStack,$fortCsFuncStack) - HPUT($fortCsHash,e,n) - e - beenHere(e,n) - - - -exp2FortOptimizeArray e == - -- this handles arrays - atom e => e - [op,:args] := e - op1 := object2Identifier op - op1 in '(BRACE BRACKET) => - args is [['AGGLST,:elts]] => - LISTP first elts and first first elts in '(BRACE BRACKET) => fortError1 e - -- var := newFortranTempVar() - var := $fortName - $exprStack := [[op,var,['AGGLST,:exp2FortOptimizeArray elts]], - :$exprStack] - var - EQ(op1,'MATRIX) => - -- var := newFortranTempVar() - var := $fortName - -- args looks like [NIL,[ROW,...],[ROW,...]] - $exprStack := [[op,var,:exp2FortOptimizeArray args],:$exprStack] - var - [exp2FortOptimizeArray op,:exp2FortOptimizeArray args] - - ---% FORTRAN Line Breaking - -fortran2Lines f == - -- f is a list of strings - -- returns: a list of strings where each string is a valid - -- FORTRAN line in fixed form - - -- collect strings up to first %l or end of list. Then feed to - -- fortran2Lines1. - fs := NIL - lines := NIL - while f repeat - while f and (ff := first(f)) ^= '"%l" repeat - fs := [ff,:fs] - f := rest f - if f and first(f) = '"%l" then f := rest f - lines := append(fortran2Lines1 nreverse fs,lines) - fs := nil - nreverse lines - -fortran2Lines1 f == - -- f is a list of strings making up 1 FORTRAN statement - -- return: a reverse list of FORTRAN lines - normPref := MAKE_-STRING($fortIndent) - --contPref := STRCONC(MAKE_-STRING($fortIndent-1),"&") - contPref := STRCONC(" &",MAKE_-STRING($fortIndent-6)) - lines := NIL - ll := $fortIndent - while f repeat - ok := true - line := normPref - ff := first f - while ok repeat - (ll + (sff := SIZE ff)) <= $fortLength => - ll := ll + sff - line := STRCONC(line,ff) - f := rest f - if f then ff := first f - else ok := nil - -- fill the line out to exactly $fortLength spaces if possible by splitting - -- up symbols. This is helpful when doing the segmentation - -- calculations, and also means that very long strings (e.g. numbers - -- with more than $fortLength-$fortIndent digits) are printed in a - -- legal format. MCD - if (ll < $fortLength) and (ll + sff) > $fortLength then - spaceLeft := $fortLength - ll - line := STRCONC(line,SUBSEQ(ff,0,spaceLeft)) - ff := SUBSEQ(ff,spaceLeft) - lines := [line,:lines] - ll := $fortIndent - line := contPref - if ll > $fortIndent then lines := [line,:lines] - lines - --- The Fortran error functions -fortError1 u == - $fortError := "t" - sayErrorly("Fortran translation error", - " No corresponding Fortran structure for:") - mathPrint u - -fortError(u,v) == - $fortError := "t" - msg := STRCONC(" ",STRINGIMAGE u); - sayErrorly("Fortran translation error",msg) - mathPrint v - ---% Top Level Things to Call --- The names are the same as those used in the old fortran code - -dispStatement x == - $fortError : fluid := nil - displayLines fortran2Lines statement2Fortran x - - -getStatement(x,ints2Floats?) == - $fortInts2Floats : fluid := ints2Floats? - $fortError : fluid := nil - checkLines fortran2Lines statement2Fortran x - -fortexp0 x == - f := expression2Fortran x - p := position('"%l",f) - p < 0 => f - l := NIL - while p < 0 repeat - [t,:f] := f - l := [t,:l] - NREVERSE ['"...",:l] - -dispfortexp x == - if atom(x) or x is [op,:.] and not object2Identifier op in - '(_= MATRIX construct ) then - var := INTERN STRCONC('"R",object2String $IOindex) - x := ['"=",var,x] - dispfortexp1 x - -dispfortexpf (xf, fortranName) == - $fortError : fluid := nil - linef := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xf),2) - displayLines linef - -dispfortexpj (xj, fortranName) == - $fortName : fluid := fortranName - $fortError : fluid := nil - linej := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xj),2) - displayLines linej - - -dispfortexp1 x == - $fortError : fluid := nil - displayLines fortran2Lines expression2Fortran x - -getfortexp1 x == - $fortError : fluid := nil - checkLines fortran2Lines expression2Fortran x - -displayLines1 lines == - for l in lines repeat - PRINTEXP(l,$fortranOutputStream) - TERPRI($fortranOutputStream) - -displayLines lines == - if not $fortError then displayLines1 lines - -checkLines lines == - $fortError => [] - lines - -dispfortarrayexp (fortranName,m) == - $fortError : fluid := nil - displayLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2) - -getfortarrayexp(fortranName,m,ints2floats?) == - $fortInts2Floats : fluid := ints2floats? - $fortError : fluid := nil - checkLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2) - - --- Globals -$currentSubprogram := nil -$symbolTable := nil - - - ---fix [x,exp x] - ------------- exp2FortSpecial.boot -------------------- - -exp2FortSpecial(op,args,nargs) == - op = "CONCAT" and first args in ["<",">","<=",">=","~","and","or"] => - mkFortFn(first args,CDADAR rest args,#(CDADAR rest args)) - op = "CONCAT" and CADR(args)="EQ" => - mkFortFn("EQ",[first args, CADDR args],2) - --the next line is NEVER used by FORTRAN code but is needed when - -- called to get a linearized form for the browser - op = "QUOTE" => - atom (arg := first args) => STRINGIMAGE arg - tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] - STRCONC('"[",first arg,tailPart,'"]") - op = "PAREN" => - args := first args - not(first(args)="CONCATB") => fortError1 [op,:args] - -- Have a matrix element - mkMat(args) - op = "SUB" => - $fortInts2Floats : fluid := nil - mkFortFn(first args,rest args,#(rest args)) - op in ["BRACE","BRACKET"] => - args is [var,['AGGLST,:elts]] => - var := object2String var - si := $fortranArrayStartingIndex - hidim := #elts - 1 + si - if LISTP first elts and #elts=1 and first elts is [sOp,:sArgs] then - sOp in ['"SEGMENT","SEGMENT"] => - #sArgs=1 => fortError1 first elts - not(NUMBERP(first sArgs) and NUMBERP(SECOND sArgs)) => - fortError("Cannot expand segment: ",first elts) - first sArgs > SECOND sArgs => fortError1 - '"Lower bound of segment exceeds upper bound." - for e in first sArgs .. SECOND sArgs for i in si.. repeat - $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack] - for e in elts for i in si.. repeat - $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack] - fortError1 [op,:args] - op in ["CONCAT","CONCATB"] => - nargs = 0 => NIL - nargs = 1 => fortPre1 first args - nargs = 2 and first rest args in ["!",'"!"] => - mkFortFn("FACTORIAL",[first args],1) - fortError1 [op,:args] - op in ['"MATRIX","MATRIX"] => - args is [var, =NIL,:rows] => - var := object2String var - nrows := #rows - 1 - ncols := #(rest first rows) - 1 - si := $fortranArrayStartingIndex - for r in rows for rx in si.. repeat - for c in rest r for cx in si.. repeat - $exprStack := [["=",[var,object2String rx,object2String cx], - fortPre1(c)],:$exprStack] - fortError1 [op,:args] - fortError1 [op,:args] - -mkMat(args) == - $fortInts2Floats : fluid := nil - mkFortFn(first rest args,rest rest args,#(rest rest args)) - - -mkFortFn(op,args,nargs) == - [fortranifyFunctionName(STRINGIMAGE op,nargs), - :MAPCAR(function fortPre1 , args) ] - -fortranifyFunctionName(op,nargs) == - op = '"<" => '".LT." - op = '">" => '".GT." - op = '"<=" => '".LE." - op = '">=" => '".GE." - op = '"EQ" => '".EQ." - op = '"and" => '".AND." - op = '"or" => '".OR." - op = '"~" => '".NOT." - fortranifyIntrinsicFunctionName(op,nargs) - -fortranifyIntrinsicFunctionName(op,nargs) == - $useIntrinsicFunctions => - intrinsic := if op = '"acos" then '"ACOS" - else if op = '"asin" then '"ASIN" - else if op = '"atan" then - nargs = 2 => '"ATAN2" - '"ATAN" - else if op = '"cos" then '"COS" - else if op = '"cosh" then '"COSH" - else if op = '"cot" then '"COTAN" - else if op = '"erf" then '"ERF" - else if op = '"exp" then '"EXP" - else if op = '"log" then '"LOG" - else if op = '"log10" then '"LOG10" - else if op = '"sin" then '"SIN" - else if op = '"sinh" then '"SINH" - else if op = '"sqrt" then '"SQRT" - else if op = '"tan" then '"TAN" - else if op = '"tanh" then '"TANH" - intrinsic => - $intrinsics := ADJOIN(intrinsic,$intrinsics) - intrinsic - op - $fortranPrecision = 'double => - op = '"acos" => '"DACOS" - op = '"asin" => '"DASIN" - op = '"atan" => - nargs = 2 => '"DATAN2" - '"DATAN" - op = '"cos" => '"DCOS" - op = '"cosh" => '"DCOSH" - op = '"cot" => '"DCOTAN" - op = '"erf" => '"DERF" - op = '"exp" => '"DEXP" - op = '"log" => '"DLOG" - op = '"log10" => '"DLOG10" - op = '"sin" => '"DSIN" - op = '"sinh" => '"DSINH" - op = '"sqrt" => '"DSQRT" - op = '"tan" => '"DTAN" - op = '"tanh" => '"DTANH" - op = '"abs" => '"DABS" - op - op = '"acos" => '"ACOS" - op = '"asin" => '"ASIN" - op = '"atan" => - nargs = 2 => '"ATAN2" - '"ATAN" - op = '"cos" => '"COS" - op = '"cosh" => '"COSH" - op = '"cot" => '"COTAN" - op = '"erf" => '"ERF" - op = '"exp" => '"EXP" - op = '"log" => '"ALOG" - op = '"log10" => '"ALOG10" - op = '"sin" => '"SIN" - op = '"sinh" => '"SINH" - op = '"sqrt" => '"SQRT" - op = '"tan" => '"TAN" - op = '"tanh" => '"TANH" - op = '"abs" => '"ABS" - op - ---------------------------format.boot------------------------------------------ - --- These functions are all used by FortranCode and FortranProgram. --- Those used by FortranCode have been changed to return a list of --- lines rather than print them directly, thus allowing us to catch --- and display type declarations for temporary variables. --- MCD 25/3/93 - -indentFortLevel(i) == - $maximumFortranExpressionLength := $maximumFortranExpressionLength -2*i - $fortIndent := $fortIndent + 2*i - -changeExprLength(i) ==> - $maximumFortranExpressionLength := $maximumFortranExpressionLength + i - -fortFormatDo(var,lo,hi,incr,lab) == - $fortError : fluid := nil - $fortInts2Floats : fluid := nil - incr=1 => - checkLines fortran2Lines - ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_ - '",", :statement2Fortran hi] - checkLines fortran2Lines - ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_ - '",", :statement2Fortran hi,'",",:statement2Fortran incr] - -fortFormatIfGoto(switch,label) == - changeExprLength(-8) -- Leave room for IF( ... )GOTO - $fortError : fluid := nil - if first(switch) = "NULL" then switch := first rest switch - r := nreverse statement2Fortran switch - changeExprLength(8) - l := ['")GOTO ",STRINGIMAGE label] - while r and not(first(r) = '"%l") repeat - l := [first(r),:l] - r := rest(r) - checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r] - -fortFormatLabelledIfGoto(switch,label1,label2) == - changeExprLength(-8) -- Leave room for IF( ... )GOTO - $fortError : fluid := nil - if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch - r := nreverse statement2Fortran switch - changeExprLength(8) - l := ['")GOTO ",STRINGIMAGE label2] - while r and not(first(r) = '"%l") repeat - l := [first(r),:l] - r := rest(r) - labString := STRINGIMAGE label1 - for i in #(labString)..5 repeat labString := STRCONC(labString,'" ") - lines := fortran2Lines nreverse [:nreverse l,'"IF(",:r] - lines := [STRCONC(labString,SUBSEQ(first lines,6)),:rest lines] - checkLines lines - -fortFormatIf(switch) == - changeExprLength(-8) -- Leave room for IF( ... )THEN - $fortError : fluid := nil - if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch - r := nreverse statement2Fortran switch - changeExprLength(8) - l := ['")THEN"] - while r and not(first(r) = '"%l") repeat - l := [first(r),:l] - r := rest(r) - checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r] - -fortFormatElseIf(switch) == - -- Leave room for IF( ... )THEN - changeExprLength(-12) - $fortError : fluid := nil - if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch - r := nreverse statement2Fortran switch - changeExprLength(12) - l := ['")THEN"] - while r and not(first(r) = '"%l") repeat - l := [first(r),:l] - r := rest(r) - checkLines fortran2Lines nreverse [:nreverse l,'"ELSEIF(",:r] - -fortFormatHead(returnType,name,args) == - $fortError : fluid := nil - $fortranSegment : fluid := nil - -- if returnType = '"_"_(_)_"" then - if returnType = '"void" then - asp := ['"SUBROUTINE "] - changeExprLength(l := -11) - else - asp := [s := checkType STRINGIMAGE returnType,'" FUNCTION "] - changeExprLength(l := -10-LENGTH(s)) - displayLines fortran2Lines [:asp,:statement2Fortran [name,:CDADR args] ] - changeExprLength(-l) - -checkType ty == - ty := STRING_-UPCASE STRINGIMAGE ty - $fortranPrecision = "double" => - ty = '"REAL" => '"DOUBLE PRECISION" - ty = '"COMPLEX" => '"DOUBLE COMPLEX" - ty - ty - -mkParameterList l == - [par2string(u) for u in l] where par2string u == - atom(u) => STRINGIMAGE u - u := rest first rest u - apply('STRCONC,[STRINGIMAGE(first u),'"(",_ - :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"]) - -nameLen n ==> - +/[1+LENGTH(u) for u in n] - -fortFormatTypes(typeName,names) == - null names => return() - $fortError : fluid := nil - $fortranSegment : fluid := nil - $fortInts2Floats : fluid := nil - typeName := checkType typeName - typeName = '"CHARACTER" => - fortFormatCharacterTypes([unravel(u) for u in names]) - where unravel u == - atom u => u - CDADR u - fortFormatTypes1(typeName,mkParameterList names) - -fortFormatTypes1(typeName,names) == - l := $maximumFortranExpressionLength-1-LENGTH(typeName) - while nameLen(names) > l repeat - n := [] - ln := 0 - while (ln := ln + LENGTH(first names) + 1) < l repeat - n := [first names,:n] - names := rest names - displayLines fortran2Lines [typeName,'" ",:addCommas n] - displayLines fortran2Lines [typeName,'" ",:addCommas names] - -insertEntry(size,el,aList) == - entry := assoc(size,aList) - null entry => CONS(CONS(size,LIST el),aList) - RPLACD(entry,CONS(el,CDR entry)) - aList - -fortFormatCharacterTypes(names) == - sortedByLength := [] - genuineArrays := [] - for u in names repeat - ATOM u => sortedByLength := insertEntry(0,u,sortedByLength) - #u=2 => sortedByLength := insertEntry(CADR u,CAR u,sortedByLength) - genuineArrays := [u,:genuineArrays] - for u in sortedByLength repeat - fortFormatTypes1(mkCharName car u, [STRINGIMAGE(s) for s in cdr(u)]) where - mkCharName v == CONCAT("CHARACTER*(",STRINGIMAGE v,")") - if (not null genuineArrays) then - fortFormatTypes1('"CHARACTER",mkParameterList2 genuineArrays) where - mkParameterList2 l == - [par2string(u) for u in l] where par2string u == - apply('STRCONC,[STRINGIMAGE(first u),'"(",_ - :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"]) - -fortFormatIntrinsics(l) == - $fortError : fluid := nil - null l => return() - displayLines fortran2Lines ['"INTRINSIC ",:addCommas(l)] - - ------------------- fortDec.boot -------------------- - --- This file contains the stuff for creating and updating the Fortran symbol --- table. - -currentSP () == - -- Return the name of the current subprogram being generated - $currentSubprogram or "MAIN" - -updateSymbolTable(name,type) == - fun := ['$elt,'SYMS,'declare_!] - coercion := ['_:_:,STRING type,'FST] - $insideCompileBodyIfTrue: local := false - interpret([fun,["QUOTE",name],coercion]) - -addCommas l == - not l => nil - r := [STRINGIMAGE first l] - for e in rest l repeat r := [STRINGIMAGE e,'",",:r] - reverse r - -$intrinsics := [] -initialiseIntrinsicList() == - $intrinsics := [] - -getIntrinsicList() == - $intrinsics - - --------------------- fortPre.boot ------------------ - -fortPre l == - -- Essentially, the idea is to fix things so that we know what size of - -- expression we will generate, which helps segment large expressions - -- and do transformations to double precision output etc.. - $exprStack : fluid := nil -- sometimes we will add elements to this in - -- other functions, for example when extracing - -- lists etc. - for e in l repeat if new := fortPre1 e then - $exprStack := [new,:$exprStack] - reverse $exprStack - -fortPre1 e == - -- replace spad function names by Fortran equivalents - -- where appropriate, replace integers by floats - -- extract complex numbers - -- replace powers of %e by calls to EXP - -- replace x**2 by x*x etc. - -- replace ROOT by either SQRT or **(1./ ... ) - -- replace N-ary by binary functions - -- strip the '%' character off objects like %pi etc.. - null e => nil - INTEGERP(e) => - $fortInts2Floats = true => - e >= 0 => fix2FortranFloat(e) - ['"-", fix2FortranFloat(-e)] - e - isFloat(e) => checkPrecision(e) - -- Keep strings as strings: - -- STRINGP(e) => STRCONC(STRING(34),e,STRING(34)) - STRINGP(e) => e - e = "%e" => fortPre1 ["exp" , 1] - imags := ['"%i","%i"] - e in imags => ['"CMPLX",fortPre1(0),fortPre1(1)] - -- other special objects - ELT(STRINGIMAGE e,0) = "%" => SUBSEQ(STRINGIMAGE e,1) - atom e => e - [op, :args] := e - op in ["**" , '"**"] => - [rand,exponent] := args - rand = "%e" => fortPre1 ["exp", exponent] - (IDENTP rand or STRINGP rand) and exponent=2 => ["*", rand, rand] - (FIXP exponent and ABS(exponent) < 32768) => ["**",fortPre1 rand,exponent] - ["**", fortPre1 rand,fortPre1 exponent] - op = "ROOT" => - #args = 1 => fortPreRoot ["sqrt", first args] - [ "**" , fortPreRoot first args , [ "/" , fortPreRoot(1), fortPreRoot first rest args] ] - if op in ['"OVER", "OVER"] then op := '"/" - specialOps := '(BRACKET BRACE SUB AGGLST SUPERSUB MATRIX SEGMENT ALTSUPERSUB - PAREN CONCAT CONCATB QUOTE STRING SIGMA STEP IN SIGMA2 - INTSIGN PI PI2 INDEFINTEGRAL) - op in specialOps => exp2FortSpecial(op,args,#args) - op in ['"*", "*", '"+", "+", '"-", "-"] and (#args > 2) => - binaryExpr := fortPre1 [op,first args, SECOND args] - for i in 3..#args repeat - binaryExpr := [op,binaryExpr,fortPre1 NTH(i-1,args)] - binaryExpr - -- Now look for any complex objects - #args = 2 => - [arg1,arg2] := args - op in ["*",'"*"] and arg2 in imags => ['"CMPLX",fortPre1(0),fortPre1(arg1)] - op in ["+",'"+"] and arg2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(1)] - op in ["+",'"+"] and arg2 is [mop,m1,m2] and mop in ["*",'"*"] => - m2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m1)] - m1 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m2)] - ["+",fortPre1 arg1,fortPre1 arg2] - op in ["+",'"+"] and arg1 is [mop,m1,m2] and mop in ["*",'"*"] => - m2 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m1)] - m1 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m2)] - ["+",fortPre1 arg1,fortPre1 arg2] - mkFortFn(op,args,2) - mkFortFn(op,args,#args) - -fortPreRoot e == --- To set $fortInts2Floats - $fortInts2Floats : fluid := true - fortPre1 e - -fix2FortranFloat e == - -- Return a Fortran float for a given integer. - $fortranPrecision = "double" => STRCONC(STRINGIMAGE(e),".0D0") - STRCONC(STRINGIMAGE(e),".") - -isFloat e == - FLOATP(e) or STRINGP(e) and FIND(char ".",e) - -checkPrecision e == - -- Do we have a string? - STRINGP(e) and CHAR_-CODE(CHAR(e,0)) = 34 => e - e := delete(char " ",STRINGIMAGE e) - $fortranPrecision = "double" => - iPart := SUBSEQ(e,0,(period:=POSITION(char ".",e))+1) - expt := if ePos := POSITION(char "E",e) then SUBSEQ(e,ePos+1) else "0" - rPart := - ePos => SUBSEQ(e,period+1,ePos) - period+1 < LENGTH e => SUBSEQ(e,period+1) - "0" - STRCONC(iPart,rPart,"D",expt) - e - ------------------ segment.boot ----------------------- - -fortExpSize e == - -- computes a tree reflecting the number of characters of the printed - -- expression. - -- The first element of a list is the "total so far", while subsequent - -- elements are the sizes of the components. - -- - -- This function overestimates the size because it assumes that e.g. - -- (+ x (+ y z)) will be printed as "x+(y+z)" rather than "x+y+z" - -- which is the actual case. - atom e => LENGTH STRINGIMAGE e - #e > 3 => 2+fortSize MAPCAR(function fortExpSize, e) - #e < 3 => 2+fortSize MAPCAR(function fortExpSize, e) - [op,arg1,arg2] := e - op := STRINGIMAGE op - op = '"CMPLX" => 3+fortSize [fortExpSize arg1,fortExpSize arg2] - narys := ['"+",'"*"] -- those nary ops we changed to binary - op in narys => - LISTP arg1 and not(op=STRINGIMAGE first arg1) => - 2+fortSize MAPCAR(function fortExpSize, e) - LISTP arg2 and not(op=STRINGIMAGE first arg2) => - 2+fortSize MAPCAR(function fortExpSize, e) - 1+fortSize [fortExpSize arg1,fortExpSize arg2] - 2+fortSize MAPCAR(function fortExpSize, e) - -fortSize e == - +/[elen u for u in e] where - elen z == - atom z => z - first z - -tempLen () == 1 + LENGTH STRINGIMAGE $exp2FortTempVarIndex - -segment l == - not $fortranSegment => l - s := nil - for e in l repeat - if LISTP(e) and first e in ["=",'"="] then - var := NTH(1,e) - exprs := segment1(THIRD e, - $maximumFortranExpressionLength-1-fortExpSize var) - s:= [:[['"=",var,car exprs],:cdr exprs],:s] - else if LISTP(e) and first e in ['"RETURN"] then - exprs := segment1(SECOND e, - $maximumFortranExpressionLength-2-fortExpSize first e) - s := [:[[first e,car exprs],:cdr exprs],:s] - else s:= [e,:s] - reverse s - -segment1(e,maxSize) == - (size := fortExpSize e) < maxSize => [e] - expressions := nil; - newE := [first e] - -- Assume we have to replace each argument with a temporary variable, and - -- that the temporary variable may be larger than we expect. - safeSize := maxSize - (#e-1)*(tempLen()+1) - fortExpSize newE - for i in 2..#e repeat - subSize := fortExpSize NTH(i-1,e) - -- We could have a check here for symbols which are simply too big - -- for Fortran (i.e. more than the maximum practical expression length) - subSize <= safeSize => - safeSize := safeSize - subSize - newE := [:newE,NTH(i-1,e)] - -- this ones too big. - exprs := segment2(NTH(i-1,e),safeSize) - expressions := [:(cdr exprs),:expressions] - newE := [:newE,(car exprs)] - safeSize := safeSize - fortExpSize car exprs - [newE,:expressions] - -segment2(e,topSize) == - maxSize := $maximumFortranExpressionLength -tempLen()-1 - atom(e) => [e] - exprs := nil - newE := [first e] - topSize := topSize - fortExpSize newE - for i in 2..#e repeat - subE := NTH(i-1,e) - (subSize := fortExpSize subE) > maxSize => - subE := segment2(subE,maxSize) - exprs := [:(cdr subE),:exprs] - if (subSize := fortExpSize first subE) <= topSize then - newE := [:newE,first subE] - topSize := topSize - subSize - else - newVar := newFortranTempVar() - newE := [:newE,newVar] - exprs:=[['"=",newVar,first subE],:exprs] - topSize := topSize - fortExpSize newVar - newE := [:newE,subE] - topSize := topSize - subSize - topSize > 0 => [newE,:exprs] - newVar := newFortranTempVar() - [newVar,['"=",newVar,newE],:exprs] - diff --git a/src/interp/newfort.boot.pamphlet b/src/interp/newfort.boot.pamphlet new file mode 100644 index 00000000..b5720292 --- /dev/null +++ b/src/interp/newfort.boot.pamphlet @@ -0,0 +1,967 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp newfort.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Translation of Expression to FORTRAN +assignment2Fortran1(name,e) == + $fortError : fluid := nil + checkLines fortran2Lines statement2Fortran ["=",name,e] + +integerAssignment2Fortran1(name,e) == + $fortError : fluid := nil + $fortInts2Floats : fluid := nil + checkLines fortran2Lines statement2Fortran ["=",name,e] + +statement2Fortran e == + -- takes an object of type Expression and returns a list of + -- strings. Any part of the expression which is a list starting + -- with 'FORTRAN is merely passed on in the list of strings. The + -- list of strings may contain '"%l". + -- This is used when formatting e.g. a DO loop from Lisp + $exp2FortTempVarIndex : local := 0 + $fortName : fluid := "DUMMY" + $fortInts2Floats : fluid := nil + fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e + +expression2Fortran e == + -- takes an object of type Expression and returns a list of + -- strings. Any part of the expression which is a list starting + -- with 'FORTRAN is merely passed on in the list of strings. The + -- list of strings may contain '"%l". + $exp2FortTempVarIndex : local := 0 + $fortName : fluid := newFortranTempVar() + $fortInts2Floats : fluid := nil + fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e + +expression2Fortran1(name,e) == + -- takes an object of type Expression and returns a list of + -- strings. Any part of the expression which is a list starting + -- with 'FORTRAN is merely passed on in the list of strings. The + -- list of strings may contain '"%l". + $exp2FortTempVarIndex : local := 0 + $fortName : fluid := name + fortranCleanUp exp2Fort1 segment fortPre exp2FortOptimize outputTran e + +newFortranTempVar() == + $exp2FortTempVarIndex := 1 + $exp2FortTempVarIndex + newVar := INTERN STRCONC('"T",STRINGIMAGE $exp2FortTempVarIndex) + updateSymbolTable(newVar,$defaultFortranType) + newVar + +fortranCleanUp l == + -- takes reversed list and cleans up a bit, putting it in + -- correct order + oldTok := NIL + m := NIL + for e in l repeat + if not (oldTok = '"-" and e = '"+") then m := [e,:m] + oldTok := e + m + +exp2Fort1 l == + s := nil + for e in l repeat s := [:exp2Fort2(e,0,nil),:s] + s + +exp2Fort2(e,prec,oldOp) == + null e => nil + atom e => [object2String e] + e is [ "=",lhs,rhs] or e is [ '"=",lhs,rhs] => + ['"%l",:exp2Fort2(rhs,prec,'"="),'"=",:exp2Fort2(lhs,prec,'"=")] + + unaryOps := ['"-",'"^",'"~"] + unaryPrecs := [700,260,50] + binaryOps := ['"|",'"**",'"/",'".LT.",'".GT.",'".EQ.",'".LE.",'".GE.", _ + '"OVER",'".AND.",'".OR."] + binaryPrecs := [0, 900, 800, 400, 400, 400, 400, 400, 800, 70, 90] + naryOps := ['"-",'"+",'"*",'",",'" ",'"ROW",'""] + naryPrecs := [700, 700, 800, 110, 0, 0, 0] + nonUnaryOps := append(binaryOps,naryOps) + [op,:args] := e + op := object2String op + nargs := #args + nargs = 0 => exp2FortFn(op,args,0) + nargs = 1 => + (p := position(op,unaryOps)) > -1 => + nprec := unaryPrecs.p + s := [:exp2Fort2(first args,nprec,op),op] + op = '"-" and atom first args => s + op = oldOp and op in ['"*",'"+"] => s + nprec <= prec => ['")",:s,'"("] + s + exp2FortFn(op,args,nargs) + op = '"CMPLX" => + ['")",:exp2Fort2(SECOND args, prec, op),'",",:exp2Fort2(first args,prec,op),'"("] + member(op,nonUnaryOps) => + if nargs > 0 then arg1 := first args + nargs = 1 and op in '("+" "*") => exp2Fort2(arg1,prec,op) + if nargs > 1 then arg2 := first rest args + p := position(op,binaryOps) + if p = -1 + then + p := position(op,naryOps) + nprec := naryPrecs.p + else nprec := binaryPrecs.p + s := nil + for arg in args repeat + op = '"+" and (arg is [m,a]) and m in '(_- "=") => + if not s then s := ['junk] + s:= [op,:exp2Fort2(a,nprec,op),'"-",:rest s] + s := [op,:exp2Fort2(arg,nprec,op),:s] + s := rest s + op = oldOp and op in ['"*",'"+"] => s + nprec <= prec => ['")",:s,'"("] + s + exp2FortFn(op,args,nargs) + + +exp2FortFn(op,args,nargs) == + s := ['"(",op] + while args repeat + s := ['",",:exp2Fort2(first args,0,op),:s] + args := rest args + if nargs > 0 then ['")",:rest s] + else ['")",:s] + + +--% Optimization of Expression + +exp2FortOptimize e == + -- $fortranOptimizationLevel means: + -- 0 just extract arrays + -- 1 extract common subexpressions + -- 2 try to optimize computing of powers + $exprStack : local := NIL + atom e => [e] + $fortranOptimizationLevel = 0 => + e1 := exp2FortOptimizeArray e + NREVERSE [e1,:$exprStack] + e := minimalise e + for e1 in exp2FortOptimizeCS e repeat + e2 := exp2FortOptimizeArray e1 + $exprStack := [e2,:$exprStack] + NREVERSE $exprStack + + +exp2FortOptimizeCS e == + $fortCsList : local := NIL + $fortCsHash : local := MAKE_-HASHTABLE 'EQ + $fortCsExprStack : local := NIL + $fortCsFuncStack : local := NIL + f := exp2FortOptimizeCS1 e + NREVERSE [f,:$fortCsList] + +-- bug fix to beenHere +-- Thu Nov 05 12:01:46 CUT 1992 , Author: TTT +-- Used in exp2FortOprtimizeCS +-- Original file : newfort.boot +beenHere(e,n) == + n.0 := n.0 + 1 -- increase count (initially 1) + n.0 = 2 => -- first time back again + var := n.1 := newFortranTempVar() -- stuff n.1 with new var + exprStk := n.2 -- get expression + if exprStk then +-- using COPY-TREE : RPLAC does not smash $fortCsList +-- which led to inconsistencies in assignment of temp. vars. + $fortCsList := COPY_-TREE [['"=",var,e],:$fortCsList] + loc := CAR exprStk + fun := CAR n.3 + fun = 'CAR => + RPLACA(loc,var) + fun = 'CDR => + if PAIRP QCDR loc + then RPLACD(loc,[var]) + else RPLACD(loc,var) + SAY '"whoops" + var + n.1 -- been here before, so just get variable + + +exp2FortOptimizeCS1 e == + -- we do nothing with atoms or simple lists containing atoms + atom(e) or (atom first e and null rest e) => e + e is [op,arg] and object2Identifier op = "-" and atom arg => e + + -- see if we have been here before + not (object2Identifier QCAR e in '(ROW AGGLST)) and + (n := HGET($fortCsHash,e)) => beenHere(e,n) -- where + + -- descend sucessive CARs of CDRs of e + f := e + while f repeat + pushCsStacks(f,'CAR) where pushCsStacks(x,y) == + $fortCsExprStack := [x,:$fortCsExprStack] + $fortCsFuncStack := [y,:$fortCsFuncStack] + RPLACA(f,exp2FortOptimizeCS1 QCAR f) + popCsStacks(0) where popCsStacks(x) == + $fortCsFuncStack := QCDR $fortCsFuncStack + $fortCsExprStack := QCDR $fortCsExprStack + g := QCDR f + -- check to see of we have an non-NIL atomic CDR + g and atom g => + pushCsStacks(f,'CDR) + RPLACD(f,exp2FortOptimizeCS1 g) + popCsStacks(0) + f := NIL + f := g + + MEMQ(object2Identifier QCAR e,'(ROW AGGLST)) => e + + -- see if we have already seen this expression + n := HGET($fortCsHash,e) + null n => + n := VECTOR(1,NIL,$fortCsExprStack,$fortCsFuncStack) + HPUT($fortCsHash,e,n) + e + beenHere(e,n) + + + +exp2FortOptimizeArray e == + -- this handles arrays + atom e => e + [op,:args] := e + op1 := object2Identifier op + op1 in '(BRACE BRACKET) => + args is [['AGGLST,:elts]] => + LISTP first elts and first first elts in '(BRACE BRACKET) => fortError1 e + -- var := newFortranTempVar() + var := $fortName + $exprStack := [[op,var,['AGGLST,:exp2FortOptimizeArray elts]], + :$exprStack] + var + EQ(op1,'MATRIX) => + -- var := newFortranTempVar() + var := $fortName + -- args looks like [NIL,[ROW,...],[ROW,...]] + $exprStack := [[op,var,:exp2FortOptimizeArray args],:$exprStack] + var + [exp2FortOptimizeArray op,:exp2FortOptimizeArray args] + + +--% FORTRAN Line Breaking + +fortran2Lines f == + -- f is a list of strings + -- returns: a list of strings where each string is a valid + -- FORTRAN line in fixed form + + -- collect strings up to first %l or end of list. Then feed to + -- fortran2Lines1. + fs := NIL + lines := NIL + while f repeat + while f and (ff := first(f)) ^= '"%l" repeat + fs := [ff,:fs] + f := rest f + if f and first(f) = '"%l" then f := rest f + lines := append(fortran2Lines1 nreverse fs,lines) + fs := nil + nreverse lines + +fortran2Lines1 f == + -- f is a list of strings making up 1 FORTRAN statement + -- return: a reverse list of FORTRAN lines + normPref := MAKE_-STRING($fortIndent) + --contPref := STRCONC(MAKE_-STRING($fortIndent-1),"&") + contPref := STRCONC(" &",MAKE_-STRING($fortIndent-6)) + lines := NIL + ll := $fortIndent + while f repeat + ok := true + line := normPref + ff := first f + while ok repeat + (ll + (sff := SIZE ff)) <= $fortLength => + ll := ll + sff + line := STRCONC(line,ff) + f := rest f + if f then ff := first f + else ok := nil + -- fill the line out to exactly $fortLength spaces if possible by splitting + -- up symbols. This is helpful when doing the segmentation + -- calculations, and also means that very long strings (e.g. numbers + -- with more than $fortLength-$fortIndent digits) are printed in a + -- legal format. MCD + if (ll < $fortLength) and (ll + sff) > $fortLength then + spaceLeft := $fortLength - ll + line := STRCONC(line,SUBSEQ(ff,0,spaceLeft)) + ff := SUBSEQ(ff,spaceLeft) + lines := [line,:lines] + ll := $fortIndent + line := contPref + if ll > $fortIndent then lines := [line,:lines] + lines + +-- The Fortran error functions +fortError1 u == + $fortError := "t" + sayErrorly("Fortran translation error", + " No corresponding Fortran structure for:") + mathPrint u + +fortError(u,v) == + $fortError := "t" + msg := STRCONC(" ",STRINGIMAGE u); + sayErrorly("Fortran translation error",msg) + mathPrint v + +--% Top Level Things to Call +-- The names are the same as those used in the old fortran code + +dispStatement x == + $fortError : fluid := nil + displayLines fortran2Lines statement2Fortran x + + +getStatement(x,ints2Floats?) == + $fortInts2Floats : fluid := ints2Floats? + $fortError : fluid := nil + checkLines fortran2Lines statement2Fortran x + +fortexp0 x == + f := expression2Fortran x + p := position('"%l",f) + p < 0 => f + l := NIL + while p < 0 repeat + [t,:f] := f + l := [t,:l] + NREVERSE ['"...",:l] + +dispfortexp x == + if atom(x) or x is [op,:.] and not object2Identifier op in + '(_= MATRIX construct ) then + var := INTERN STRCONC('"R",object2String $IOindex) + x := ['"=",var,x] + dispfortexp1 x + +dispfortexpf (xf, fortranName) == + $fortError : fluid := nil + linef := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xf),2) + displayLines linef + +dispfortexpj (xj, fortranName) == + $fortName : fluid := fortranName + $fortError : fluid := nil + linej := fortran2Lines BUTLAST(expression2Fortran1(fortranName,xj),2) + displayLines linej + + +dispfortexp1 x == + $fortError : fluid := nil + displayLines fortran2Lines expression2Fortran x + +getfortexp1 x == + $fortError : fluid := nil + checkLines fortran2Lines expression2Fortran x + +displayLines1 lines == + for l in lines repeat + PRINTEXP(l,$fortranOutputStream) + TERPRI($fortranOutputStream) + +displayLines lines == + if not $fortError then displayLines1 lines + +checkLines lines == + $fortError => [] + lines + +dispfortarrayexp (fortranName,m) == + $fortError : fluid := nil + displayLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2) + +getfortarrayexp(fortranName,m,ints2floats?) == + $fortInts2Floats : fluid := ints2floats? + $fortError : fluid := nil + checkLines fortran2Lines BUTLAST(expression2Fortran1(fortranName,m),2) + + +-- Globals +$currentSubprogram := nil +$symbolTable := nil + + + +--fix [x,exp x] + +------------ exp2FortSpecial.boot -------------------- + +exp2FortSpecial(op,args,nargs) == + op = "CONCAT" and first args in ["<",">","<=",">=","~","and","or"] => + mkFortFn(first args,CDADAR rest args,#(CDADAR rest args)) + op = "CONCAT" and CADR(args)="EQ" => + mkFortFn("EQ",[first args, CADDR args],2) + --the next line is NEVER used by FORTRAN code but is needed when + -- called to get a linearized form for the browser + op = "QUOTE" => + atom (arg := first args) => STRINGIMAGE arg + tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] + STRCONC('"[",first arg,tailPart,'"]") + op = "PAREN" => + args := first args + not(first(args)="CONCATB") => fortError1 [op,:args] + -- Have a matrix element + mkMat(args) + op = "SUB" => + $fortInts2Floats : fluid := nil + mkFortFn(first args,rest args,#(rest args)) + op in ["BRACE","BRACKET"] => + args is [var,['AGGLST,:elts]] => + var := object2String var + si := $fortranArrayStartingIndex + hidim := #elts - 1 + si + if LISTP first elts and #elts=1 and first elts is [sOp,:sArgs] then + sOp in ['"SEGMENT","SEGMENT"] => + #sArgs=1 => fortError1 first elts + not(NUMBERP(first sArgs) and NUMBERP(SECOND sArgs)) => + fortError("Cannot expand segment: ",first elts) + first sArgs > SECOND sArgs => fortError1 + '"Lower bound of segment exceeds upper bound." + for e in first sArgs .. SECOND sArgs for i in si.. repeat + $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack] + for e in elts for i in si.. repeat + $exprStack := [["=",[var,object2String i],fortPre1(e)],:$exprStack] + fortError1 [op,:args] + op in ["CONCAT","CONCATB"] => + nargs = 0 => NIL + nargs = 1 => fortPre1 first args + nargs = 2 and first rest args in ["!",'"!"] => + mkFortFn("FACTORIAL",[first args],1) + fortError1 [op,:args] + op in ['"MATRIX","MATRIX"] => + args is [var, =NIL,:rows] => + var := object2String var + nrows := #rows - 1 + ncols := #(rest first rows) - 1 + si := $fortranArrayStartingIndex + for r in rows for rx in si.. repeat + for c in rest r for cx in si.. repeat + $exprStack := [["=",[var,object2String rx,object2String cx], + fortPre1(c)],:$exprStack] + fortError1 [op,:args] + fortError1 [op,:args] + +mkMat(args) == + $fortInts2Floats : fluid := nil + mkFortFn(first rest args,rest rest args,#(rest rest args)) + + +mkFortFn(op,args,nargs) == + [fortranifyFunctionName(STRINGIMAGE op,nargs), + :MAPCAR(function fortPre1 , args) ] + +fortranifyFunctionName(op,nargs) == + op = '"<" => '".LT." + op = '">" => '".GT." + op = '"<=" => '".LE." + op = '">=" => '".GE." + op = '"EQ" => '".EQ." + op = '"and" => '".AND." + op = '"or" => '".OR." + op = '"~" => '".NOT." + fortranifyIntrinsicFunctionName(op,nargs) + +fortranifyIntrinsicFunctionName(op,nargs) == + $useIntrinsicFunctions => + intrinsic := if op = '"acos" then '"ACOS" + else if op = '"asin" then '"ASIN" + else if op = '"atan" then + nargs = 2 => '"ATAN2" + '"ATAN" + else if op = '"cos" then '"COS" + else if op = '"cosh" then '"COSH" + else if op = '"cot" then '"COTAN" + else if op = '"erf" then '"ERF" + else if op = '"exp" then '"EXP" + else if op = '"log" then '"LOG" + else if op = '"log10" then '"LOG10" + else if op = '"sin" then '"SIN" + else if op = '"sinh" then '"SINH" + else if op = '"sqrt" then '"SQRT" + else if op = '"tan" then '"TAN" + else if op = '"tanh" then '"TANH" + intrinsic => + $intrinsics := ADJOIN(intrinsic,$intrinsics) + intrinsic + op + $fortranPrecision = 'double => + op = '"acos" => '"DACOS" + op = '"asin" => '"DASIN" + op = '"atan" => + nargs = 2 => '"DATAN2" + '"DATAN" + op = '"cos" => '"DCOS" + op = '"cosh" => '"DCOSH" + op = '"cot" => '"DCOTAN" + op = '"erf" => '"DERF" + op = '"exp" => '"DEXP" + op = '"log" => '"DLOG" + op = '"log10" => '"DLOG10" + op = '"sin" => '"DSIN" + op = '"sinh" => '"DSINH" + op = '"sqrt" => '"DSQRT" + op = '"tan" => '"DTAN" + op = '"tanh" => '"DTANH" + op = '"abs" => '"DABS" + op + op = '"acos" => '"ACOS" + op = '"asin" => '"ASIN" + op = '"atan" => + nargs = 2 => '"ATAN2" + '"ATAN" + op = '"cos" => '"COS" + op = '"cosh" => '"COSH" + op = '"cot" => '"COTAN" + op = '"erf" => '"ERF" + op = '"exp" => '"EXP" + op = '"log" => '"ALOG" + op = '"log10" => '"ALOG10" + op = '"sin" => '"SIN" + op = '"sinh" => '"SINH" + op = '"sqrt" => '"SQRT" + op = '"tan" => '"TAN" + op = '"tanh" => '"TANH" + op = '"abs" => '"ABS" + op + +--------------------------format.boot------------------------------------------ + +-- These functions are all used by FortranCode and FortranProgram. +-- Those used by FortranCode have been changed to return a list of +-- lines rather than print them directly, thus allowing us to catch +-- and display type declarations for temporary variables. +-- MCD 25/3/93 + +indentFortLevel(i) == + $maximumFortranExpressionLength := $maximumFortranExpressionLength -2*i + $fortIndent := $fortIndent + 2*i + +changeExprLength(i) ==> + $maximumFortranExpressionLength := $maximumFortranExpressionLength + i + +fortFormatDo(var,lo,hi,incr,lab) == + $fortError : fluid := nil + $fortInts2Floats : fluid := nil + incr=1 => + checkLines fortran2Lines + ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_ + '",", :statement2Fortran hi] + checkLines fortran2Lines + ['"DO ",STRINGIMAGE lab,'" ",STRINGIMAGE var,'"=",:statement2Fortran lo,_ + '",", :statement2Fortran hi,'",",:statement2Fortran incr] + +fortFormatIfGoto(switch,label) == + changeExprLength(-8) -- Leave room for IF( ... )GOTO + $fortError : fluid := nil + if first(switch) = "NULL" then switch := first rest switch + r := nreverse statement2Fortran switch + changeExprLength(8) + l := ['")GOTO ",STRINGIMAGE label] + while r and not(first(r) = '"%l") repeat + l := [first(r),:l] + r := rest(r) + checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r] + +fortFormatLabelledIfGoto(switch,label1,label2) == + changeExprLength(-8) -- Leave room for IF( ... )GOTO + $fortError : fluid := nil + if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch + r := nreverse statement2Fortran switch + changeExprLength(8) + l := ['")GOTO ",STRINGIMAGE label2] + while r and not(first(r) = '"%l") repeat + l := [first(r),:l] + r := rest(r) + labString := STRINGIMAGE label1 + for i in #(labString)..5 repeat labString := STRCONC(labString,'" ") + lines := fortran2Lines nreverse [:nreverse l,'"IF(",:r] + lines := [STRCONC(labString,SUBSEQ(first lines,6)),:rest lines] + checkLines lines + +fortFormatIf(switch) == + changeExprLength(-8) -- Leave room for IF( ... )THEN + $fortError : fluid := nil + if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch + r := nreverse statement2Fortran switch + changeExprLength(8) + l := ['")THEN"] + while r and not(first(r) = '"%l") repeat + l := [first(r),:l] + r := rest(r) + checkLines fortran2Lines nreverse [:nreverse l,'"IF(",:r] + +fortFormatElseIf(switch) == + -- Leave room for IF( ... )THEN + changeExprLength(-12) + $fortError : fluid := nil + if LISTP(switch) and first(switch) = "NULL" then switch := first rest switch + r := nreverse statement2Fortran switch + changeExprLength(12) + l := ['")THEN"] + while r and not(first(r) = '"%l") repeat + l := [first(r),:l] + r := rest(r) + checkLines fortran2Lines nreverse [:nreverse l,'"ELSEIF(",:r] + +fortFormatHead(returnType,name,args) == + $fortError : fluid := nil + $fortranSegment : fluid := nil + -- if returnType = '"_"_(_)_"" then + if returnType = '"void" then + asp := ['"SUBROUTINE "] + changeExprLength(l := -11) + else + asp := [s := checkType STRINGIMAGE returnType,'" FUNCTION "] + changeExprLength(l := -10-LENGTH(s)) + displayLines fortran2Lines [:asp,:statement2Fortran [name,:CDADR args] ] + changeExprLength(-l) + +checkType ty == + ty := STRING_-UPCASE STRINGIMAGE ty + $fortranPrecision = "double" => + ty = '"REAL" => '"DOUBLE PRECISION" + ty = '"COMPLEX" => '"DOUBLE COMPLEX" + ty + ty + +mkParameterList l == + [par2string(u) for u in l] where par2string u == + atom(u) => STRINGIMAGE u + u := rest first rest u + apply('STRCONC,[STRINGIMAGE(first u),'"(",_ + :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"]) + +nameLen n ==> + +/[1+LENGTH(u) for u in n] + +fortFormatTypes(typeName,names) == + null names => return() + $fortError : fluid := nil + $fortranSegment : fluid := nil + $fortInts2Floats : fluid := nil + typeName := checkType typeName + typeName = '"CHARACTER" => + fortFormatCharacterTypes([unravel(u) for u in names]) + where unravel u == + atom u => u + CDADR u + fortFormatTypes1(typeName,mkParameterList names) + +fortFormatTypes1(typeName,names) == + l := $maximumFortranExpressionLength-1-LENGTH(typeName) + while nameLen(names) > l repeat + n := [] + ln := 0 + while (ln := ln + LENGTH(first names) + 1) < l repeat + n := [first names,:n] + names := rest names + displayLines fortran2Lines [typeName,'" ",:addCommas n] + displayLines fortran2Lines [typeName,'" ",:addCommas names] + +insertEntry(size,el,aList) == + entry := assoc(size,aList) + null entry => CONS(CONS(size,LIST el),aList) + RPLACD(entry,CONS(el,CDR entry)) + aList + +fortFormatCharacterTypes(names) == + sortedByLength := [] + genuineArrays := [] + for u in names repeat + ATOM u => sortedByLength := insertEntry(0,u,sortedByLength) + #u=2 => sortedByLength := insertEntry(CADR u,CAR u,sortedByLength) + genuineArrays := [u,:genuineArrays] + for u in sortedByLength repeat + fortFormatTypes1(mkCharName car u, [STRINGIMAGE(s) for s in cdr(u)]) where + mkCharName v == CONCAT("CHARACTER*(",STRINGIMAGE v,")") + if (not null genuineArrays) then + fortFormatTypes1('"CHARACTER",mkParameterList2 genuineArrays) where + mkParameterList2 l == + [par2string(u) for u in l] where par2string u == + apply('STRCONC,[STRINGIMAGE(first u),'"(",_ + :rest [:['",",:statement2Fortran(v)] for v in rest u],'")"]) + +fortFormatIntrinsics(l) == + $fortError : fluid := nil + null l => return() + displayLines fortran2Lines ['"INTRINSIC ",:addCommas(l)] + + +------------------ fortDec.boot -------------------- + +-- This file contains the stuff for creating and updating the Fortran symbol +-- table. + +currentSP () == + -- Return the name of the current subprogram being generated + $currentSubprogram or "MAIN" + +updateSymbolTable(name,type) == + fun := ['$elt,'SYMS,'declare_!] + coercion := ['_:_:,STRING type,'FST] + $insideCompileBodyIfTrue: local := false + interpret([fun,["QUOTE",name],coercion]) + +addCommas l == + not l => nil + r := [STRINGIMAGE first l] + for e in rest l repeat r := [STRINGIMAGE e,'",",:r] + reverse r + +$intrinsics := [] +initialiseIntrinsicList() == + $intrinsics := [] + +getIntrinsicList() == + $intrinsics + + +-------------------- fortPre.boot ------------------ + +fortPre l == + -- Essentially, the idea is to fix things so that we know what size of + -- expression we will generate, which helps segment large expressions + -- and do transformations to double precision output etc.. + $exprStack : fluid := nil -- sometimes we will add elements to this in + -- other functions, for example when extracing + -- lists etc. + for e in l repeat if new := fortPre1 e then + $exprStack := [new,:$exprStack] + reverse $exprStack + +fortPre1 e == + -- replace spad function names by Fortran equivalents + -- where appropriate, replace integers by floats + -- extract complex numbers + -- replace powers of %e by calls to EXP + -- replace x**2 by x*x etc. + -- replace ROOT by either SQRT or **(1./ ... ) + -- replace N-ary by binary functions + -- strip the '%' character off objects like %pi etc.. + null e => nil + INTEGERP(e) => + $fortInts2Floats = true => + e >= 0 => fix2FortranFloat(e) + ['"-", fix2FortranFloat(-e)] + e + isFloat(e) => checkPrecision(e) + -- Keep strings as strings: + -- STRINGP(e) => STRCONC(STRING(34),e,STRING(34)) + STRINGP(e) => e + e = "%e" => fortPre1 ["exp" , 1] + imags := ['"%i","%i"] + e in imags => ['"CMPLX",fortPre1(0),fortPre1(1)] + -- other special objects + ELT(STRINGIMAGE e,0) = "%" => SUBSEQ(STRINGIMAGE e,1) + atom e => e + [op, :args] := e + op in ["**" , '"**"] => + [rand,exponent] := args + rand = "%e" => fortPre1 ["exp", exponent] + (IDENTP rand or STRINGP rand) and exponent=2 => ["*", rand, rand] + (FIXP exponent and ABS(exponent) < 32768) => ["**",fortPre1 rand,exponent] + ["**", fortPre1 rand,fortPre1 exponent] + op = "ROOT" => + #args = 1 => fortPreRoot ["sqrt", first args] + [ "**" , fortPreRoot first args , [ "/" , fortPreRoot(1), fortPreRoot first rest args] ] + if op in ['"OVER", "OVER"] then op := '"/" + specialOps := '(BRACKET BRACE SUB AGGLST SUPERSUB MATRIX SEGMENT ALTSUPERSUB + PAREN CONCAT CONCATB QUOTE STRING SIGMA STEP IN SIGMA2 + INTSIGN PI PI2 INDEFINTEGRAL) + op in specialOps => exp2FortSpecial(op,args,#args) + op in ['"*", "*", '"+", "+", '"-", "-"] and (#args > 2) => + binaryExpr := fortPre1 [op,first args, SECOND args] + for i in 3..#args repeat + binaryExpr := [op,binaryExpr,fortPre1 NTH(i-1,args)] + binaryExpr + -- Now look for any complex objects + #args = 2 => + [arg1,arg2] := args + op in ["*",'"*"] and arg2 in imags => ['"CMPLX",fortPre1(0),fortPre1(arg1)] + op in ["+",'"+"] and arg2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(1)] + op in ["+",'"+"] and arg2 is [mop,m1,m2] and mop in ["*",'"*"] => + m2 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m1)] + m1 in imags => ['"CMPLX",fortPre1(arg1),fortPre1(m2)] + ["+",fortPre1 arg1,fortPre1 arg2] + op in ["+",'"+"] and arg1 is [mop,m1,m2] and mop in ["*",'"*"] => + m2 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m1)] + m1 in imags => ['"CMPLX",fortPre1(arg2),fortPre1(m2)] + ["+",fortPre1 arg1,fortPre1 arg2] + mkFortFn(op,args,2) + mkFortFn(op,args,#args) + +fortPreRoot e == +-- To set $fortInts2Floats + $fortInts2Floats : fluid := true + fortPre1 e + +fix2FortranFloat e == + -- Return a Fortran float for a given integer. + $fortranPrecision = "double" => STRCONC(STRINGIMAGE(e),".0D0") + STRCONC(STRINGIMAGE(e),".") + +isFloat e == + FLOATP(e) or STRINGP(e) and FIND(char ".",e) + +checkPrecision e == + -- Do we have a string? + STRINGP(e) and CHAR_-CODE(CHAR(e,0)) = 34 => e + e := delete(char " ",STRINGIMAGE e) + $fortranPrecision = "double" => + iPart := SUBSEQ(e,0,(period:=POSITION(char ".",e))+1) + expt := if ePos := POSITION(char "E",e) then SUBSEQ(e,ePos+1) else "0" + rPart := + ePos => SUBSEQ(e,period+1,ePos) + period+1 < LENGTH e => SUBSEQ(e,period+1) + "0" + STRCONC(iPart,rPart,"D",expt) + e + +----------------- segment.boot ----------------------- + +fortExpSize e == + -- computes a tree reflecting the number of characters of the printed + -- expression. + -- The first element of a list is the "total so far", while subsequent + -- elements are the sizes of the components. + -- + -- This function overestimates the size because it assumes that e.g. + -- (+ x (+ y z)) will be printed as "x+(y+z)" rather than "x+y+z" + -- which is the actual case. + atom e => LENGTH STRINGIMAGE e + #e > 3 => 2+fortSize MAPCAR(function fortExpSize, e) + #e < 3 => 2+fortSize MAPCAR(function fortExpSize, e) + [op,arg1,arg2] := e + op := STRINGIMAGE op + op = '"CMPLX" => 3+fortSize [fortExpSize arg1,fortExpSize arg2] + narys := ['"+",'"*"] -- those nary ops we changed to binary + op in narys => + LISTP arg1 and not(op=STRINGIMAGE first arg1) => + 2+fortSize MAPCAR(function fortExpSize, e) + LISTP arg2 and not(op=STRINGIMAGE first arg2) => + 2+fortSize MAPCAR(function fortExpSize, e) + 1+fortSize [fortExpSize arg1,fortExpSize arg2] + 2+fortSize MAPCAR(function fortExpSize, e) + +fortSize e == + +/[elen u for u in e] where + elen z == + atom z => z + first z + +tempLen () == 1 + LENGTH STRINGIMAGE $exp2FortTempVarIndex + +segment l == + not $fortranSegment => l + s := nil + for e in l repeat + if LISTP(e) and first e in ["=",'"="] then + var := NTH(1,e) + exprs := segment1(THIRD e, + $maximumFortranExpressionLength-1-fortExpSize var) + s:= [:[['"=",var,car exprs],:cdr exprs],:s] + else if LISTP(e) and first e in ['"RETURN"] then + exprs := segment1(SECOND e, + $maximumFortranExpressionLength-2-fortExpSize first e) + s := [:[[first e,car exprs],:cdr exprs],:s] + else s:= [e,:s] + reverse s + +segment1(e,maxSize) == + (size := fortExpSize e) < maxSize => [e] + expressions := nil; + newE := [first e] + -- Assume we have to replace each argument with a temporary variable, and + -- that the temporary variable may be larger than we expect. + safeSize := maxSize - (#e-1)*(tempLen()+1) - fortExpSize newE + for i in 2..#e repeat + subSize := fortExpSize NTH(i-1,e) + -- We could have a check here for symbols which are simply too big + -- for Fortran (i.e. more than the maximum practical expression length) + subSize <= safeSize => + safeSize := safeSize - subSize + newE := [:newE,NTH(i-1,e)] + -- this ones too big. + exprs := segment2(NTH(i-1,e),safeSize) + expressions := [:(cdr exprs),:expressions] + newE := [:newE,(car exprs)] + safeSize := safeSize - fortExpSize car exprs + [newE,:expressions] + +segment2(e,topSize) == + maxSize := $maximumFortranExpressionLength -tempLen()-1 + atom(e) => [e] + exprs := nil + newE := [first e] + topSize := topSize - fortExpSize newE + for i in 2..#e repeat + subE := NTH(i-1,e) + (subSize := fortExpSize subE) > maxSize => + subE := segment2(subE,maxSize) + exprs := [:(cdr subE),:exprs] + if (subSize := fortExpSize first subE) <= topSize then + newE := [:newE,first subE] + topSize := topSize - subSize + else + newVar := newFortranTempVar() + newE := [:newE,newVar] + exprs:=[['"=",newVar,first subE],:exprs] + topSize := topSize - fortExpSize newVar + newE := [:newE,subE] + topSize := topSize - subSize + topSize > 0 => [newE,:exprs] + newVar := newFortranTempVar() + [newVar,['"=",newVar,newE],:exprs] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nhyper.boot b/src/interp/nhyper.boot deleted file mode 100644 index ad10f860..00000000 --- a/src/interp/nhyper.boot +++ /dev/null @@ -1,119 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- HyperTex Spad interface - ---SETANDFILEQ($SendXEventToHyperTeX, 8) ---SETANDFILEQ($LinkToPage, 96) ---SETANDFILEQ($StartPage, 97) ---SETANDFILEQ($SendLine, 98) ---SETANDFILEQ($EndOfPage, 99) ---SETANDFILEQ($PopUpPage, 95) ---SETANDFILEQ($PopUpNamedPage, 94) ---SETANDFILEQ($KillPage, 93) ---SETANDFILEQ($ReplacePage, 92) ---SETANDFILEQ($ReplaceNamedPage, 91) ---SETANDFILEQ($SpadError, 90) ---SETANDFILEQ($PageStuff, 100) - --- Issue a line of HyperTex -issueHT line == - sockSendInt($MenuServer, $SendLine) - sockSendString($MenuServer, line) - -endHTPage() == - sockSendInt($MenuServer, $EndOfPage) - -testPage() == - startHTPage(50) - issueHT '"\page{TestPage}{Test Page generated from Lisp} " - issueHT '"\horizontalline\beginscroll\beginitems " - issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " - issueHT '"The misadventures of the White House bellboy. " - issueHT '"\enditems\endscroll\autobuttons " - endHTPage() - --- create a named top-page -HTLinkToPage name == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $LinkToPage) - sockSendString($MenuServer, name) - --- create a pop-up named page ; returns a windowid -HTPopUpNamedPage(name,cols) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpNamedPage) - sockSendInt($MenuServer, cols) - sockSendString($MenuServer, name) - sockGetInt($MenuServer) - --- Update a window with named page -HTReplaceNamedPage(window, name) == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplaceNamedPage) - sockSendInt($MenuServer, window) - sockSendString($MenuServer, name) - --- Start a pop-up page ; returns a windowid -HTPopUpPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $PopUpPage) - sockSendInt($MenuServer, cols) - sockGetInt($MenuServer) - --- Start an update sequence on a window -HTReplacePage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $ReplacePage) - sockSendInt($MenuServer, w) - --- Start a top-page ; no further Lisp interaction -HTStartPage cols == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $StartPage) - sockSendInt($MenuServer, cols) - --- Kill a window from Lisp -HTKillPage w == - sockSendInt($MenuServer, $PageStuff) - sockSendInt($MenuServer, $currentFrameNum) - sockSendInt($MenuServer, $KillPage) - sockSendInt($MenuServer, w) - -HTErrorSignal() == - sockSendInt($MenuServer, $SpadError) diff --git a/src/interp/nhyper.boot.pamphlet b/src/interp/nhyper.boot.pamphlet new file mode 100644 index 00000000..d0fb8051 --- /dev/null +++ b/src/interp/nhyper.boot.pamphlet @@ -0,0 +1,141 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nhyper.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- HyperTex Spad interface + +--SETANDFILEQ($SendXEventToHyperTeX, 8) +--SETANDFILEQ($LinkToPage, 96) +--SETANDFILEQ($StartPage, 97) +--SETANDFILEQ($SendLine, 98) +--SETANDFILEQ($EndOfPage, 99) +--SETANDFILEQ($PopUpPage, 95) +--SETANDFILEQ($PopUpNamedPage, 94) +--SETANDFILEQ($KillPage, 93) +--SETANDFILEQ($ReplacePage, 92) +--SETANDFILEQ($ReplaceNamedPage, 91) +--SETANDFILEQ($SpadError, 90) +--SETANDFILEQ($PageStuff, 100) + +-- Issue a line of HyperTex +issueHT line == + sockSendInt($MenuServer, $SendLine) + sockSendString($MenuServer, line) + +endHTPage() == + sockSendInt($MenuServer, $EndOfPage) + +testPage() == + startHTPage(50) + issueHT '"\page{TestPage}{Test Page generated from Lisp} " + issueHT '"\horizontalline\beginscroll\beginitems " + issueHT '"\item \downlink{Quayle Jokes}{ChickenPage} \space{2} " + issueHT '"The misadventures of the White House bellboy. " + issueHT '"\enditems\endscroll\autobuttons " + endHTPage() + +-- create a named top-page +HTLinkToPage name == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $LinkToPage) + sockSendString($MenuServer, name) + +-- create a pop-up named page ; returns a windowid +HTPopUpNamedPage(name,cols) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpNamedPage) + sockSendInt($MenuServer, cols) + sockSendString($MenuServer, name) + sockGetInt($MenuServer) + +-- Update a window with named page +HTReplaceNamedPage(window, name) == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplaceNamedPage) + sockSendInt($MenuServer, window) + sockSendString($MenuServer, name) + +-- Start a pop-up page ; returns a windowid +HTPopUpPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $PopUpPage) + sockSendInt($MenuServer, cols) + sockGetInt($MenuServer) + +-- Start an update sequence on a window +HTReplacePage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $ReplacePage) + sockSendInt($MenuServer, w) + +-- Start a top-page ; no further Lisp interaction +HTStartPage cols == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $StartPage) + sockSendInt($MenuServer, cols) + +-- Kill a window from Lisp +HTKillPage w == + sockSendInt($MenuServer, $PageStuff) + sockSendInt($MenuServer, $currentFrameNum) + sockSendInt($MenuServer, $KillPage) + sockSendInt($MenuServer, w) + +HTErrorSignal() == + sockSendInt($MenuServer, $SpadError) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot deleted file mode 100644 index 71bb7b77..00000000 --- a/src/interp/nruncomp.boot +++ /dev/null @@ -1,743 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ------------------------------NEW buildFunctor CODE----------------------------- -NRTaddDeltaCode() == ---NOTES: This function is called from NRTbuildFunctor to initially --- fill slots in $template. The $template so created is stored in the --- NRLIB. On load, makeDomainTemplate is called on this $template to --- create a template which becomes slot 0 of the infovec for the constructor. ---The template has 6 kinds of entries: --- (1) formal arguments and local variables, represented by (QUOTE ) --- this conflicts by (5) but is ok since each is explicitly set by --- instantiator code; --- (2) domains, represented by lazy forms, e.g. (Foo 12 17 6) --- (3) latch slots, represented SPADCALLable forms which goGet an operation --- from a domain then cache the operation in the same slot --- (4) functions, represented by identifiers which are names of functions --- (5) identifiers/strings, parts of signatures (now parts of signatures --- now must all have slot numbers, represented by (QUOTE ) --- (6) constants, like 0 and 1, represented by (CONS .. ) form - kvec := first $catvecList - for i in $NRTbase.. for item in REVERSE $NRTdeltaList - for compItem in REVERSE $NRTdeltaListComp - |null (s:=kvec.i) repeat - $template.i:= deltaTran(item,compItem) - $template.5 := - $NRTaddForm => - $NRTaddForm is ['Tuple,:y] => NREVERSE y - NRTencode($NRTaddForm,$addForm) - nil - -deltaTran(item,compItem) == - item is ['domain,lhs,:.] => NRTencode(lhs,compItem) - --NOTE: all items but signatures are wrapped with domain forms - [op,:modemap] := item - [dcSig,[.,[kind,:.]]] := modemap - [dc,:sig] := dcSig - sig := substitute('$,dc,substitute("$$",'$,sig)) - dcCode := - dc = '$ => - --$NRTaddForm => -5 - 0 - NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc]) - formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig) - kindFlag:= (kind = 'CONST => 'CONST; nil) - newSig := [NRTassocIndex x or x for x in formalSig] - [newSig,dcCode,op,:kindFlag] - ---NRTencodeSig x == [NRTencode y for y in x] - -NRTreplaceAllLocalReferences(form) == - $devaluateList :local := [] - NRTputInLocalReferences form - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == - --converts a domain form to a lazy domain form; everything other than - --the operation name should be assigned a slot - null firstTime and (k:= NRTassocIndex x) => k - VECP x => systemErrorHere '"NRTencode" - PAIRP x => - QCAR x='Record or x is ['Union,['_:,a,b],:.] => - [QCAR x,:[['_:,a,encode(b,c,false)] - for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] - constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => - [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] - ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] - MEMQ(x,$formalArgList) => - v := $FormalMapVariableList.(POSN1(x,$formalArgList)) - firstTime => ['local,v] - v - x = '$ => x - ['QUOTE,x] - ---------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- -listOfBoundVars form == --- Only called from the function genDeltaEntry below - form = '$ => [] - IDENTP form and (u:=get(form,'value,$e)) => - u:=u.expr - MEMQ(KAR u,'(Union Record)) => listOfBoundVars u - [form] - atom form => [] - CAR form = 'QUOTE => [] - EQ(CAR form,":") => listOfBoundVars CADDR form - -- We don't want to pick up the tag, only the domain - "union"/[listOfBoundVars x for x in CDR form] - -optDeltaEntry(op,sig,dc,eltOrConst) == - $killOptimizeIfTrue = true => nil - ndc := - dc = '$ => $functorForm - atom dc and (dcval := get(dc,'value,$e)) => dcval.expr - dc ---if (atom dc) and (dcval := get(dc,'value,$e)) --- then ndc := dcval.expr --- else ndc := dc - sig := SUBST(ndc,dc,sig) - not MEMQ(KAR ndc,$optimizableConstructorNames) => nil - dcval := optCallEval ndc - -- MSUBST guarantees to use EQUAL testing - sig := MSUBST(devaluate dcval, ndc, sig) - if rest ndc then - for new in rest devaluate dcval for old in rest ndc repeat - sig := MSUBST(new,old,sig) - -- optCallEval sends (List X) to (LIst (Integer)) etc, - -- so we should make the same transformation - fn := compiledLookup(op,sig,dcval) - if null fn then - -- following code is to handle selectors like first, rest - nsig := [quoteSelector tt for tt in sig] where - quoteSelector(x) == - not(IDENTP x) => x - get(x,'value,$e) => x - x='$ => x - MKQ x - fn := compiledLookup(op,nsig,dcval) - if null fn then return nil - eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn] - GETL(compileTimeBindingOf first fn,'SPADreplace) - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair - if $profileCompiler = true then profileRecord(dc,op,sig) - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - -- following hack needed to invert Rep to $ substitution - if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(sig,dc),consDomainForm(dc,nil)]] - --if null atom dc then - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (member(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= compOrCroak(dc,$EmptyMode,$e).expr --- dc - RPLACA(saveNRTdeltaListComp,compEntry) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - -genDeltaSig x == - NRTgetLocalIndex x - -genDeltaSpecialSig x == - x is [":",y,z] => [":",y,genDeltaSig z] - genDeltaSig x - -NRTassocIndexAdd x == - x = $NRTaddForm => 5 - NRTassocIndex x - -NRTassocIndex x == --returns index of "domain" entry x in al - NULL x => x - x = $NRTaddForm => 5 - k := or/[i for i in 1.. for y in $NRTdeltaList - | y.0 = 'domain and y.1 = x and ($found := y)] => - $NRTbase + $NRTdeltaLength - k - nil - -NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) - -NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) - -NRTgetLocalIndex1(item,killBindingIfTrue) == - k := NRTassocIndex item => k - item = $NRTaddForm => 5 - item = '$ => 0 - item = '_$_$ => 2 - value:= - MEMQ(item,$formalArgList) => item - nil - atom item and null MEMQ(item,'($ _$_$)) - and null value => --give slots to atoms - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - $NRTdeltaListComp:=[item,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - saveIndex := $NRTbase + $NRTdeltaLength - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= compOrCroak(item,$EmptyMode,$e).expr --- item - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -NRTgetAddForm domain == - u := HGET($Slot1DataBase,first domain) => - EQSUBSTLIST(rest domain,$FormalMapVariableList,first u) - systemErrorHere '"NRTgetAddForm" - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -NRTassignCapsuleFunctionSlot(op,sig) == ---called from compDefineCapsuleFunction - opSig := [op,sig] - [.,.,implementation] := NRTisExported? opSig or return nil - --if opSig is not exported, it is local and need not be assigned - sig := [genDeltaSig x for x in sig] - opModemapPair := [op,['_$,:sig],['T,implementation]] - POSN1(opModemapPair,$NRTdeltaList) => nil --already there - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp := [nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - -NRTisExported? opSig == - or/[u for u in $domainShell.1 | u.0 = opSig] - -consOpSig(op,sig,dc) == - if null atom op then - keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"]) - mkList [MKQ op,mkList consSig(sig,dc)] - -consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig] - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -consDomainName(x,dc) == - x = dc => ''$ - x = '$ => ['devaluate,'$] - x is [op,:argl] => - (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => - mkList [MKQ op, - :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] - for [.,tag,dom] in argl]] - isFunctor op or op = 'Mapping or constructor? op => - -- call to constructor? needed if op was compiled in $bootStrapMode - mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] - x - x = [] => x - (y := LASSOC(x,$devaluateList)) => y - k:=NRTassocIndex x => - ['devaluate,['ELT,'$,k]] - get(x,'value,$e) or get(x,'mode,$e) => - isDomainForm(x,$e) => ['devaluate,x] - x - MKQ x - -consDomainForm(x,dc) == - x = '$ => '$ - x is [op,:argl] => - op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)] - [op,:[consDomainForm(y,dc) for y in argl]] - x = [] => x - (y := LASSOC(x,$devaluateList)) => y - k:=NRTassocIndex x => ['ELT,'$,k] - get(x,'value,$e) or get(x,'mode,$e) => x - MKQ x - -buildFunctor($definition is [name,:args],sig,code,$locals,$e) == ---PARAMETERS --- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) --- sig: signature of constructor form --- code: result of "doIt", converting body of capsule to CodeDefine forms, e.g. --- (PROGN (LET Rep ...) --- (: (ListOf x y) $) --- (CodeDefine ( )) --- (COND ((HasCategory $ ...) (PROGN ...))) ..) --- $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4) --- same as $functorLocalParameters --- this list is not augmented by this function --- $e: environment ---GLOBAL VARIABLES REFERENCED: --- $domainShell: passed in from compDefineFunctor1 --- $QuickCode: compilation flag - - if code is ['add,.,newstuff] then code := newstuff - - changeDirectoryInSlot1() --this extends $NRTslot1PredicateList - - --pp '"==================" - --for item in $NRTdeltaList repeat pp item - ---LOCAL BOUND FLUID VARIABLES: - $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here ---$frontier: local --index of first local slot=#(cat part of princ view) - $catvecList: local --list of vectors v1..vn for each view - $hasCategoryAlist: local --list of GENSYMs bound to (HasCategory ..) items - $catNames: local --list of names n1..nn for each view - $maximalViews: local --list of maximal categories for domain (???) - $catsig: local --target category (used in ProcessCond) - $SetFunctions: local --copy of p view with preds telling when fnct defined - $MissingFunctionInfo: local --now useless - --vector marking which functions are assigned - $ConstantAssignments: local --code for creation of constants - $epilogue: local := nil --code to set slot 5, things to be done last - $HackSlot4: local --Invention of JHD 13/July/86-set in InvestigateConditions - $extraParms:local --Set in DomainSubstitutionFunction, used in setVector12 - $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later - $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList] - $supplementaries: local - --set in InvestigateConditions to represent any additional - --category membership tests that may be needed(see buildFunctor for details) ------------------------- - $maximalViews: local - oldtime:= TEMPUS_-FUGIT() - [$catsig,:argsig]:= sig - catvecListMaker:=REMDUP - [(comp($catsig,$EmptyMode,$e)).expr, - :[compCategories first u for u in CADR $domainShell.4]] - condCats:= InvestigateConditions [$catsig,:rest catvecListMaker] - -- a list, one %for each element of catvecListMaker - -- indicating under what conditions this - -- category should be present. true => always - makeCatvecCode:= first catvecListMaker - emptyVector := VECTOR() ---if $NRTaddForm and null NRTassocIndex $NRTaddForm then --- --create "domain" entry to $NRTdeltaList --- $NRTdeltaList:= --- [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList] --- $NRTdeltaLength := $NRTdeltaLength+1 ---NRTgetLocalIndex $NRTaddForm - domainShell := GETREFV (6 + $NRTdeltaLength) - for i in 0..4 repeat domainShell.i := $domainShell.i - --we will clobber elements; copy since $domainShell may be a cached vector - $template := - $NRTvec = true => GETREFV (6 + $NRTdeltaLength) - nil - $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]] - $catNames := ['$] -- for DescendCode -- to be changed below for slot 4 - $maximalViews:= nil - $SetFunctions:= GETREFV SIZE domainShell - $MissingFunctionInfo:= GETREFV SIZE domainShell - $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]] - domname:='dv_$ - ---> Do this now to create predicate vector; then DescendCode can refer ---> to predicate vector if it can - [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 - NRTsetVector4Part1($catNames,catvecListMaker,condCats) - [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := - makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] - - storeOperationCode:= DescendCode(code,true,nil,first $catNames) - outsideFunctionCode:= NRTaddDeltaCode() - storeOperationCode:= NRTputInLocalReferences storeOperationCode - if $NRTvec = true then - NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode - codePart2:= - $NRTvec = true => - argStuffCode := - [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList - for arg in rest $definition] - if MEMQ($NRTaddForm,$locals) then - addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals)) - argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode] - [['stuffDomainSlots,'$],:argStuffCode, - :predBitVectorCode2,storeOperationCode] - [:outsideFunctionCode,storeOperationCode] - - $CheckVectorList := NRTcheckVector domainShell ---CODE: part 1 - codePart1:= [:devaluateCode,:domainFormCode,createDomainCode, - createViewCode,setVector0Code, slot3Code,:slamCode] where - devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList] - domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList] - --$NRTdomainFormList is unused now - createDomainCode:= - ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]] - createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]] - setVector0Code:=[$setelt,'$,0,'dv_$] - slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]] - slamCode:= - isCategoryPackageName opOf $definition => nil - [NRTaddToSlam($definition,'$)] - ---CODE: part 3 - $ConstantAssignments := - [NRTputInLocalReferences code for code in $ConstantAssignments] - codePart3:= [:constantCode1, - :constantCode2,:epilogue] where - constantCode1:= - name='Integer => $ConstantAssignments - nil - -- The above line is needed to get the recursion - -- Integer => FontTable => NonNegativeInteger => Integer - -- right. Otherwise NNI has 'unset' for 0 and 1 --- setVector4c:= setVector4part3($catNames,$catvecList) - -- In particular, setVector4part3 and setVector5, - -- which generate calls to local domain-instantiators, - -- must come after operations are set in the vector. - -- The symptoms of getting this wrong are that - -- operations are not set which should be - constantCode2:= --matches previous test on Integer - name='Integer => nil - $ConstantAssignments - epilogue:= $epilogue - ans := - ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$] - $getDomainCode:= nil - --if we didn't kill this, DEFINE would insert it in the wrong place - ans:= minimalise ans - SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime] - --sayBrightly '"------------------functor code: -------------------" - --pp ans - ans - -NRTcheckVector domainShell == ---RETURNS: an alist (((op,sig),:pred) ...) of missing functions - alist := nil - for i in 6..MAXINDEX domainShell repeat ---Vector elements can be one of --- (a) T -- item was marked --- (b) NIL -- item is a domain; will be filled in by setVector4part3 --- (c) categoryForm-- it was a domain view; now irrelevant --- (d) op-signature-- store missing function info in $CheckVectorList - v:= domainShell.i - v=true => nil --item is marked; ignore - null v => nil --a domain, which setVector4part3 will fill in - atom first v => nil --category form; ignore - atom v => systemErrorHere '"CheckVector" - ASSOC(first v,alist) => nil - alist:= - [[first v,:$SetFunctions.i],:alist] - alist - --- Obsolete once we have moved to JHD's world -NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength) - -mkDomainCatName id == INTERN STRCONC(id,";CAT") - -NRTsetVector4(siglist,formlist,condlist) == - $uncondList: local := nil - $condList: local := nil - $count: local := 0 - for sig in reverse siglist for form in reverse formlist - for cond in reverse condlist repeat - NRTsetVector4a(sig,form,cond) - --NRTsetVector4a(first siglist,first formlist,first condlist) - - $lisplibCategoriesExtended:= [$uncondList,:$condList] - code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList] - if $condList then - localVariable := GENSYM() - code := [['LET,localVariable,code]] - for [pred,list] in $condList repeat - code := - [['COND,[pred,['LET,localVariable, - ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], - :code] - code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] - g := GENSYM() - [$setelt,'$,4,['PROG2,['LET,g,code], - ['VECTOR,['catList2catPackageList,g],g]]] - -NRTsetVector4Part1(siglist,formlist,condlist) == - $uncondList: local := nil - $condList: local := nil - $count: local := 0 - for sig in reverse siglist for form in reverse formlist - for cond in reverse condlist repeat - NRTsetVector4a(sig,form,cond) - reducedUncondlist := REMDUP $uncondList - reducedConlist := - [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)] - revCondlist := reverseCondlist reducedConlist - orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist] - [reducedUncondlist,:orCondlist] - --NRTsetVector4a(first siglist,first formlist,first condlist) - -reverseCondlist cl == - alist := nil - for [x,:y] in cl repeat - for z in y repeat - u := ASSOC(z,alist) - null u => alist := [[z,x],:alist] - member(x,CDR u) => nil - RPLACD(u,[x,:CDR u]) - alist - -NRTsetVector4Part2(uncondList,condList) == - $lisplibCategoriesExtended:= [uncondList,:condList] - code := ['mapConsDB,MKQ REVERSE REMDUP uncondList] - if condList then - localVariable := GENSYM() - code := [['LET,localVariable,code]] - for [pred,list] in condList repeat - code := - [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable, - ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], - :code] - code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] - g := GENSYM() - [$setelt,'$,4,['PROG2,['LET,g,code], - ['VECTOR,['catList2catPackageList,g],g]]] - -mergeAppend(l1,l2) == - ATOM l1 => l2 - member(QCAR l1,l2) => mergeAppend(QCDR l1, l2) - CONS(QCAR l1, mergeAppend(QCDR l1, l2)) - ---genLoadTimeValue u == --- name := --- INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1)) --- $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist] --- --see compDefineFunctor1 --- name - -catList2catPackageList u == ---converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...) - [fn x for x in u] where - fn [op,:argl] == - newOp := INTERN(STRCONC(PNAME op,"&")) - addConsDB [newOp,"$",:argl] - -NRTsetVector4a(sig,form,cond) == - sig = '$ => - domainList := - [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0] - $uncondList := APPEND(domainList,$uncondList) - if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] - $uncondList - evalform := eval mkEvalableCategoryForm form - cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)] - $condList := [[cond,[form,:evalform.4.0]],:$condList] - -NRTmakeSlot1 domainShell == - opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect") - fun := - $NRTmakeCompactDirect => '(function lookupInCompactTable) - '(function lookupInTable) - [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]] - -NRTmakeSlot1Info() == --- 4 cases: --- a:T == b add c --- slot1 directory has #s for entries defined in c --- a:T == b --- slot1 has all slot #s = NIL (see compFunctorBody) --- a == b add c --- not allowed (line 7 of getTargetFromRhs) --- a == b --- $NRTderivedTargetIfTrue = true; set directory to NIL - pairlis := - $insideCategoryPackageIfTrue = true => - [:argl,dollarName] := rest $form - [[dollarName,:'_$],:mkSlot1sublis argl] - mkSlot1sublis rest $form - $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1) - opList := - $NRTderivedTargetIfTrue => 'derived - $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist - $lisplibOpAlist - addList := SUBLIS(pairlis,$NRTaddForm) - [first $form,[addList,:opList]] - -mkSlot1sublis argl == - [[a,:b] for a in argl for b in $FormalMapVariableList] - -slot1Filter opList == ---include only those ops which are defined within the capsule - [u for x in opList | u := fn x] where - fn [op,:l] == - u := [entry for entry in l | INTEGERP CADR entry] => [op,:u] - nil - -NRToptimizeHas u == ---u is a list ((pred cond)...) -- see optFunctorBody ---produces an alist: (((HasCategory a b) . GENSYM)...) - u is [a,:b] => - a='HasCategory => LASSOC(u,$hasCategoryAlist) or - $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist] - y - a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b] - a = 'QUOTE => u - [NRToptimizeHas a,:NRToptimizeHas b] - u - -NRTaddToSlam([name,:argnames],shell) == - $mutableDomain => return nil - null argnames => addToConstructorCache(name,nil,shell) - args:= ['LIST,:ASSOCRIGHT $devaluateList] - addToConstructorCache(name,args,shell) - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -changeDirectoryInSlot1() == --called by NRTbuildFunctor - --3 cases: - -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs - -- otherwise called from compFunctorBody (all lookups are forwarded): - -- $NRTdeltaList = nil ===> all slot numbers become nil - $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where - sigloc [opsig,pred,fnsel] == - if pred ^= 'T then - pred := simpBool pred - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => - [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] - [opsig,pred,fnsel] - sortedOplist := listSort(function GLESSEQP, - COPY_-LIST $lisplibOperationAlist,function CADR) - $lastPred :local := nil - $newEnv :local := $e - $domainShell.1 := [fn entry for entry in sortedOplist] where - fn [[op,sig],pred,fnsel] == - if $lastPred ^= pred then - $newEnv := deepChaseInferences(pred,$e) - $lastPred := pred - newfnsel := - fnsel is ['Subsumed,op1,sig1] => - ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] - fnsel - [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] - -genSlotSig(sig,pred,$e) == - [genDeltaSig t for t in sig] - -deepChaseInferences(pred,$e) == - pred is ['AND,:preds] or pred is ['and,:preds] => - for p in preds repeat $e := deepChaseInferences(p,$e) - $e - pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] => - deepChaseInferences(pred1,$e) - pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e - chaseInferences(pred,$e) - -vectorLocation(op,sig) == - u := or/[i for i in 1.. for u in $NRTdeltaList - | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ] - u => $NRTdeltaLength - u + 6 - nil -- this signals that calls should be forwarded - -NRTsubstDelta(initSig) == - sig := [replaceSlotTypes s for s in initSig] where - replaceSlotTypes(t) == - atom t => - not INTEGERP t => t - t = 0 => '$ - t = 2 => '_$_$ - t = 5 => $NRTaddForm - u:= $NRTdeltaList.($NRTdeltaLength+5-t) - CAR u = 'domain => CADR u - error "bad $NRTdeltaList entry" - MEMQ(CAR t,'(Mapping Union Record _:)) => - [CAR t,:[replaceSlotTypes(x) for x in rest t]] - t ------------------------------SLOT1 DATABASE------------------------------------ - -updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info) - -NRTputInLocalReferences bod == - $elt: local := ($QuickCode => 'QREFELT; 'ELT) - NRTputInHead bod - -NRTputInHead bod == - atom bod => bod --- LASSOC(bod,$devaluateList) => nil --- k:= NRTassocIndex bod => [$elt,'_$,k] --- systemError '"unexpected position of domain reference" --- bod ---bod is ['LET,var,val,:extra] and IDENTP var => --- NRTputInTail extra --- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) --- NRTputInHead val --- bod - bod is ['SPADCALL,:args,fn] => - NRTputInTail rest bod --NOTE: args = COPY of rest bod - -- The following test allows function-returning expressions - fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => - k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) --- sayBrightlyNT '"unexpected SPADCALL:" --- pp fn --- nil --- keyedSystemError("S2GE0016",['"NRTputInHead", --- '"unexpected SPADCALL form"]) - nil - NRTputInHead fn - bod - bod is ["COND",:clauses] => - for cc in clauses repeat NRTputInTail cc - bod - bod is ["QUOTE",:.] => bod - bod is ["CLOSEDFN",:.] => bod - bod is ["SPADCONST",dom,ind] => - RPLACA(bod,$elt) - dom = '_$ => nil - k:= NRTassocIndex dom => - RPLACA(LASTNODE bod,[$elt,'_$,k]) - bod - keyedSystemError("S2GE0016",['"NRTputInHead", - '"unexpected SPADCONST form"]) - NRTputInHead first bod - NRTputInTail rest bod - bod - -NRTputInTail x == - for y in tails x repeat - atom (u := first y) => - EQ(u,'$) or LASSOC(u,$devaluateList) => nil - k:= NRTassocIndex u => - atom u => RPLACA(y,[$elt,'_$,k]) - -- u atomic means that the slot will always contain a vector - RPLACA(y,['SPADCHECKELT,'_$,k]) - --this reference must check that slot is a vector - nil - NRTputInHead u - x - - - diff --git a/src/interp/nruncomp.boot.pamphlet b/src/interp/nruncomp.boot.pamphlet new file mode 100644 index 00000000..fbc94289 --- /dev/null +++ b/src/interp/nruncomp.boot.pamphlet @@ -0,0 +1,769 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp nruncomp.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-----------------------------NEW buildFunctor CODE----------------------------- +NRTaddDeltaCode() == +--NOTES: This function is called from NRTbuildFunctor to initially +-- fill slots in $template. The $template so created is stored in the +-- NRLIB. On load, makeDomainTemplate is called on this $template to +-- create a template which becomes slot 0 of the infovec for the constructor. +--The template has 6 kinds of entries: +-- (1) formal arguments and local variables, represented by (QUOTE ) +-- this conflicts by (5) but is ok since each is explicitly set by +-- instantiator code; +-- (2) domains, represented by lazy forms, e.g. (Foo 12 17 6) +-- (3) latch slots, represented SPADCALLable forms which goGet an operation +-- from a domain then cache the operation in the same slot +-- (4) functions, represented by identifiers which are names of functions +-- (5) identifiers/strings, parts of signatures (now parts of signatures +-- now must all have slot numbers, represented by (QUOTE ) +-- (6) constants, like 0 and 1, represented by (CONS .. ) form + kvec := first $catvecList + for i in $NRTbase.. for item in REVERSE $NRTdeltaList + for compItem in REVERSE $NRTdeltaListComp + |null (s:=kvec.i) repeat + $template.i:= deltaTran(item,compItem) + $template.5 := + $NRTaddForm => + $NRTaddForm is ['Tuple,:y] => NREVERSE y + NRTencode($NRTaddForm,$addForm) + nil + +deltaTran(item,compItem) == + item is ['domain,lhs,:.] => NRTencode(lhs,compItem) + --NOTE: all items but signatures are wrapped with domain forms + [op,:modemap] := item + [dcSig,[.,[kind,:.]]] := modemap + [dc,:sig] := dcSig + sig := substitute('$,dc,substitute("$$",'$,sig)) + dcCode := + dc = '$ => + --$NRTaddForm => -5 + 0 + NRTassocIndexAdd dc or keyedSystemError("S2NR0004",[dc]) + formalSig:= SUBLISLIS($FormalMapVariableList,$formalArgList,sig) + kindFlag:= (kind = 'CONST => 'CONST; nil) + newSig := [NRTassocIndex x or x for x in formalSig] + [newSig,dcCode,op,:kindFlag] + +--NRTencodeSig x == [NRTencode y for y in x] + +NRTreplaceAllLocalReferences(form) == + $devaluateList :local := [] + NRTputInLocalReferences form + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == + --converts a domain form to a lazy domain form; everything other than + --the operation name should be assigned a slot + null firstTime and (k:= NRTassocIndex x) => k + VECP x => systemErrorHere '"NRTencode" + PAIRP x => + QCAR x='Record or x is ['Union,['_:,a,b],:.] => + [QCAR x,:[['_:,a,encode(b,c,false)] + for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] + constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => + [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] + ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] + MEMQ(x,$formalArgList) => + v := $FormalMapVariableList.(POSN1(x,$formalArgList)) + firstTime => ['local,v] + v + x = '$ => x + ['QUOTE,x] + +--------------FUNCTIONS CALLED DURING CAPSULE FUNCTION COMPILATION------------- +listOfBoundVars form == +-- Only called from the function genDeltaEntry below + form = '$ => [] + IDENTP form and (u:=get(form,'value,$e)) => + u:=u.expr + MEMQ(KAR u,'(Union Record)) => listOfBoundVars u + [form] + atom form => [] + CAR form = 'QUOTE => [] + EQ(CAR form,":") => listOfBoundVars CADDR form + -- We don't want to pick up the tag, only the domain + "union"/[listOfBoundVars x for x in CDR form] + +optDeltaEntry(op,sig,dc,eltOrConst) == + $killOptimizeIfTrue = true => nil + ndc := + dc = '$ => $functorForm + atom dc and (dcval := get(dc,'value,$e)) => dcval.expr + dc +--if (atom dc) and (dcval := get(dc,'value,$e)) +-- then ndc := dcval.expr +-- else ndc := dc + sig := SUBST(ndc,dc,sig) + not MEMQ(KAR ndc,$optimizableConstructorNames) => nil + dcval := optCallEval ndc + -- MSUBST guarantees to use EQUAL testing + sig := MSUBST(devaluate dcval, ndc, sig) + if rest ndc then + for new in rest devaluate dcval for old in rest ndc repeat + sig := MSUBST(new,old,sig) + -- optCallEval sends (List X) to (LIst (Integer)) etc, + -- so we should make the same transformation + fn := compiledLookup(op,sig,dcval) + if null fn then + -- following code is to handle selectors like first, rest + nsig := [quoteSelector tt for tt in sig] where + quoteSelector(x) == + not(IDENTP x) => x + get(x,'value,$e) => x + x='$ => x + MKQ x + fn := compiledLookup(op,nsig,dcval) + if null fn then return nil + eltOrConst="CONST" => ['XLAM,'ignore,MKQ SPADCALL fn] + GETL(compileTimeBindingOf first fn,'SPADreplace) + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +genDeltaEntry opMmPair == +--called from compApplyModemap +--$NRTdeltaLength=0.. always equals length of $NRTdeltaList + [.,[odc,:.],.] := opMmPair + --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) + [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair + if $profileCompiler = true then profileRecord(dc,op,sig) + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + -- following hack needed to invert Rep to $ substitution + if odc = 'Rep and cform is [.,.,osig] then sig:=osig + newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(sig,dc),consDomainForm(dc,nil)]] + --if null atom dc then + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T + if null NRTassocIndex dc and dc ^= $NRTaddForm and + (member(dc,$functorLocalParameters) or null atom dc) then + --create "domain" entry to $NRTdeltaList + $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= compOrCroak(dc,$EmptyMode,$e).expr +-- dc + RPLACA(saveNRTdeltaListComp,compEntry) + u := + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == + (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 + --n + 1 since $NRTdeltaLength is 1 too large + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + 0 + u + +genDeltaSig x == + NRTgetLocalIndex x + +genDeltaSpecialSig x == + x is [":",y,z] => [":",y,genDeltaSig z] + genDeltaSig x + +NRTassocIndexAdd x == + x = $NRTaddForm => 5 + NRTassocIndex x + +NRTassocIndex x == --returns index of "domain" entry x in al + NULL x => x + x = $NRTaddForm => 5 + k := or/[i for i in 1.. for y in $NRTdeltaList + | y.0 = 'domain and y.1 = x and ($found := y)] => + $NRTbase + $NRTdeltaLength - k + nil + +NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) + +NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) + +NRTgetLocalIndex1(item,killBindingIfTrue) == + k := NRTassocIndex item => k + item = $NRTaddForm => 5 + item = '$ => 0 + item = '_$_$ => 2 + value:= + MEMQ(item,$formalArgList) => item + nil + atom item and null MEMQ(item,'($ _$_$)) + and null value => --give slots to atoms + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + $NRTdeltaListComp:=[item,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + $NRTbase + $NRTdeltaLength - 1 + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + saveIndex := $NRTbase + $NRTdeltaLength + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= compOrCroak(item,$EmptyMode,$e).expr +-- item + RPLACA(saveNRTdeltaListComp,compEntry) + saveIndex + +NRTgetAddForm domain == + u := HGET($Slot1DataBase,first domain) => + EQSUBSTLIST(rest domain,$FormalMapVariableList,first u) + systemErrorHere '"NRTgetAddForm" + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +NRTassignCapsuleFunctionSlot(op,sig) == +--called from compDefineCapsuleFunction + opSig := [op,sig] + [.,.,implementation] := NRTisExported? opSig or return nil + --if opSig is not exported, it is local and need not be assigned + sig := [genDeltaSig x for x in sig] + opModemapPair := [op,['_$,:sig],['T,implementation]] + POSN1(opModemapPair,$NRTdeltaList) => nil --already there + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp := [nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + +NRTisExported? opSig == + or/[u for u in $domainShell.1 | u.0 = opSig] + +consOpSig(op,sig,dc) == + if null atom op then + keyedSystemError("S2GE0016",['"consOpSig",'"bad operator in table"]) + mkList [MKQ op,mkList consSig(sig,dc)] + +consSig(sig,dc) == [consDomainName(sigpart,dc) for sigpart in sig] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +consDomainName(x,dc) == + x = dc => ''$ + x = '$ => ['devaluate,'$] + x is [op,:argl] => + (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => + mkList [MKQ op, + :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] + for [.,tag,dom] in argl]] + isFunctor op or op = 'Mapping or constructor? op => + -- call to constructor? needed if op was compiled in $bootStrapMode + mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] + x + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => + ['devaluate,['ELT,'$,k]] + get(x,'value,$e) or get(x,'mode,$e) => + isDomainForm(x,$e) => ['devaluate,x] + x + MKQ x + +consDomainForm(x,dc) == + x = '$ => '$ + x is [op,:argl] => + op = ":" and argl is [tag, value] => [op, tag, consDomainForm(value,dc)] + [op,:[consDomainForm(y,dc) for y in argl]] + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => ['ELT,'$,k] + get(x,'value,$e) or get(x,'mode,$e) => x + MKQ x + +buildFunctor($definition is [name,:args],sig,code,$locals,$e) == +--PARAMETERS +-- $definition: constructor form, e.g. (SquareMatrix 10 (RationalNumber)) +-- sig: signature of constructor form +-- code: result of "doIt", converting body of capsule to CodeDefine forms, e.g. +-- (PROGN (LET Rep ...) +-- (: (ListOf x y) $) +-- (CodeDefine ( )) +-- (COND ((HasCategory $ ...) (PROGN ...))) ..) +-- $locals: list of variables to go into slot 5, e.g. (R Rep R,1 R,2 R,3 R,4) +-- same as $functorLocalParameters +-- this list is not augmented by this function +-- $e: environment +--GLOBAL VARIABLES REFERENCED: +-- $domainShell: passed in from compDefineFunctor1 +-- $QuickCode: compilation flag + + if code is ['add,.,newstuff] then code := newstuff + + changeDirectoryInSlot1() --this extends $NRTslot1PredicateList + + --pp '"==================" + --for item in $NRTdeltaList repeat pp item + +--LOCAL BOUND FLUID VARIABLES: + $GENNO: local:= 0 --bound in compDefineFunctor1, then as parameter here +--$frontier: local --index of first local slot=#(cat part of princ view) + $catvecList: local --list of vectors v1..vn for each view + $hasCategoryAlist: local --list of GENSYMs bound to (HasCategory ..) items + $catNames: local --list of names n1..nn for each view + $maximalViews: local --list of maximal categories for domain (???) + $catsig: local --target category (used in ProcessCond) + $SetFunctions: local --copy of p view with preds telling when fnct defined + $MissingFunctionInfo: local --now useless + --vector marking which functions are assigned + $ConstantAssignments: local --code for creation of constants + $epilogue: local := nil --code to set slot 5, things to be done last + $HackSlot4: local --Invention of JHD 13/July/86-set in InvestigateConditions + $extraParms:local --Set in DomainSubstitutionFunction, used in setVector12 + $devaluateList: local --Bound to ((#1 . dv$1)..) where &1 := devaluate #1 later + $devaluateList:= [[arg,:b] for arg in args for b in $ModeVariableList] + $supplementaries: local + --set in InvestigateConditions to represent any additional + --category membership tests that may be needed(see buildFunctor for details) +------------------------ + $maximalViews: local + oldtime:= TEMPUS_-FUGIT() + [$catsig,:argsig]:= sig + catvecListMaker:=REMDUP + [(comp($catsig,$EmptyMode,$e)).expr, + :[compCategories first u for u in CADR $domainShell.4]] + condCats:= InvestigateConditions [$catsig,:rest catvecListMaker] + -- a list, one %for each element of catvecListMaker + -- indicating under what conditions this + -- category should be present. true => always + makeCatvecCode:= first catvecListMaker + emptyVector := VECTOR() +--if $NRTaddForm and null NRTassocIndex $NRTaddForm then +-- --create "domain" entry to $NRTdeltaList +-- $NRTdeltaList:= +-- [['domain,NRTaddInner $NRTaddForm,:$NRTaddForm],:$NRTdeltaList] +-- $NRTdeltaLength := $NRTdeltaLength+1 +--NRTgetLocalIndex $NRTaddForm + domainShell := GETREFV (6 + $NRTdeltaLength) + for i in 0..4 repeat domainShell.i := $domainShell.i + --we will clobber elements; copy since $domainShell may be a cached vector + $template := + $NRTvec = true => GETREFV (6 + $NRTdeltaLength) + nil + $catvecList:= [domainShell,:[emptyVector for u in CADR domainShell.4]] + $catNames := ['$] -- for DescendCode -- to be changed below for slot 4 + $maximalViews:= nil + $SetFunctions:= GETREFV SIZE domainShell + $MissingFunctionInfo:= GETREFV SIZE domainShell + $catNames:= ['$,:[GENVAR() for u in rest catvecListMaker]] + domname:='dv_$ + +--> Do this now to create predicate vector; then DescendCode can refer +--> to predicate vector if it can + [$uncondAlist,:$condAlist] := --bound in compDefineFunctor1 + NRTsetVector4Part1($catNames,catvecListMaker,condCats) + [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := + makePredicateBitVector [:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList] + + storeOperationCode:= DescendCode(code,true,nil,first $catNames) + outsideFunctionCode:= NRTaddDeltaCode() + storeOperationCode:= NRTputInLocalReferences storeOperationCode + if $NRTvec = true then + NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode + codePart2:= + $NRTvec = true => + argStuffCode := + [[$setelt,'$,i,v] for i in 6.. for v in $FormalMapVariableList + for arg in rest $definition] + if MEMQ($NRTaddForm,$locals) then + addargname := $FormalMapVariableList.(POSN1($NRTaddForm,$locals)) + argStuffCode := [[$setelt,'$,5,addargname],:argStuffCode] + [['stuffDomainSlots,'$],:argStuffCode, + :predBitVectorCode2,storeOperationCode] + [:outsideFunctionCode,storeOperationCode] + + $CheckVectorList := NRTcheckVector domainShell +--CODE: part 1 + codePart1:= [:devaluateCode,:domainFormCode,createDomainCode, + createViewCode,setVector0Code, slot3Code,:slamCode] where + devaluateCode:= [['LET,b,['devaluate,a]] for [a,:b] in $devaluateList] + domainFormCode := [['LET,a,b] for [a,:b] in NREVERSE $NRTdomainFormList] + --$NRTdomainFormList is unused now + createDomainCode:= + ['LET,domname,['LIST,MKQ CAR $definition,:ASSOCRIGHT $devaluateList]] + createViewCode:= ['LET,'$,['GETREFV, 6+$NRTdeltaLength]] + setVector0Code:=[$setelt,'$,0,'dv_$] + slot3Code := ['QSETREFV,'$,3,['LET,'pv_$,predBitVectorCode1]] + slamCode:= + isCategoryPackageName opOf $definition => nil + [NRTaddToSlam($definition,'$)] + +--CODE: part 3 + $ConstantAssignments := + [NRTputInLocalReferences code for code in $ConstantAssignments] + codePart3:= [:constantCode1, + :constantCode2,:epilogue] where + constantCode1:= + name='Integer => $ConstantAssignments + nil + -- The above line is needed to get the recursion + -- Integer => FontTable => NonNegativeInteger => Integer + -- right. Otherwise NNI has 'unset' for 0 and 1 +-- setVector4c:= setVector4part3($catNames,$catvecList) + -- In particular, setVector4part3 and setVector5, + -- which generate calls to local domain-instantiators, + -- must come after operations are set in the vector. + -- The symptoms of getting this wrong are that + -- operations are not set which should be + constantCode2:= --matches previous test on Integer + name='Integer => nil + $ConstantAssignments + epilogue:= $epilogue + ans := + ['PROGN,:optFunctorPROGN [:codePart1,:codePart2,:codePart3], '$] + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + ans:= minimalise ans + SAY ['"time taken in buildFunctor: ",TEMPUS_-FUGIT()-oldtime] + --sayBrightly '"------------------functor code: -------------------" + --pp ans + ans + +NRTcheckVector domainShell == +--RETURNS: an alist (((op,sig),:pred) ...) of missing functions + alist := nil + for i in 6..MAXINDEX domainShell repeat +--Vector elements can be one of +-- (a) T -- item was marked +-- (b) NIL -- item is a domain; will be filled in by setVector4part3 +-- (c) categoryForm-- it was a domain view; now irrelevant +-- (d) op-signature-- store missing function info in $CheckVectorList + v:= domainShell.i + v=true => nil --item is marked; ignore + null v => nil --a domain, which setVector4part3 will fill in + atom first v => nil --category form; ignore + atom v => systemErrorHere '"CheckVector" + ASSOC(first v,alist) => nil + alist:= + [[first v,:$SetFunctions.i],:alist] + alist + +-- Obsolete once we have moved to JHD's world +NRTvectorCopy(cacheName,domName,deltaLength) == GETREFV (6 + deltaLength) + +mkDomainCatName id == INTERN STRCONC(id,";CAT") + +NRTsetVector4(siglist,formlist,condlist) == + $uncondList: local := nil + $condList: local := nil + $count: local := 0 + for sig in reverse siglist for form in reverse formlist + for cond in reverse condlist repeat + NRTsetVector4a(sig,form,cond) + --NRTsetVector4a(first siglist,first formlist,first condlist) + + $lisplibCategoriesExtended:= [$uncondList,:$condList] + code := ['mapConsDB,MKQ REVERSE REMDUP $uncondList] + if $condList then + localVariable := GENSYM() + code := [['LET,localVariable,code]] + for [pred,list] in $condList repeat + code := + [['COND,[pred,['LET,localVariable, + ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], + :code] + code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] + g := GENSYM() + [$setelt,'$,4,['PROG2,['LET,g,code], + ['VECTOR,['catList2catPackageList,g],g]]] + +NRTsetVector4Part1(siglist,formlist,condlist) == + $uncondList: local := nil + $condList: local := nil + $count: local := 0 + for sig in reverse siglist for form in reverse formlist + for cond in reverse condlist repeat + NRTsetVector4a(sig,form,cond) + reducedUncondlist := REMDUP $uncondList + reducedConlist := + [[x,:y] for [x,z] in $condList| y := SETDIFFERENCE(z,reducedUncondlist)] + revCondlist := reverseCondlist reducedConlist + orCondlist := [[x,:MKPF(y,'OR)] for [x,:y] in revCondlist] + [reducedUncondlist,:orCondlist] + --NRTsetVector4a(first siglist,first formlist,first condlist) + +reverseCondlist cl == + alist := nil + for [x,:y] in cl repeat + for z in y repeat + u := ASSOC(z,alist) + null u => alist := [[z,x],:alist] + member(x,CDR u) => nil + RPLACD(u,[x,:CDR u]) + alist + +NRTsetVector4Part2(uncondList,condList) == + $lisplibCategoriesExtended:= [uncondList,:condList] + code := ['mapConsDB,MKQ REVERSE REMDUP uncondList] + if condList then + localVariable := GENSYM() + code := [['LET,localVariable,code]] + for [pred,list] in condList repeat + code := + [['COND,[predicateBitRef SUBLIS($pairlis,pred),['LET,localVariable, + ['mergeAppend,['mapConsDB,MKQ list],localVariable]]]], + :code] + code := ['PROGN,:NREVERSE [['NREVERSE,localVariable],:code]] + g := GENSYM() + [$setelt,'$,4,['PROG2,['LET,g,code], + ['VECTOR,['catList2catPackageList,g],g]]] + +mergeAppend(l1,l2) == + ATOM l1 => l2 + member(QCAR l1,l2) => mergeAppend(QCDR l1, l2) + CONS(QCAR l1, mergeAppend(QCDR l1, l2)) + +--genLoadTimeValue u == +-- name := +-- INTERN STRCONC(PNAME first $definition,'";",STRINGIZE($count:=$count+1)) +-- $NRTloadTimeAlist := [[name,:['addConsDB,MKQ u]],:$NRTloadTimeAlist] +-- --see compDefineFunctor1 +-- name + +catList2catPackageList u == +--converts ((Set) (Module R) ...) to ((Set& $) (Module& $ R)...) + [fn x for x in u] where + fn [op,:argl] == + newOp := INTERN(STRCONC(PNAME op,"&")) + addConsDB [newOp,"$",:argl] + +NRTsetVector4a(sig,form,cond) == + sig = '$ => + domainList := + [optimize COPY KAR comp(d,$EmptyMode,$e) or d for d in $domainShell.4.0] + $uncondList := APPEND(domainList,$uncondList) + if isCategoryForm(form,$e) then $uncondList := [form,:$uncondList] + $uncondList + evalform := eval mkEvalableCategoryForm form + cond = true => $uncondList := [form,:APPEND(evalform.4.0,$uncondList)] + $condList := [[cond,[form,:evalform.4.0]],:$condList] + +NRTmakeSlot1 domainShell == + opDirectName := INTERN STRCONC(PNAME first $definition,'";opDirect") + fun := + $NRTmakeCompactDirect => '(function lookupInCompactTable) + '(function lookupInTable) + [($QuickCode=>'QSETREFV;'SETELT), '$,1, ['LIST,fun,'$,opDirectName]] + +NRTmakeSlot1Info() == +-- 4 cases: +-- a:T == b add c --- slot1 directory has #s for entries defined in c +-- a:T == b --- slot1 has all slot #s = NIL (see compFunctorBody) +-- a == b add c --- not allowed (line 7 of getTargetFromRhs) +-- a == b --- $NRTderivedTargetIfTrue = true; set directory to NIL + pairlis := + $insideCategoryPackageIfTrue = true => + [:argl,dollarName] := rest $form + [[dollarName,:'_$],:mkSlot1sublis argl] + mkSlot1sublis rest $form + $lisplibOpAlist := transformOperationAlist SUBLIS(pairlis,$domainShell.1) + opList := + $NRTderivedTargetIfTrue => 'derived + $insideCategoryPackageIfTrue = true => slot1Filter $lisplibOpAlist + $lisplibOpAlist + addList := SUBLIS(pairlis,$NRTaddForm) + [first $form,[addList,:opList]] + +mkSlot1sublis argl == + [[a,:b] for a in argl for b in $FormalMapVariableList] + +slot1Filter opList == +--include only those ops which are defined within the capsule + [u for x in opList | u := fn x] where + fn [op,:l] == + u := [entry for entry in l | INTEGERP CADR entry] => [op,:u] + nil + +NRToptimizeHas u == +--u is a list ((pred cond)...) -- see optFunctorBody +--produces an alist: (((HasCategory a b) . GENSYM)...) + u is [a,:b] => + a='HasCategory => LASSOC(u,$hasCategoryAlist) or + $hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist] + y + a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b] + a = 'QUOTE => u + [NRToptimizeHas a,:NRToptimizeHas b] + u + +NRTaddToSlam([name,:argnames],shell) == + $mutableDomain => return nil + null argnames => addToConstructorCache(name,nil,shell) + args:= ['LIST,:ASSOCRIGHT $devaluateList] + addToConstructorCache(name,args,shell) + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +changeDirectoryInSlot1() == --called by NRTbuildFunctor + --3 cases: + -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs + -- otherwise called from compFunctorBody (all lookups are forwarded): + -- $NRTdeltaList = nil ===> all slot numbers become nil + $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where + sigloc [opsig,pred,fnsel] == + if pred ^= 'T then + pred := simpBool pred + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => + [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] + [opsig,pred,fnsel] + sortedOplist := listSort(function GLESSEQP, + COPY_-LIST $lisplibOperationAlist,function CADR) + $lastPred :local := nil + $newEnv :local := $e + $domainShell.1 := [fn entry for entry in sortedOplist] where + fn [[op,sig],pred,fnsel] == + if $lastPred ^= pred then + $newEnv := deepChaseInferences(pred,$e) + $lastPred := pred + newfnsel := + fnsel is ['Subsumed,op1,sig1] => + ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] + fnsel + [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] + +genSlotSig(sig,pred,$e) == + [genDeltaSig t for t in sig] + +deepChaseInferences(pred,$e) == + pred is ['AND,:preds] or pred is ['and,:preds] => + for p in preds repeat $e := deepChaseInferences(p,$e) + $e + pred is ['OR,pred1,:.] or pred is ['or,pred1,:.] => + deepChaseInferences(pred1,$e) + pred is 'T or pred is ['NOT,:.] or pred is ['not,:.] => $e + chaseInferences(pred,$e) + +vectorLocation(op,sig) == + u := or/[i for i in 1.. for u in $NRTdeltaList + | u is [=op,[='$,: xsig],:.] and sig=NRTsubstDelta(xsig) ] + u => $NRTdeltaLength - u + 6 + nil -- this signals that calls should be forwarded + +NRTsubstDelta(initSig) == + sig := [replaceSlotTypes s for s in initSig] where + replaceSlotTypes(t) == + atom t => + not INTEGERP t => t + t = 0 => '$ + t = 2 => '_$_$ + t = 5 => $NRTaddForm + u:= $NRTdeltaList.($NRTdeltaLength+5-t) + CAR u = 'domain => CADR u + error "bad $NRTdeltaList entry" + MEMQ(CAR t,'(Mapping Union Record _:)) => + [CAR t,:[replaceSlotTypes(x) for x in rest t]] + t +-----------------------------SLOT1 DATABASE------------------------------------ + +updateSlot1DataBase [name,info] == HPUT($Slot1DataBase,name,info) + +NRTputInLocalReferences bod == + $elt: local := ($QuickCode => 'QREFELT; 'ELT) + NRTputInHead bod + +NRTputInHead bod == + atom bod => bod +-- LASSOC(bod,$devaluateList) => nil +-- k:= NRTassocIndex bod => [$elt,'_$,k] +-- systemError '"unexpected position of domain reference" +-- bod +--bod is ['LET,var,val,:extra] and IDENTP var => +-- NRTputInTail extra +-- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) +-- NRTputInHead val +-- bod + bod is ['SPADCALL,:args,fn] => + NRTputInTail rest bod --NOTE: args = COPY of rest bod + -- The following test allows function-returning expressions + fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => + k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) +-- sayBrightlyNT '"unexpected SPADCALL:" +-- pp fn +-- nil +-- keyedSystemError("S2GE0016",['"NRTputInHead", +-- '"unexpected SPADCALL form"]) + nil + NRTputInHead fn + bod + bod is ["COND",:clauses] => + for cc in clauses repeat NRTputInTail cc + bod + bod is ["QUOTE",:.] => bod + bod is ["CLOSEDFN",:.] => bod + bod is ["SPADCONST",dom,ind] => + RPLACA(bod,$elt) + dom = '_$ => nil + k:= NRTassocIndex dom => + RPLACA(LASTNODE bod,[$elt,'_$,k]) + bod + keyedSystemError("S2GE0016",['"NRTputInHead", + '"unexpected SPADCONST form"]) + NRTputInHead first bod + NRTputInTail rest bod + bod + +NRTputInTail x == + for y in tails x repeat + atom (u := first y) => + EQ(u,'$) or LASSOC(u,$devaluateList) => nil + k:= NRTassocIndex u => + atom u => RPLACA(y,[$elt,'_$,k]) + -- u atomic means that the slot will always contain a vector + RPLACA(y,['SPADCHECKELT,'_$,k]) + --this reference must check that slot is a vector + nil + NRTputInHead u + x + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot deleted file mode 100644 index db9136af..00000000 --- a/src/interp/nrunfast.boot +++ /dev/null @@ -1,670 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---======================================================================= --- Basic Functions ---======================================================================= -initNewWorld() == - $NRTflag := true - $NRTvec := true - $NRTmakeCompactDirect := true - $NRTquick := true - $NRTmakeShortDirect := true - $newWorld := true - $monitorNewWorld := false - $consistencyCheck := false - $spadLibFT := 'NRLIB - $NRTmonitorIfTrue := false - $updateCatTableIfTrue := false - $doNotCompressHashTableIfTrue := true - -isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute - -getDomainByteVector dom == CDDR dom.4 - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -getOpCode(op,vec,max) == ---search Op vector for "op" returning code if found, nil otherwise - res := nil - for i in 0..max by 2 repeat - EQ(QVELT(vec,i),op) => return (res := QSADD1 i) - res - ---======================================================= --- Lookup From Compiled Code ---======================================================= -newGoGet(:l) == - [:arglist,env] := l - slot := replaceGoGetSlot env - APPLY(first slot,[:arglist,rest slot]) --SPADCALL it! - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -replaceGoGetSlot env == - [thisDomain,index,:op] := env - thisDomainForm := devaluate thisDomain - bytevec := getDomainByteVector thisDomain - numOfArgs := bytevec.index - goGetDomainSlotIndex := bytevec.(index := QSADD1 index) - goGetDomain := - goGetDomainSlotIndex = 0 => thisDomain - thisDomain.goGetDomainSlotIndex - if PAIRP goGetDomain then - goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) - sig := - [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) - for i in 0..numOfArgs] - thisSlot := bytevec.(QSADD1 index) - if $monitorNewWorld then - sayLooking(concat('"%l","..",form2String thisDomainForm, - '" wants",'"%l",'" "),op,sig,goGetDomain) - slot := .basicLookup(op,sig,goGetDomain,goGetDomain) - slot = nil => - $returnNowhereFromGoGet = true => - ['nowhere,:goGetDomain] --see newGetDomainOpTable - sayBrightly concat('"Function: ",formatOpSignature(op,sig), - '" is missing from domain: ",form2String goGetDomain.0) - keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) - if $monitorNewWorld then - sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) - SETELT(thisDomain,thisSlot,slot) - if $monitorNewWorld then - sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) - slot - ---======================================================= --- Lookup Function in Slot 1 (via SPADCALL) ---======================================================= -lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) - -lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupInCompactTable(op,sig,dollar,env) == - newLookupInTable(op,sig,dollar,env,true) - -newLookupInTable(op,sig,dollar,[domain,opvec],flag) == - dollar = nil => systemError() - $lookupDefaults = true => - newLookupInCategories(op,sig,domain,dollar) --lookup first in my cats - or newLookupInAddChain(op,sig,domain,dollar) - --fast path when called from newGoGet - success := false - if $monitorNewWorld then - sayLooking(concat('"---->",form2String devaluate domain, - '"----> searching op table for:","%l"," "),op,sig,dollar) - someMatch := false - numvec := getDomainByteVector domain - predvec := domain.3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return - flag => newLookupInAddChain(op,sig,domain,dollar) - nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - numArgs := QSDIFFERENCE(#sig,1) - success := nil - $isDefaultingPackage: local := - -- use special defaulting handler when dollar non-trivial - dollar ^= domain and isDefaultPackageForm? devaluate domain - while finish > start repeat - PROGN - i := start - numArgs ^= (numTableArgs :=numvec.i) => nil - predIndex := numvec.(i := QSADD1 i) - NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil - loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain) - null loc => nil --signifies no match - loc = 1 => (someMatch := true) - loc = 0 => - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - i := start + 2 - someMatch := true --mark so that if subsumption fails, look for original - subsumptionSig := - [newExpandTypeSlot(numvec.(QSPLUS(i,j)), - dollar,domain) for j in 0..numTableArgs] - if $monitorNewWorld then - sayBrightly [formatOpSignature(op,sig),'"--?-->", - formatOpSignature(op,subsumptionSig)] - nil - slot := domain.loc - null atom slot => - EQ(QCAR slot,'newGoGet) => someMatch:=true - --treat as if operation were not there - --if EQ(QCAR slot,'newGoGet) then - -- UNWIND_-PROTECT --break infinite recursion - -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), - -- if domain.loc = 'skip then domain.loc := slot) - return (success := slot) - slot = 'skip => --recursive call from above 'replaceGoGetSlot - return (success := newLookupInAddChain(op,sig,domain,dollar)) - systemError '"unexpected format" - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - NE(success,'failed) and success => - if $monitorNewWorld then - sayLooking1('"<----",uu) where uu == - PAIRP success => [first success,:devaluate rest success] - success - success - subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u - flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) - nil - - -isDefaultPackageForm? x == x is [op,:.] - and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&" - - ---======================================================= --- Lookup Addlist (from lookupInDomainTable or lookupInDomain) ---======================================================= -newLookupInAddChain(op,sig,addFormDomain,dollar) == - if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain) - addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5) - addFunction => - if $monitorNewWorld then - sayLooking1(concat('"<----add-chain function found for ", - form2String devaluate addFormDomain,'"<----"),CDR addFunction) - addFunction - nil - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -newLookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := addFormDomain.index => - INTEGERP KAR addFormCell => - or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index) - lookupInDomainVector(op,sig,addFormDomain.index,dollar) - nil - ---======================================================= --- Category Default Lookup (from goGet or lookupInAddChain) ---======================================================= -newLookupInCategories(op,sig,dom,dollar) == - slot4 := dom.4 - catVec := CADR slot4 - SIZE catVec = 0 => nil --early exit if no categories - INTEGERP KDR catVec.0 => - newLookupInCategories1(op,sig,dom,dollar) --old style - $lookupDefaults : local := nil - if $monitorNewWorld = true then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := dom.3 - packageVec := QCAR slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..MAXINDEX packageVec | - (entry := packageVec.i) and entry ^= 'T repeat - package := - VECP entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - IDENTP entry => - cat := catVec.i - packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) - success := - --VECP infovec => ----new world - true => ----new world - opvec := infovec.1 - max := MAXINDEX opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDDR infovec.3 - endPos := - code+2 > max => SIZE byteVector - opvec.(code+2) - not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil - --numOfArgs := byteVector.(opvec.code) - --numOfArgs ^= #(QCDR sig) => nil - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - ----old world - table := HGET($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u | #sig = #x.0]) => - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld = true then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := basicLookup(op,sig,package,dollar) => - if $monitorNewWorld = true then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld = true then - sayBrightly '"candidate fails -- continuing to search categories" - nil - -nrunNumArgCheck(num,bytevec,start,finish) == - args := bytevec.start - num = args => true - (start := start + args + 4) = finish => nil - nrunNumArgCheck(num,bytevec,start,finish) - -newLookupInCategories1(op,sig,dom,dollar) == - $lookupDefaults : local := nil - if $monitorNewWorld = true then sayBrightly concat('"----->", - form2String devaluate dom,'"-----> searching default packages for ",op) - predvec := dom.3 - slot4 := dom.4 - packageVec := CAR slot4 - catVec := CAR QCDR slot4 ---the next three lines can go away with new category world - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - for i in 0..MAXINDEX packageVec | (entry := ELT(packageVec,i)) - and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and - (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat - package := - VECP entry => - if $monitorNewWorld then - sayLooking1('"already instantiated cat package",entry) - entry - IDENTP entry => - cat := QCAR node - packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) - success := - VECP infovec => - opvec := infovec.1 - max := MAXINDEX opvec - code := getOpCode(op,opvec,max) - null code => nil - byteVector := CDDR infovec.3 - numOfArgs := byteVector.(opvec.code) - numOfArgs ^= #(QCDR sig) => nil - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - table := HGET($Slot1DataBase,entry) or systemError nil - (u := LASSQ(op,table)) - and (v := or/[rest x for x in u | #sig = #x.0]) => - packageForm := [entry,'$,:CDR cat] - package := evalSlotDomain(packageForm,dom) - packageVec.i := package - package - nil - null success => - if $monitorNewWorld = true then - sayBrightlyNT '" not in: " - pp (packageForm and devaluate package or entry) - nil - if $monitorNewWorld then - sayLooking1('"candidate default package instantiated: ",success) - success - entry - null package => nil - if $monitorNewWorld then - sayLooking1('"Looking at instantiated package ",package) - res := lookupInDomainVector(op,sig,package,dollar) => - if $monitorNewWorld = true then - sayBrightly '"candidate default package succeeds" - return res - if $monitorNewWorld = true then - sayBrightly '"candidate fails -- continuing to search categories" - nil - ---======================================================= --- Instantiate Default Package if Signature Matches ---======================================================= - -getNewDefaultPackage(op,sig,infovec,dom,dollar) == - hohohoho() - opvec := infovec . 1 - numvec := CDDR infovec . 3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - numArgs := QSDIFFERENCE(#sig,1) - success := nil - while finish > start repeat - PROGN - i := start - numArgs ^= (numTableArgs :=numvec.i) => nil - newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) => - return (success := true) - start := QSPLUS(start,QSPLUS(numTableArgs,4)) - null success => nil - defaultPackage := cacheCategoryPackage(packageVec,catVec,i) - ---======================================================= --- Compare Signature to One Derived from Table ---======================================================= -newCompareSig(sig, numvec, index, dollar, domain) == - k := index - null (target := first sig) - or lazyMatchArg(target,numvec.k,dollar,domain) => - and/[lazyMatchArg(s,numvec.(k := i),dollar,domain) - for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k) - nil - nil - ---======================================================= --- Compare Signature to One Derived from Table ---======================================================= -lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -lazyMatchArg2(s,a,dollar,domain,typeFlag) == - if s = '$ then --- a = 0 => return true --needed only if extra call in newGoGet to basicLookup - s := devaluate dollar -- calls from HasCategory can have $s - INTEGERP a => - not typeFlag => s = domain.a - a = 6 and $isDefaultingPackage => s = devaluate dollar - VECP (d := domainVal(dollar,domain,a)) => - s = d.0 => true - domainArg := ($isDefaultingPackage => domain.6.0; domain.0) - KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - lazyMatch(s,d,dollar,domain) --new style - a = '$ => s = devaluate dollar - STRINGP a => - s is ['QUOTE,y] and PNAME y = a - IDENTP s and PNAME s = a - atom a => a = s - op := opOf a - op = 'NRTEVAL => s = nrtEval(CADR a,domain) - op = 'QUOTE => s = CADR a - lazyMatch(s,a,dollar,domain) - --above line is temporarily necessary until system is compiled 8/15/90 ---s = a - -lazyMatch(source,lazyt,dollar,domain) == - lazyt is [op,:argl] and null atom source and op=CAR source - and #(sargl := CDR source) = #argl => - MEMQ(op,'(Record Union)) and first argl is [":",:.] => - and/[stag = atag and lazyMatchArg(s,a,dollar,domain) - for [.,stag,s] in sargl for [.,atag,a] in argl] - MEMQ(op,'(Union Mapping QUOTE)) => - and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] - coSig := GETDATABASE(op,'COSIG) - NULL coSig => error ["bad Constructor op", op] - and/[lazyMatchArg2(s,a,dollar,domain,flag) - for s in sargl for a in argl for flag in rest coSig] - STRINGP source and lazyt is ['QUOTE,=source] => true - NUMBERP source => - lazyt is ['_#, slotNum] => source = #(domain.slotNum) - lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) - nil - source is ['construct,:l] => l = lazyt - -- A hideous hack on the same lines as the previous four lines JHD/MCD - nil - - -lazyMatchArgDollarCheck(s,d,dollarName,domainName) == - #s ^= #d => nil - scoSig := GETDATABASE(opOf s,'COSIG) or return nil - if MEMQ(opOf s, '(Union Mapping Record)) then - scoSig := [true for x in s] - and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where - fn == - x = arg => true - x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg) - x = '$ and (arg = dollarName or arg = domainName) => true - x = dollarName and arg = domainName => true - ATOM x or ATOM arg => false - xt and CAR x = CAR arg => - lazyMatchArgDollarCheck(x,arg,dollarName,domainName) - false - -lookupInDomainByName(op,domain,arg) == - atom arg => nil - opvec := domain . 1 . 2 - numvec := getDomainByteVector domain - predvec := domain.3 - max := MAXINDEX opvec - k := getOpCode(op,opvec,max) or return nil - maxIndex := MAXINDEX numvec - start := ELT(opvec,k) - finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) - maxIndex - if QSGREATERP(finish,maxIndex) then systemError '"limit too large" - success := false - while finish > start repeat - i := start - numberOfArgs :=numvec.i - predIndex := numvec.(i := QSADD1 i) - NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil - slotIndex := numvec.(i + 2 + numberOfArgs) - newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) - slot := domain.slotIndex - null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true) - start := QSPLUS(start,QSPLUS(numberOfArgs,4)) - success - ---======================================================= --- Expand Signature from Encoded Slot Form ---======================================================= ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandGoGetTypeSlot(slot,dollar,domain) == - newExpandTypeSlot(slot,domain,domain) - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandTypeSlot(slot, dollar, domain) == ---> returns domain form for dollar.slot - newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain) - - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandLocalTypeForm([functorName,:argl],dollar,domain) == - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] - for [.,tag,dom] in argl]] - MEMQ(functorName, '(Union Mapping)) => - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] - functorName = 'QUOTE => [functorName,:argl] - coSig := GETDATABASE(functorName,'COSIG) - NULL coSig => error ["bad functorName", functorName] - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) - for a in argl for flag in rest coSig]] - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == - u = '$ => dollar.0 -------eliminate this as $ is rep by 0 - INTEGERP u => - typeFlag => newExpandTypeSlot(u, dollar,domain) - domain.u - u is ['NRTEVAL,y] => nrtEval(y,domain) - u is ['QUOTE,y] => y - atom u => u --can be first, rest, etc. - newExpandLocalTypeForm(u,dollar,domain) - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -nrtEval(expr,dom) == - $:fluid := dom - eval expr - -domainVal(dollar,domain,index) == ---returns a domain or a lazy slot - index = 0 => dollar - index = 2 => domain - domain.index - - ---======================================================= --- Convert Lazy Domain to Domain Form ---======================================================= - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lazyDomainSet(lazyForm,thisDomain,slot) == - form := - lazyForm is [vec,.,:u] and VECP vec => u --old style - lazyForm --new style - slotDomain := evalSlotDomain(form,thisDomain) - if $monitorNewWorld then - sayLooking1(concat(form2String devaluate thisDomain, - '" activating lazy slot ",slot,'": "),slotDomain) - name := CAR form - SETELT(thisDomain,slot,slotDomain) - ---======================================================= --- HasCategory/Attribute ---======================================================= --- PLEASE NOTE: This function has the rather charming side-effect that --- e.g. it works if domform is an Aldor Category. This is being used --- by extendscategoryForm in c-util to allow Aldor domains to be used --- in spad code. Please do not break this! An example is the use of --- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. -newHasTest(domform,catOrAtt) == - domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => - ofCategory(domform, catOrAtt) - catOrAtt = '(Type) => true - GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where - -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where - fn(a,b) == - categoryForm?(a) => assoc(b, ancestorsOf(a, nil)) - isPartialMode a => throwKeyedMsg("S2IS0025",NIL) - b is ["SIGNATURE",:opSig] => - HasSignature(evalDomain a,opSig) - b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr) - hasCaty(a,b,NIL) ^= 'failed - HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean - op := opOf catOrAtt - isAtom := atom catOrAtt - null isAtom and op = 'Join => - and/[newHasTest(domform,x) for x in rest catOrAtt] --- we will refuse to say yes for 'Cat has Cat' ---GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) --- on second thoughts we won't! - GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => - domform = catOrAtt => 'T - for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat - return evalCond cond where - evalCond x == - ATOM x => x - [pred,:l] := x - pred = 'has => - l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) - l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1) - newHasTest(first l ,first rest l) - pred = 'OR => or/[evalCond i for i in l] - pred = 'AND => and/[evalCond i for i in l] - x - null isAtom and constructor? op => - domain := eval mkEvalable domform - newHasCategory(domain,catOrAtt) - newHasAttribute(eval mkEvalable domform,catOrAtt) - -lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 - n : FIXNUM := MAXINDEX catvec - xop := CAR x - or/[ELT(auxvec,i) for i in 0..n | - xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] - -lazyMatchAssocV1(x,vec,domain) == --old style slot4 - n : FIXNUM := MAXINDEX vec - xop := CAR x - or/[QCDR QVELT(vec,i) for i in 0..n | - xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)] - ---newHasAttribute(domain,attrib) == --- predIndex := LASSOC(attrib,domain.2) => --- EQ(predIndex,0) => true --- predvec := domain.3 --- testBitVector(predvec,predIndex) --- false - ---======================================================= --- Utility Functions ---======================================================= - -sayLooking(prefix,op,sig,dom) == - $monitorNewWorld := false - dollar := devaluate dom - atom dollar or VECP dollar or or/[VECP x for x in dollar] => systemError nil - sayBrightly - concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar) - $monitorNewWorld := true - -sayLooking1(prefix,dom) == - $monitorNewWorld := false - dollar := - VECP dom => devaluate dom - devaluateList dom - sayBrightly concat(prefix,form2String dollar) - $monitorNewWorld := true - -cc() == -- don't remove this function - clearConstructorCaches() - clearClams() diff --git a/src/interp/nrunfast.boot.pamphlet b/src/interp/nrunfast.boot.pamphlet new file mode 100644 index 00000000..e6a29b12 --- /dev/null +++ b/src/interp/nrunfast.boot.pamphlet @@ -0,0 +1,692 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nrunfast.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--======================================================================= +-- Basic Functions +--======================================================================= +initNewWorld() == + $NRTflag := true + $NRTvec := true + $NRTmakeCompactDirect := true + $NRTquick := true + $NRTmakeShortDirect := true + $newWorld := true + $monitorNewWorld := false + $consistencyCheck := false + $spadLibFT := 'NRLIB + $NRTmonitorIfTrue := false + $updateCatTableIfTrue := false + $doNotCompressHashTableIfTrue := true + +isNewWorldDomain domain == INTEGERP domain.3 --see HasCategory/Attribute + +getDomainByteVector dom == CDDR dom.4 + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +getOpCode(op,vec,max) == +--search Op vector for "op" returning code if found, nil otherwise + res := nil + for i in 0..max by 2 repeat + EQ(QVELT(vec,i),op) => return (res := QSADD1 i) + res + +--======================================================= +-- Lookup From Compiled Code +--======================================================= +newGoGet(:l) == + [:arglist,env] := l + slot := replaceGoGetSlot env + APPLY(first slot,[:arglist,rest slot]) --SPADCALL it! + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +replaceGoGetSlot env == + [thisDomain,index,:op] := env + thisDomainForm := devaluate thisDomain + bytevec := getDomainByteVector thisDomain + numOfArgs := bytevec.index + goGetDomainSlotIndex := bytevec.(index := QSADD1 index) + goGetDomain := + goGetDomainSlotIndex = 0 => thisDomain + thisDomain.goGetDomainSlotIndex + if PAIRP goGetDomain then + goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) + sig := + [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) + for i in 0..numOfArgs] + thisSlot := bytevec.(QSADD1 index) + if $monitorNewWorld then + sayLooking(concat('"%l","..",form2String thisDomainForm, + '" wants",'"%l",'" "),op,sig,goGetDomain) + slot := .basicLookup(op,sig,goGetDomain,goGetDomain) + slot = nil => + $returnNowhereFromGoGet = true => + ['nowhere,:goGetDomain] --see newGetDomainOpTable + sayBrightly concat('"Function: ",formatOpSignature(op,sig), + '" is missing from domain: ",form2String goGetDomain.0) + keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) + if $monitorNewWorld then + sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) + SETELT(thisDomain,thisSlot,slot) + if $monitorNewWorld then + sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) + slot + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +lookupFF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +lookupUF(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupComplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,nil) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupIncomplete(op,sig,dollar,env) == newLookupInTable(op,sig,dollar,env,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInCompactTable(op,sig,dollar,env) == + newLookupInTable(op,sig,dollar,env,true) + +newLookupInTable(op,sig,dollar,[domain,opvec],flag) == + dollar = nil => systemError() + $lookupDefaults = true => + newLookupInCategories(op,sig,domain,dollar) --lookup first in my cats + or newLookupInAddChain(op,sig,domain,dollar) + --fast path when called from newGoGet + success := false + if $monitorNewWorld then + sayLooking(concat('"---->",form2String devaluate domain, + '"----> searching op table for:","%l"," "),op,sig,dollar) + someMatch := false + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return + flag => newLookupInAddChain(op,sig,domain,dollar) + nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + $isDefaultingPackage: local := + -- use special defaulting handler when dollar non-trivial + dollar ^= domain and isDefaultPackageForm? devaluate domain + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + loc := newCompareSig(sig,numvec,(i := QSADD1 i),dollar,domain) + null loc => nil --signifies no match + loc = 1 => (someMatch := true) + loc = 0 => + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + i := start + 2 + someMatch := true --mark so that if subsumption fails, look for original + subsumptionSig := + [newExpandTypeSlot(numvec.(QSPLUS(i,j)), + dollar,domain) for j in 0..numTableArgs] + if $monitorNewWorld then + sayBrightly [formatOpSignature(op,sig),'"--?-->", + formatOpSignature(op,subsumptionSig)] + nil + slot := domain.loc + null atom slot => + EQ(QCAR slot,'newGoGet) => someMatch:=true + --treat as if operation were not there + --if EQ(QCAR slot,'newGoGet) then + -- UNWIND_-PROTECT --break infinite recursion + -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot), + -- if domain.loc = 'skip then domain.loc := slot) + return (success := slot) + slot = 'skip => --recursive call from above 'replaceGoGetSlot + return (success := newLookupInAddChain(op,sig,domain,dollar)) + systemError '"unexpected format" + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + NE(success,'failed) and success => + if $monitorNewWorld then + sayLooking1('"<----",uu) where uu == + PAIRP success => [first success,:devaluate rest success] + success + success + subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u + flag or someMatch => newLookupInAddChain(op,sig,domain,dollar) + nil + + +isDefaultPackageForm? x == x is [op,:.] + and IDENTP op and (s := PNAME op).(MAXINDEX s) = "&" + + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +newLookupInAddChain(op,sig,addFormDomain,dollar) == + if $monitorNewWorld then sayLooking1('"looking up add-chain: ",addFormDomain) + addFunction:=newLookupInDomain(op,sig,addFormDomain,dollar,5) + addFunction => + if $monitorNewWorld then + sayLooking1(concat('"<----add-chain function found for ", + form2String devaluate addFormDomain,'"<----"),CDR addFunction) + addFunction + nil + +--======================================================= +-- Lookup In Domain (from lookupInAddChain) +--======================================================= +newLookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := addFormDomain.index => + INTEGERP KAR addFormCell => + or/[newLookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if null VECP addFormCell then lazyDomainSet(addFormCell,addFormDomain,index) + lookupInDomainVector(op,sig,addFormDomain.index,dollar) + nil + +--======================================================= +-- Category Default Lookup (from goGet or lookupInAddChain) +--======================================================= +newLookupInCategories(op,sig,dom,dollar) == + slot4 := dom.4 + catVec := CADR slot4 + SIZE catVec = 0 => nil --early exit if no categories + INTEGERP KDR catVec.0 => + newLookupInCategories1(op,sig,dom,dollar) --old style + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + packageVec := QCAR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + for i in 0..MAXINDEX packageVec | + (entry := packageVec.i) and entry ^= 'T repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := catVec.i + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + --VECP infovec => ----new world + true => ----new world + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDDR infovec.3 + endPos := + code+2 > max => SIZE byteVector + opvec.(code+2) + not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil + --numOfArgs := byteVector.(opvec.code) + --numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + ----old world + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true then + sayBrightlyNT '" not in: " + pp (packageForm and devaluate package or entry) + nil + if $monitorNewWorld then + sayLooking1('"candidate default package instantiated: ",success) + success + entry + null package => nil + if $monitorNewWorld then + sayLooking1('"Looking at instantiated package ",package) + res := basicLookup(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +nrunNumArgCheck(num,bytevec,start,finish) == + args := bytevec.start + num = args => true + (start := start + args + 4) = finish => nil + nrunNumArgCheck(num,bytevec,start,finish) + +newLookupInCategories1(op,sig,dom,dollar) == + $lookupDefaults : local := nil + if $monitorNewWorld = true then sayBrightly concat('"----->", + form2String devaluate dom,'"-----> searching default packages for ",op) + predvec := dom.3 + slot4 := dom.4 + packageVec := CAR slot4 + catVec := CAR QCDR slot4 +--the next three lines can go away with new category world + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + for i in 0..MAXINDEX packageVec | (entry := ELT(packageVec,i)) + and (VECP entry or (predIndex := CDR (node := ELT(catVec,i))) and + (EQ(predIndex,0) or testBitVector(predvec,predIndex))) repeat + package := + VECP entry => + if $monitorNewWorld then + sayLooking1('"already instantiated cat package",entry) + entry + IDENTP entry => + cat := QCAR node + packageForm := nil + if not GETL(entry,'LOADED) then loadLib entry + infovec := GETL(entry,'infovec) + success := + VECP infovec => + opvec := infovec.1 + max := MAXINDEX opvec + code := getOpCode(op,opvec,max) + null code => nil + byteVector := CDDR infovec.3 + numOfArgs := byteVector.(opvec.code) + numOfArgs ^= #(QCDR sig) => nil + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + table := HGET($Slot1DataBase,entry) or systemError nil + (u := LASSQ(op,table)) + and (v := or/[rest x for x in u | #sig = #x.0]) => + packageForm := [entry,'$,:CDR cat] + package := evalSlotDomain(packageForm,dom) + packageVec.i := package + package + nil + null success => + if $monitorNewWorld = true then + sayBrightlyNT '" not in: " + pp (packageForm and devaluate package or entry) + nil + if $monitorNewWorld then + sayLooking1('"candidate default package instantiated: ",success) + success + entry + null package => nil + if $monitorNewWorld then + sayLooking1('"Looking at instantiated package ",package) + res := lookupInDomainVector(op,sig,package,dollar) => + if $monitorNewWorld = true then + sayBrightly '"candidate default package succeeds" + return res + if $monitorNewWorld = true then + sayBrightly '"candidate fails -- continuing to search categories" + nil + +--======================================================= +-- Instantiate Default Package if Signature Matches +--======================================================= + +getNewDefaultPackage(op,sig,infovec,dom,dollar) == + hohohoho() + opvec := infovec . 1 + numvec := CDDR infovec . 3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + numArgs := QSDIFFERENCE(#sig,1) + success := nil + while finish > start repeat + PROGN + i := start + numArgs ^= (numTableArgs :=numvec.i) => nil + newCompareSigCheaply(sig,numvec,(i := QSPLUS(i,2))) => + return (success := true) + start := QSPLUS(start,QSPLUS(numTableArgs,4)) + null success => nil + defaultPackage := cacheCategoryPackage(packageVec,catVec,i) + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +newCompareSig(sig, numvec, index, dollar, domain) == + k := index + null (target := first sig) + or lazyMatchArg(target,numvec.k,dollar,domain) => + and/[lazyMatchArg(s,numvec.(k := i),dollar,domain) + for s in rest sig for i in (index+1)..] => numvec.(QSINC1 k) + nil + nil + +--======================================================= +-- Compare Signature to One Derived from Table +--======================================================= +lazyMatchArg(s,a,dollar,domain) == lazyMatchArg2(s,a,dollar,domain,true) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +lazyMatchArg2(s,a,dollar,domain,typeFlag) == + if s = '$ then +-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup + s := devaluate dollar -- calls from HasCategory can have $s + INTEGERP a => + not typeFlag => s = domain.a + a = 6 and $isDefaultingPackage => s = devaluate dollar + VECP (d := domainVal(dollar,domain,a)) => + s = d.0 => true + domainArg := ($isDefaultingPackage => domain.6.0; domain.0) + KAR s = QCAR d.0 and lazyMatchArgDollarCheck(s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + lazyMatch(s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + STRINGP a => + s is ['QUOTE,y] and PNAME y = a + IDENTP s and PNAME s = a + atom a => a = s + op := opOf a + op = 'NRTEVAL => s = nrtEval(CADR a,domain) + op = 'QUOTE => s = CADR a + lazyMatch(s,a,dollar,domain) + --above line is temporarily necessary until system is compiled 8/15/90 +--s = a + +lazyMatch(source,lazyt,dollar,domain) == + lazyt is [op,:argl] and null atom source and op=CAR source + and #(sargl := CDR source) = #argl => + MEMQ(op,'(Record Union)) and first argl is [":",:.] => + and/[stag = atag and lazyMatchArg(s,a,dollar,domain) + for [.,stag,s] in sargl for [.,atag,a] in argl] + MEMQ(op,'(Union Mapping QUOTE)) => + and/[lazyMatchArg(s,a,dollar,domain) for s in sargl for a in argl] + coSig := GETDATABASE(op,'COSIG) + NULL coSig => error ["bad Constructor op", op] + and/[lazyMatchArg2(s,a,dollar,domain,flag) + for s in sargl for a in argl for flag in rest coSig] + STRINGP source and lazyt is ['QUOTE,=source] => true + NUMBERP source => + lazyt is ['_#, slotNum] => source = #(domain.slotNum) + lazyt is ['call,'LENGTH, slotNum] => source = #(domain.slotNum) + nil + source is ['construct,:l] => l = lazyt + -- A hideous hack on the same lines as the previous four lines JHD/MCD + nil + + +lazyMatchArgDollarCheck(s,d,dollarName,domainName) == + #s ^= #d => nil + scoSig := GETDATABASE(opOf s,'COSIG) or return nil + if MEMQ(opOf s, '(Union Mapping Record)) then + scoSig := [true for x in s] + and/[fn for x in rest s for arg in rest d for xt in rest scoSig] where + fn == + x = arg => true + x is ['elt,someDomain,opname] => lookupInDomainByName(opname,evalDomain someDomain,arg) + x = '$ and (arg = dollarName or arg = domainName) => true + x = dollarName and arg = domainName => true + ATOM x or ATOM arg => false + xt and CAR x = CAR arg => + lazyMatchArgDollarCheck(x,arg,dollarName,domainName) + false + +lookupInDomainByName(op,domain,arg) == + atom arg => nil + opvec := domain . 1 . 2 + numvec := getDomainByteVector domain + predvec := domain.3 + max := MAXINDEX opvec + k := getOpCode(op,opvec,max) or return nil + maxIndex := MAXINDEX numvec + start := ELT(opvec,k) + finish := + QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + maxIndex + if QSGREATERP(finish,maxIndex) then systemError '"limit too large" + success := false + while finish > start repeat + i := start + numberOfArgs :=numvec.i + predIndex := numvec.(i := QSADD1 i) + NE(predIndex,0) and null testBitVector(predvec,predIndex) => nil + slotIndex := numvec.(i + 2 + numberOfArgs) + newStart := QSPLUS(start,QSPLUS(numberOfArgs,4)) + slot := domain.slotIndex + null atom slot and EQ(CAR slot,CAR arg) and EQ(CDR slot,CDR arg) => return (success := true) + start := QSPLUS(start,QSPLUS(numberOfArgs,4)) + success + +--======================================================= +-- Expand Signature from Encoded Slot Form +--======================================================= +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandGoGetTypeSlot(slot,dollar,domain) == + newExpandTypeSlot(slot,domain,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandTypeSlot(slot, dollar, domain) == +--> returns domain form for dollar.slot + newExpandLocalType(domainVal(dollar, domain, slot), dollar,domain) + + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalTypeForm([functorName,:argl],dollar,domain) == + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] + for [.,tag,dom] in argl]] + MEMQ(functorName, '(Union Mapping)) => + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + functorName = 'QUOTE => [functorName,:argl] + coSig := GETDATABASE(functorName,'COSIG) + NULL coSig => error ["bad functorName", functorName] + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) + for a in argl for flag in rest coSig]] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == + u = '$ => dollar.0 -------eliminate this as $ is rep by 0 + INTEGERP u => + typeFlag => newExpandTypeSlot(u, dollar,domain) + domain.u + u is ['NRTEVAL,y] => nrtEval(y,domain) + u is ['QUOTE,y] => y + atom u => u --can be first, rest, etc. + newExpandLocalTypeForm(u,dollar,domain) + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +nrtEval(expr,dom) == + $:fluid := dom + eval expr + +domainVal(dollar,domain,index) == +--returns a domain or a lazy slot + index = 0 => dollar + index = 2 => domain + domain.index + + +--======================================================= +-- Convert Lazy Domain to Domain Form +--======================================================= + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lazyDomainSet(lazyForm,thisDomain,slot) == + form := + lazyForm is [vec,.,:u] and VECP vec => u --old style + lazyForm --new style + slotDomain := evalSlotDomain(form,thisDomain) + if $monitorNewWorld then + sayLooking1(concat(form2String devaluate thisDomain, + '" activating lazy slot ",slot,'": "),slotDomain) + name := CAR form + SETELT(thisDomain,slot,slotDomain) + +--======================================================= +-- HasCategory/Attribute +--======================================================= +-- PLEASE NOTE: This function has the rather charming side-effect that +-- e.g. it works if domform is an Aldor Category. This is being used +-- by extendscategoryForm in c-util to allow Aldor domains to be used +-- in spad code. Please do not break this! An example is the use of +-- Interval (an Aldor domain) by SIGNEF in limitps.spad. MCD. +newHasTest(domform,catOrAtt) == + domform is [dom,:.] and dom in '(Union Record Mapping Enumeration) => + ofCategory(domform, catOrAtt) + catOrAtt = '(Type) => true + GETDATABASE(opOf domform, 'ASHARP?) => fn(domform,catOrAtt) where + -- atom (infovec := getInfovec opOf domform) => fn(domform,catOrAtt) where + fn(a,b) == + categoryForm?(a) => assoc(b, ancestorsOf(a, nil)) + isPartialMode a => throwKeyedMsg("S2IS0025",NIL) + b is ["SIGNATURE",:opSig] => + HasSignature(evalDomain a,opSig) + b is ["ATTRIBUTE",attr] => HasAttribute(evalDomain a,attr) + hasCaty(a,b,NIL) ^= 'failed + HasCategory(evalDomain a,b) => true -- for asharp domains: must return Boolean + op := opOf catOrAtt + isAtom := atom catOrAtt + null isAtom and op = 'Join => + and/[newHasTest(domform,x) for x in rest catOrAtt] +-- we will refuse to say yes for 'Cat has Cat' +--GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => throwKeyedMsg("S2IS0025",NIL) +-- on second thoughts we won't! + GETDATABASE(opOf domform,'CONSTRUCTORKIND) = 'category => + domform = catOrAtt => 'T + for [aCat,:cond] in [:ancestorsOf(domform,NIL),:SUBLISLIS (rest domform,$FormalMapVariableList,GETDATABASE(opOf domform,'ATTRIBUTES))] | aCat = catOrAtt repeat + return evalCond cond where + evalCond x == + ATOM x => x + [pred,:l] := x + pred = 'has => + l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2) + l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1) + newHasTest(first l ,first rest l) + pred = 'OR => or/[evalCond i for i in l] + pred = 'AND => and/[evalCond i for i in l] + x + null isAtom and constructor? op => + domain := eval mkEvalable domform + newHasCategory(domain,catOrAtt) + newHasAttribute(eval mkEvalable domform,catOrAtt) + +lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4 + n : FIXNUM := MAXINDEX catvec + xop := CAR x + or/[ELT(auxvec,i) for i in 0..n | + xop = CAR (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)] + +lazyMatchAssocV1(x,vec,domain) == --old style slot4 + n : FIXNUM := MAXINDEX vec + xop := CAR x + or/[QCDR QVELT(vec,i) for i in 0..n | + xop = CAR (lazyt := CAR QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)] + +--newHasAttribute(domain,attrib) == +-- predIndex := LASSOC(attrib,domain.2) => +-- EQ(predIndex,0) => true +-- predvec := domain.3 +-- testBitVector(predvec,predIndex) +-- false + +--======================================================= +-- Utility Functions +--======================================================= + +sayLooking(prefix,op,sig,dom) == + $monitorNewWorld := false + dollar := devaluate dom + atom dollar or VECP dollar or or/[VECP x for x in dollar] => systemError nil + sayBrightly + concat(prefix,formatOpSignature(op,sig),bright '"from ",form2String dollar) + $monitorNewWorld := true + +sayLooking1(prefix,dom) == + $monitorNewWorld := false + dollar := + VECP dom => devaluate dom + devaluateList dom + sayBrightly concat(prefix,form2String dollar) + $monitorNewWorld := true + +cc() == -- don't remove this function + clearConstructorCaches() + clearClams() +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot deleted file mode 100644 index 379b511a..00000000 --- a/src/interp/nrungo.boot +++ /dev/null @@ -1,395 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---======================================================= --- Lookup From Interpreter ---======================================================= - -NRTevalDomain form == - form is ['SETELT,:.] => eval form - evalDomain form - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -compiledLookup(op,sig,dollar) == ---called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, --- getFunctionFromDomain, optDeltaEntry, retractByFunction - if not VECP dollar then dollar := NRTevalDomain dollar - basicLookup(op,sig,dollar,dollar) - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -basicLookup(op,sig,domain,dollar) == - domain.1 is ['lookupInDomain,:.] => lookupInDomainVector(op,sig,domain,dollar) - ----------new world code follows------------ - $lookupDefaults : local := nil -- new world - u := lookupInDomainVector(op,sig,domain,dollar) => u - $lookupDefaults := true - lookupInDomainVector(op,sig,domain,dollar) - -compiledLookupCheck(op,sig,dollar) == - fn := compiledLookup(op,sig,dollar) - - -- NEW COMPILER COMPATIBILITY ON - - if (fn = nil) and (op = "^") then - fn := compiledLookup("**",sig,dollar) - else if (fn = nil) and (op = "**") then - fn := compiledLookup("^",sig,dollar) - - -- NEW COMPILER COMPATIBILITY OFF - - fn = nil => - keyedSystemError("S2NR0001",[op,formatSignature sig,dollar.0]) - fn - ---======================================================= --- Lookup From Compiled Code ---======================================================= -goGet(:l) == - [:arglist,env] := l - arglist is ['goGet,:.] => stop() - [[.,[op,initSig,:code]],thisDomain] := env - domainSlot := QSQUOTIENT(code,8192) - code1 := QSREMAINDER(code,8192) - if QSODDP code1 then isConstant := true - code2 := QSQUOTIENT(code1,2) - if QSODDP code2 then explicitLookupDomainIfTrue := true - index := QSQUOTIENT(code2,2) - kind := (isConstant = true => 'CONST; 'ELT) - sig := [NRTreplaceLocalTypes(s,thisDomain) for s in initSig] - sig := substDomainArgs(thisDomain,sig) - lookupDomain := - domainSlot = 0 => thisDomain - thisDomain.domainSlot -- where we look for the operation - if PAIRP lookupDomain then lookupDomain := NRTevalDomain lookupDomain - dollar := -- what matches $ in signatures - explicitLookupDomainIfTrue => lookupDomain - thisDomain - if PAIRP dollar then dollar := NRTevalDomain dollar - fn:= basicLookup(op,sig,lookupDomain,dollar) - fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) - val:= APPLY(first fn,[:arglist,rest fn]) - SETELT(thisDomain,index,fn) - val - -NRTreplaceLocalTypes(t,dom) == - atom t => - not INTEGERP t => t - t:= dom.t - if PAIRP t then t:= NRTevalDomain t - t.0 - MEMQ(CAR t,'(Mapping Union Record _:)) => - [CAR t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]] - t - -substDomainArgs(domain,object) == - form := devaluate domain - SUBLISLIS([form,:rest form],["$$",:$FormalMapVariableList],object) - ---======================================================= --- Lookup Function in Slot 1 (via SPADCALL) ---======================================================= -domainTableLookup(op,sig,dollar,env) == lookupInTable(op,sig,dollar,env) -lookupInTable(op,sig,dollar,[domain,table]) == - EQ(table,'derived) => lookupInAddChain(op,sig,domain,dollar) - success := false - someMatch := false - while not success for [sig1,:code] in LASSQ(op,table) repeat - success := - null compareSig(sig,sig1,dollar.0,domain) => false - code is ['subsumed,a] => - subsumptionSig := - EQSUBSTLIST(rest(domain.0),$FormalMapVariableList,a) - someMatch:=true - false - predIndex := QSQUOTIENT(code,8192) - predIndex ^= 0 and null lookupPred($predVector.predIndex,dollar,domain) - => false - loc := QSQUOTIENT(QSREMAINDER(code,8192),2) - loc = 0 => - someMatch := true - nil - slot := domain.loc - EQCAR(slot,'goGet) => - lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") - lookupInAddChain(op,sig,domain,dollar) or 'failed - NULL slot => - lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") - lookupInAddChain(op,sig,domain,dollar) or 'failed - lookupDisplay(op,sig,domain,'" !! found in NEW table!!") - slot - NE(success,'failed) and success => success - subsumptionSig and (u:= SPADCALL(op,subsumptionSig,dollar,domain.1)) => u - someMatch => lookupInAddChain(op,sig,domain,dollar) - nil - ---======================================================= --- Lookup Addlist (from lookupInDomainTable or lookupInDomain) ---======================================================= -lookupInAddChain(op,sig,addFormDomain,dollar) == - addFunction:=lookupInDomain(op,sig,addFormDomain,dollar,5) - defaultingFunction addFunction => - lookupInCategories(op,sig,addFormDomain,dollar) or addFunction - addFunction or lookupInCategories(op,sig,addFormDomain,dollar) - - -defaultingFunction op == - not(op is [.,:dom]) => false - not VECP dom => false - not (#dom > 0) => false - not (dom.0 is [packageName,:.]) => false - not IDENTP packageName => false - pname := PNAME packageName - pname.(MAXINDEX pname) = char "&" - ---======================================================= --- Lookup In Domain (from lookupInAddChain) ---======================================================= -lookupInDomain(op,sig,addFormDomain,dollar,index) == - addFormCell := addFormDomain.index => - INTEGERP KAR addFormCell => - or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] - if null VECP addFormCell then addFormCell := eval addFormCell - lookupInDomainVector(op,sig,addFormCell,dollar) - nil - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -lookupInDomainVector(op,sig,domain,dollar) == - slot1 := domain.1 - SPADCALL(op,sig,dollar,slot1) - ---======================================================= --- Category Default Lookup (from goGet or lookupInAddChain) ---======================================================= -lookupInCategories(op,sig,dom,dollar) == - catformList := dom.4.0 - varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] - valueList := [MKQ val for val in valueList] - nsig := MSUBST(dom.0,dollar.0,sig) - r := or/[lookupInDomainVector(op,nsig, - eval EQSUBSTLIST(valueList,varList,catform),dollar) - for catform in catformList | pred] where pred == - (table := HGET($Slot1DataBase,first catform)) and - (u := LASSQ(op,table)) --compare without checking predicates - and (v := or/[rest x for x in u | #sig = #x.0]) - -- following lines commented out because compareSig needs domain - -- and (v := or/[rest x for x in u | - -- compareSig(sig,x.0,dollar.0, catform)]) - r or lookupDisplay(op,sig,'"category defaults",'"-- not found") - ---======================================================= --- Predicates ---======================================================= -lookupPred(pred,dollar,domain) == - pred = true => true - pred = 'asserted => false - pred is ['AND,:pl] or pred is ['and,:pl] => - and/[lookupPred(p,dollar,domain) for p in pl] - pred is ['OR,:pl] or pred is ['or,:pl] => - or/[lookupPred(p,dollar,domain) for p in pl] - pred is ['NOT,p] or pred is ['not,p] => not lookupPred(p,dollar,domain) - pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) - pred is ['has,a,b] => - VECP a => - keyedSystemError("S2GE0016",['"lookupPred", - '"vector as first argument to has"]) - a := eval mkEvalable substDollarArgs(dollar,domain,a) - b := substDollarArgs(dollar,domain,b) - HasCategory(a,b) - keyedSystemError("S2NR0002",[pred]) - -substDollarArgs(dollar,domain,object) == - form := devaluate domain - SUBLISLIS([devaluate dollar,:rest form], - ["$",:$FormalMapVariableList],object) - -compareSig(sig,tableSig,dollar,domain) == - not (#sig = #tableSig) => false - null (target := first sig) - or lazyCompareSigEqual(target,first tableSig,dollar,domain) => - and/[lazyCompareSigEqual(s,t,dollar,domain) - for s in rest sig for t in rest tableSig] - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -lazyCompareSigEqual(s,tslot,dollar,domain) == - tslot = '$ => s = devaluate dollar --needed for browser - INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => - lazyt is [.,.,.,[.,item,.]] and - item is [.,[functorName,:.]] and functorName = CAR s => - compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) - nil - compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) - - -compareSigEqual(s,t,dollar,domain) == - EQUAL(s,t) => true - ATOM t => - u := - EQ(t,'$) => dollar - isSharpVar t => - VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList)) - ELT(rest domain,POSN1(t,$FormalMapVariableList)) - STRINGP t and IDENTP s => (s := PNAME s; t) - nil - s = '$ => compareSigEqual(dollar,u,dollar,domain) - u => compareSigEqual(s,u,dollar,domain) - EQUAL(s,u) - EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain) - ATOM s => nil - #s ^= #t => nil - match := true - for u in s for v in t repeat - not compareSigEqual(u,v,dollar,domain) => return(match:=false) - match - ------------------------Compiler for Interpreter--------------------------------- -NRTcompileEvalForm(opName,sigTail,dcVector) == - u := NRTcompiledLookup(opName,sigTail,dcVector) - not ($insideCompileBodyIfTrue = true) => MKQ u - k := NRTgetMinivectorIndex(u,opName,sigTail,dcVector) - ['ELT,"$$$",k] --$$$ denotes minivector - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -NRTcompiledLookup(op,sig,dom) == - if CONTAINED('_#,sig) then - sig := [NRTtypeHack t for t in sig] - compiledLookupCheck(op,sig,dom) - -NRTtypeHack t == - ATOM t => t - CAR t = '_# => # CADR t - [CAR t,:[NRTtypeHack tt for tt in CDR t]] - -NRTgetMinivectorIndex(u,op,sig,domVector) == - s := # $minivector - k := or/[k for k in 0..(s-1) - for x in $minivector | EQ(x,u)] => k - $minivector := [:$minivector,u] - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,[op,sig,devaluate domVector]] --- pp '"-- minivectorCode -->" --- pp $minivectorCode - s - -NRTisRecurrenceRelation(op,body,minivectorName) == - -- returns [body p1 p2 ... pk] for a k-term recurrence relation - -- where the n-th term is computed using the (n-1)st,...,(n-k)th - -- whose values are initially computed using the expressions - -- p1,...,pk respectively; body has #2,#3,... in place of - -- f(k-1),f(k-2),... - - body isnt ['COND,:pcl] => false - -- body should have a conditional expression which - -- gives k boundary values, one general term plus possibly an - -- "out of domain" condition ---pcl is [:.,[ ''T,:mess]] and not (CONTAINED('throwMessage,mess) or --- CONTAINED('throwKeyedMsg,mess)) => NIL - pcl := [x for x in pcl | not (x is [''T,:mess] and - (CONTAINED('throwMessage,mess) or - CONTAINED('throwKeyedMsg,mess)))] - integer := EVALFUN $Integer - iequalSlot:=compiledLookupCheck("=",'((Boolean) $ $),integer) - lesspSlot:=compiledLookupCheck("<",'((Boolean) $ $),integer) - bf := '(Boolean) - notpSlot:= compiledLookupCheck("not",'((Boolean)(Boolean)),EVALFUN bf) - for [p,c] in pcl repeat - p is ['SPADCALL,sharpVar,n1,['ELT,=minivectorName,slot]] - and EQ(iequalSlot,$minivector.slot) => - initList:= [[n1,:c],:initList] - sharpList := insert(sharpVar,sharpList) - n:=n1 - miscList:= [[p,c],:miscList] - miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] => - return false - --first general term starts at n - - --Must have at least one special value; insist that they be consecutive - null initList => false - specialValues:= MSORT ASSOCLEFT initList - or/[null INTEGERP n for n in specialValues] => false - minIndex:= "MIN"/specialValues - not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) => - sayKeyedMsg("S2IX0005", - ["append"/[['" ",sv] for sv in specialValues]]) - return nil - - --Determine the order k of the recurrence and index n of first general term - k:= #specialValues - n:= k+minIndex - --Check general predicate - predOk := - generalPred is '(QUOTE T) => true - generalPred is ['SPADCALL,m,=sharpArg,['ELT,=minivectorName,slot]] - and EQ(lesspSlot,$minivector.slot)=> m+1 - generalPred is ['SPADCALL,['SPADCALL,=sharpArg,m, - ['ELT,=minivectorName,slot]], ['ELT,=minivectorName,notSlot]] - and EQ(lesspSlot,$minivector.slot) - and EQ(notpSlot,$minivector.notSlot) => m - generalPred is ['NOT,['SPADCALL,=sharpArg,m,['ELT,=minivectorName, =lesspSlot]]] - and EQ(lesspSlot,$minivector.slot) => m - return nil - INTEGERP predOk and predOk ^= n => - sayKeyedMsg("S2IX0006",[n,m]) - return nil - - --Check general term for references to just the k previous values - diffCell:=compiledLookupCheck("-",'($ $ $),integer) - diffSlot := or/[i for i in 0.. for x in $minivector | EQ(x,diffCell)] - or return nil - --Check general term for references to just the k previous values - sharpPosition := PARSE_-INTEGER SUBSTRING(sharpArg,1,nil) - al:= mkDiffAssoc(op,generalTerm,k,sharpPosition,sharpArg,diffSlot,minivectorName) - null al => false - '$failed in al => false - body:= generalTerm - for [a,:b] in al repeat - body:= substitute(b,a,body) - result:= [body,sharpArg,n-1,:NREVERSE [LASSOC(i,initList) or - systemErrorHere('"NRTisRecurrenceRelation") - for i in minIndex..(n-1)]] - -mkDiffAssoc(op,body,k,sharpPosition,sharpArg,diffSlot,vecname) == - -- returns alist which should not have any entries = $failed - -- form substitution list of the form: - -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...) - -- but also checking that all difference values lie in 1..k - atom body => nil - body is ['COND,:pl] => - "union"/[mkDiffAssoc(op,c,k,sharpPosition,sharpArg,diffSlot,vecname) for [p,c] in pl] - body is [fn,:argl] => - (fn = op) and argl.(sharpPosition-1) is - ['SPADCALL,=sharpArg,n,['ELT,=vecname,=diffSlot]] => - NUMP n and n > 0 and n <= k => - [[body,:$TriangleVariableList.n]] - ['$failed] - "union"/[mkDiffAssoc(op,x,k,sharpPosition,sharpArg,diffSlot,vecname) for x in argl] - systemErrorHere '"mkDiffAssoc" diff --git a/src/interp/nrungo.boot.pamphlet b/src/interp/nrungo.boot.pamphlet new file mode 100644 index 00000000..72a8e153 --- /dev/null +++ b/src/interp/nrungo.boot.pamphlet @@ -0,0 +1,417 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nrungo.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--======================================================= +-- Lookup From Interpreter +--======================================================= + +NRTevalDomain form == + form is ['SETELT,:.] => eval form + evalDomain form + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +compiledLookup(op,sig,dollar) == +--called by coerceByFunction, evalForm, findEqualFun, findUniqueOpInDomain, +-- getFunctionFromDomain, optDeltaEntry, retractByFunction + if not VECP dollar then dollar := NRTevalDomain dollar + basicLookup(op,sig,dollar,dollar) + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +basicLookup(op,sig,domain,dollar) == + domain.1 is ['lookupInDomain,:.] => lookupInDomainVector(op,sig,domain,dollar) + ----------new world code follows------------ + $lookupDefaults : local := nil -- new world + u := lookupInDomainVector(op,sig,domain,dollar) => u + $lookupDefaults := true + lookupInDomainVector(op,sig,domain,dollar) + +compiledLookupCheck(op,sig,dollar) == + fn := compiledLookup(op,sig,dollar) + + -- NEW COMPILER COMPATIBILITY ON + + if (fn = nil) and (op = "^") then + fn := compiledLookup("**",sig,dollar) + else if (fn = nil) and (op = "**") then + fn := compiledLookup("^",sig,dollar) + + -- NEW COMPILER COMPATIBILITY OFF + + fn = nil => + keyedSystemError("S2NR0001",[op,formatSignature sig,dollar.0]) + fn + +--======================================================= +-- Lookup From Compiled Code +--======================================================= +goGet(:l) == + [:arglist,env] := l + arglist is ['goGet,:.] => stop() + [[.,[op,initSig,:code]],thisDomain] := env + domainSlot := QSQUOTIENT(code,8192) + code1 := QSREMAINDER(code,8192) + if QSODDP code1 then isConstant := true + code2 := QSQUOTIENT(code1,2) + if QSODDP code2 then explicitLookupDomainIfTrue := true + index := QSQUOTIENT(code2,2) + kind := (isConstant = true => 'CONST; 'ELT) + sig := [NRTreplaceLocalTypes(s,thisDomain) for s in initSig] + sig := substDomainArgs(thisDomain,sig) + lookupDomain := + domainSlot = 0 => thisDomain + thisDomain.domainSlot -- where we look for the operation + if PAIRP lookupDomain then lookupDomain := NRTevalDomain lookupDomain + dollar := -- what matches $ in signatures + explicitLookupDomainIfTrue => lookupDomain + thisDomain + if PAIRP dollar then dollar := NRTevalDomain dollar + fn:= basicLookup(op,sig,lookupDomain,dollar) + fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0]) + val:= APPLY(first fn,[:arglist,rest fn]) + SETELT(thisDomain,index,fn) + val + +NRTreplaceLocalTypes(t,dom) == + atom t => + not INTEGERP t => t + t:= dom.t + if PAIRP t then t:= NRTevalDomain t + t.0 + MEMQ(CAR t,'(Mapping Union Record _:)) => + [CAR t,:[NRTreplaceLocalTypes(x,dom) for x in rest t]] + t + +substDomainArgs(domain,object) == + form := devaluate domain + SUBLISLIS([form,:rest form],["$$",:$FormalMapVariableList],object) + +--======================================================= +-- Lookup Function in Slot 1 (via SPADCALL) +--======================================================= +domainTableLookup(op,sig,dollar,env) == lookupInTable(op,sig,dollar,env) +lookupInTable(op,sig,dollar,[domain,table]) == + EQ(table,'derived) => lookupInAddChain(op,sig,domain,dollar) + success := false + someMatch := false + while not success for [sig1,:code] in LASSQ(op,table) repeat + success := + null compareSig(sig,sig1,dollar.0,domain) => false + code is ['subsumed,a] => + subsumptionSig := + EQSUBSTLIST(rest(domain.0),$FormalMapVariableList,a) + someMatch:=true + false + predIndex := QSQUOTIENT(code,8192) + predIndex ^= 0 and null lookupPred($predVector.predIndex,dollar,domain) + => false + loc := QSQUOTIENT(QSREMAINDER(code,8192),2) + loc = 0 => + someMatch := true + nil + slot := domain.loc + EQCAR(slot,'goGet) => + lookupDisplay(op,sig,domain,'" !! goGet found, will ignore") + lookupInAddChain(op,sig,domain,dollar) or 'failed + NULL slot => + lookupDisplay(op,sig,domain,'" !! null slot entry, continuing") + lookupInAddChain(op,sig,domain,dollar) or 'failed + lookupDisplay(op,sig,domain,'" !! found in NEW table!!") + slot + NE(success,'failed) and success => success + subsumptionSig and (u:= SPADCALL(op,subsumptionSig,dollar,domain.1)) => u + someMatch => lookupInAddChain(op,sig,domain,dollar) + nil + +--======================================================= +-- Lookup Addlist (from lookupInDomainTable or lookupInDomain) +--======================================================= +lookupInAddChain(op,sig,addFormDomain,dollar) == + addFunction:=lookupInDomain(op,sig,addFormDomain,dollar,5) + defaultingFunction addFunction => + lookupInCategories(op,sig,addFormDomain,dollar) or addFunction + addFunction or lookupInCategories(op,sig,addFormDomain,dollar) + + +defaultingFunction op == + not(op is [.,:dom]) => false + not VECP dom => false + not (#dom > 0) => false + not (dom.0 is [packageName,:.]) => false + not IDENTP packageName => false + pname := PNAME packageName + pname.(MAXINDEX pname) = char "&" + +--======================================================= +-- Lookup In Domain (from lookupInAddChain) +--======================================================= +lookupInDomain(op,sig,addFormDomain,dollar,index) == + addFormCell := addFormDomain.index => + INTEGERP KAR addFormCell => + or/[lookupInDomain(op,sig,addFormDomain,dollar,i) for i in addFormCell] + if null VECP addFormCell then addFormCell := eval addFormCell + lookupInDomainVector(op,sig,addFormCell,dollar) + nil + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +lookupInDomainVector(op,sig,domain,dollar) == + slot1 := domain.1 + SPADCALL(op,sig,dollar,slot1) + +--======================================================= +-- Category Default Lookup (from goGet or lookupInAddChain) +--======================================================= +lookupInCategories(op,sig,dom,dollar) == + catformList := dom.4.0 + varList := ['$,:$FormalMapVariableList] + valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [MKQ val for val in valueList] + nsig := MSUBST(dom.0,dollar.0,sig) + r := or/[lookupInDomainVector(op,nsig, + eval EQSUBSTLIST(valueList,varList,catform),dollar) + for catform in catformList | pred] where pred == + (table := HGET($Slot1DataBase,first catform)) and + (u := LASSQ(op,table)) --compare without checking predicates + and (v := or/[rest x for x in u | #sig = #x.0]) + -- following lines commented out because compareSig needs domain + -- and (v := or/[rest x for x in u | + -- compareSig(sig,x.0,dollar.0, catform)]) + r or lookupDisplay(op,sig,'"category defaults",'"-- not found") + +--======================================================= +-- Predicates +--======================================================= +lookupPred(pred,dollar,domain) == + pred = true => true + pred = 'asserted => false + pred is ['AND,:pl] or pred is ['and,:pl] => + and/[lookupPred(p,dollar,domain) for p in pl] + pred is ['OR,:pl] or pred is ['or,:pl] => + or/[lookupPred(p,dollar,domain) for p in pl] + pred is ['NOT,p] or pred is ['not,p] => not lookupPred(p,dollar,domain) + pred is ['is,dom1,dom2] => domainEqual(dom1,dom2) + pred is ['has,a,b] => + VECP a => + keyedSystemError("S2GE0016",['"lookupPred", + '"vector as first argument to has"]) + a := eval mkEvalable substDollarArgs(dollar,domain,a) + b := substDollarArgs(dollar,domain,b) + HasCategory(a,b) + keyedSystemError("S2NR0002",[pred]) + +substDollarArgs(dollar,domain,object) == + form := devaluate domain + SUBLISLIS([devaluate dollar,:rest form], + ["$",:$FormalMapVariableList],object) + +compareSig(sig,tableSig,dollar,domain) == + not (#sig = #tableSig) => false + null (target := first sig) + or lazyCompareSigEqual(target,first tableSig,dollar,domain) => + and/[lazyCompareSigEqual(s,t,dollar,domain) + for s in rest sig for t in rest tableSig] + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +lazyCompareSigEqual(s,tslot,dollar,domain) == + tslot = '$ => s = devaluate dollar --needed for browser + INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => + lazyt is [.,.,.,[.,item,.]] and + item is [.,[functorName,:.]] and functorName = CAR s => + compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) + nil + compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) + + +compareSigEqual(s,t,dollar,domain) == + EQUAL(s,t) => true + ATOM t => + u := + EQ(t,'$) => dollar + isSharpVar t => + VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList)) + ELT(rest domain,POSN1(t,$FormalMapVariableList)) + STRINGP t and IDENTP s => (s := PNAME s; t) + nil + s = '$ => compareSigEqual(dollar,u,dollar,domain) + u => compareSigEqual(s,u,dollar,domain) + EQUAL(s,u) + EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain) + ATOM s => nil + #s ^= #t => nil + match := true + for u in s for v in t repeat + not compareSigEqual(u,v,dollar,domain) => return(match:=false) + match + +-----------------------Compiler for Interpreter--------------------------------- +NRTcompileEvalForm(opName,sigTail,dcVector) == + u := NRTcompiledLookup(opName,sigTail,dcVector) + not ($insideCompileBodyIfTrue = true) => MKQ u + k := NRTgetMinivectorIndex(u,opName,sigTail,dcVector) + ['ELT,"$$$",k] --$$$ denotes minivector + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +NRTcompiledLookup(op,sig,dom) == + if CONTAINED('_#,sig) then + sig := [NRTtypeHack t for t in sig] + compiledLookupCheck(op,sig,dom) + +NRTtypeHack t == + ATOM t => t + CAR t = '_# => # CADR t + [CAR t,:[NRTtypeHack tt for tt in CDR t]] + +NRTgetMinivectorIndex(u,op,sig,domVector) == + s := # $minivector + k := or/[k for k in 0..(s-1) + for x in $minivector | EQ(x,u)] => k + $minivector := [:$minivector,u] + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,[op,sig,devaluate domVector]] +-- pp '"-- minivectorCode -->" +-- pp $minivectorCode + s + +NRTisRecurrenceRelation(op,body,minivectorName) == + -- returns [body p1 p2 ... pk] for a k-term recurrence relation + -- where the n-th term is computed using the (n-1)st,...,(n-k)th + -- whose values are initially computed using the expressions + -- p1,...,pk respectively; body has #2,#3,... in place of + -- f(k-1),f(k-2),... + + body isnt ['COND,:pcl] => false + -- body should have a conditional expression which + -- gives k boundary values, one general term plus possibly an + -- "out of domain" condition +--pcl is [:.,[ ''T,:mess]] and not (CONTAINED('throwMessage,mess) or +-- CONTAINED('throwKeyedMsg,mess)) => NIL + pcl := [x for x in pcl | not (x is [''T,:mess] and + (CONTAINED('throwMessage,mess) or + CONTAINED('throwKeyedMsg,mess)))] + integer := EVALFUN $Integer + iequalSlot:=compiledLookupCheck("=",'((Boolean) $ $),integer) + lesspSlot:=compiledLookupCheck("<",'((Boolean) $ $),integer) + bf := '(Boolean) + notpSlot:= compiledLookupCheck("not",'((Boolean)(Boolean)),EVALFUN bf) + for [p,c] in pcl repeat + p is ['SPADCALL,sharpVar,n1,['ELT,=minivectorName,slot]] + and EQ(iequalSlot,$minivector.slot) => + initList:= [[n1,:c],:initList] + sharpList := insert(sharpVar,sharpList) + n:=n1 + miscList:= [[p,c],:miscList] + miscList isnt [[generalPred,generalTerm]] or sharpList isnt [sharpArg] => + return false + --first general term starts at n + + --Must have at least one special value; insist that they be consecutive + null initList => false + specialValues:= MSORT ASSOCLEFT initList + or/[null INTEGERP n for n in specialValues] => false + minIndex:= "MIN"/specialValues + not (and/[i=x for i in minIndex..(minIndex+n-1) for x in specialValues]) => + sayKeyedMsg("S2IX0005", + ["append"/[['" ",sv] for sv in specialValues]]) + return nil + + --Determine the order k of the recurrence and index n of first general term + k:= #specialValues + n:= k+minIndex + --Check general predicate + predOk := + generalPred is '(QUOTE T) => true + generalPred is ['SPADCALL,m,=sharpArg,['ELT,=minivectorName,slot]] + and EQ(lesspSlot,$minivector.slot)=> m+1 + generalPred is ['SPADCALL,['SPADCALL,=sharpArg,m, + ['ELT,=minivectorName,slot]], ['ELT,=minivectorName,notSlot]] + and EQ(lesspSlot,$minivector.slot) + and EQ(notpSlot,$minivector.notSlot) => m + generalPred is ['NOT,['SPADCALL,=sharpArg,m,['ELT,=minivectorName, =lesspSlot]]] + and EQ(lesspSlot,$minivector.slot) => m + return nil + INTEGERP predOk and predOk ^= n => + sayKeyedMsg("S2IX0006",[n,m]) + return nil + + --Check general term for references to just the k previous values + diffCell:=compiledLookupCheck("-",'($ $ $),integer) + diffSlot := or/[i for i in 0.. for x in $minivector | EQ(x,diffCell)] + or return nil + --Check general term for references to just the k previous values + sharpPosition := PARSE_-INTEGER SUBSTRING(sharpArg,1,nil) + al:= mkDiffAssoc(op,generalTerm,k,sharpPosition,sharpArg,diffSlot,minivectorName) + null al => false + '$failed in al => false + body:= generalTerm + for [a,:b] in al repeat + body:= substitute(b,a,body) + result:= [body,sharpArg,n-1,:NREVERSE [LASSOC(i,initList) or + systemErrorHere('"NRTisRecurrenceRelation") + for i in minIndex..(n-1)]] + +mkDiffAssoc(op,body,k,sharpPosition,sharpArg,diffSlot,vecname) == + -- returns alist which should not have any entries = $failed + -- form substitution list of the form: + -- ( ((f (,DIFFERENCE #1 1)) . #2) ((f (,DIFFERENCE #1 2)) . #3) ...) + -- but also checking that all difference values lie in 1..k + atom body => nil + body is ['COND,:pl] => + "union"/[mkDiffAssoc(op,c,k,sharpPosition,sharpArg,diffSlot,vecname) for [p,c] in pl] + body is [fn,:argl] => + (fn = op) and argl.(sharpPosition-1) is + ['SPADCALL,=sharpArg,n,['ELT,=vecname,=diffSlot]] => + NUMP n and n > 0 and n <= k => + [[body,:$TriangleVariableList.n]] + ['$failed] + "union"/[mkDiffAssoc(op,x,k,sharpPosition,sharpArg,diffSlot,vecname) for x in argl] + systemErrorHere '"mkDiffAssoc" +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot deleted file mode 100644 index 7bdba59a..00000000 --- a/src/interp/nrunopt.boot +++ /dev/null @@ -1,903 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---======================================================================= --- Generate Code to Create Infovec ---======================================================================= -getInfovecCode() == ---Function called by compDefineFunctor1 to create infovec at compile time - ['LIST, - MKQ makeDomainTemplate $template, - MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist(), - NRTmakeCategoryAlist(), - MKQ $lookupFunction] - ---======================================================================= --- Generation of Domain Vector Template (Compile Time) ---======================================================================= -makeDomainTemplate vec == ---NOTES: This function is called at compile time to create the template --- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 - newVec := GETREFV SIZE vec - for index in 0..MAXINDEX vec repeat - item := vec.index - null item => nil - newVec.index := - atom item => item - null atom first item => makeGoGetSlot(item,index) - item - $byteVec := "append"/NREVERSE $byteVec - newVec - -makeGoGetSlot(item,index) == ---NOTES: creates byte vec strings for LATCH slots ---these parts of the $byteVec are created first; see also makeCompactDirect - [sig,whereToGo,op,:flag] := item - n := #sig - 1 - newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] - $byteVec := [newcode,:$byteVec] - curAddress := $byteAddress - $byteAddress := $byteAddress + n + 4 - [curAddress,:op] - ---======================================================================= --- Generate OpTable at Compile Time ---======================================================================= ---> called by getInfovecCode (see top of this file) from compDefineFunctor1 -makeCompactDirect u == - $predListLength :local := LENGTH $NRTslot1PredicateList - $byteVecAcc: local := nil - [nam,[addForm,:opList]] := u - --pp opList - d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] - $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] - LIST2VEC ("append"/d) - -makeCompactDirect1(op,items) == ---NOTES: creates byte codes for ops implemented by the domain - curAddress := $byteAddress - $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) - newcodes := - "append"/[u for y in orderBySubsumption items | u := fn y] or return nil - $byteVecAcc := [newcodes,:$byteVecAcc] - curAddress - where fn y == - [sig,:r] := y - r = ['Subsumed] => - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature - --identified by a 0 in slot position - if r is [n,:s] then - slot := - n is [p,:.] => p --the CDR is linenumber of function definition - n - predCode := - s is [pred,:.] => predicateBitIndex pred - 0 - --> drop items which are not present (predCode = -1) - predCode = -1 => return nil - --> drop items with NIL slots if lookup function is incomplete - if null slot then - $lookupFunction = 'lookupIncomplete => return nil - slot := 1 --signals that operation is not present - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] - res - -orderBySubsumption items == - acc := subacc := nil - for x in items repeat - not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] - acc := [x,:acc] - y := z := nil - for [a,b,:.] in subacc | b repeat - --NOTE: b = nil means that the signature a will appear in acc, that this - -- entry is be ignored (e.g. init: -> $ in ULS) - while (u := ASSOC(b,subacc)) repeat b := CADR u - u := ASSOC(b,acc) or systemError nil - if null CADR u then u := [CAR u,1] --mark as missing operation - y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed - z := insert(b,z) --mark a signature as already present - [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming - -makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where ---$isOpPackageName = true only for an exported operation of a default package - fn == - x = '_$_$ => 2 - x = '$ => 0 - NULL INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] --- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages - x - ---======================================================================= --- Instantiation Code (Stuffslots) ---======================================================================= -stuffDomainSlots dollar == - domname := devaluate dollar - infovec := GETL(opOf domname,'infovec) - lookupFunction := getLookupFun infovec - lookupFunction := - lookupFunction = 'lookupIncomplete => function lookupIncomplete - function lookupComplete - template := infovec.0 - if template.5 then stuffSlot(dollar,5,template.5) - for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat - stuffSlot(dollar,i,item) - dollar.1 := LIST(lookupFunction,dollar,infovec.1) - dollar.2 := infovec.2 - proto4 := infovec.3 - dollar.4 := - VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style - bitVector := dollar.3 - predvec := CAR proto4 - packagevec := CADR proto4 - auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn == - null testBitVector(bitVector,predvec.i) => nil - packagevec.i or 'T - [auxvec,:CDDR proto4] - -getLookupFun infovec == - MAXINDEX infovec = 4 => infovec.4 - 'lookupIncomplete - -stuffSlot(dollar,i,item) == - dollar.i := - atom item => [SYMBOL_-FUNCTION item,:dollar] - item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] - item is ['CONS,.,['FUNCALL,a,b]] => - b = '$ => ['makeSpadConstant,eval a,dollar,i] - sayBrightlyNT '"Unexpected constant environment!!" - pp devaluate b - nil --- [dollar,i,:item] --old form --- $isOpPackageName = 'T => SUBST(0,6,item) - item --new form ---======================================================================= --- Generate Slot 2 Attribute Alist ---======================================================================= -NRTgenInitialAttributeAlist attributeList == - --alist has form ((item pred)...) where some items are constructor forms - alist := [x for x in attributeList | -- throw out constructors - null MEMQ(opOf first x,allConstructors())] - $lisplibAttributes := simplifyAttributeAlist - [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] - -simplifyAttributeAlist al == - al is [[a,:b],:r] => - u := [x for x in r | x is [=a,:b]] - null u => [first al,:simplifyAttributeAlist rest al] - pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - s := [x for x in r | x isnt [=a,:b]] - [[a,:pred],:simplifyAttributeAlist s] - nil - -NRTgenFinalAttributeAlist() == - [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] - -predicateBitIndex x == - pn(x,nil) where - pn(x,flag) == - u := simpBool transHasCode x - u = 'T => 0 - u = nil => -1 - p := POSN1(u,$NRTslot1PredicateList) => p + 1 - null flag => pn(predicateBitIndexRemop x,true) - systemError nil - -predicateBitIndexRemop p== ---transform attribute predicates taken out by removeAttributePredicates - p is [op,:argl] and op in '(AND and OR or NOT not) => - simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) - p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) - p - -predicateBitRef x == - x = 'T => 'T - ['testBitVector,'pv_$,predicateBitIndex x] - -makePrefixForm(u,op) == - u := MKPF(u,op) - u = ''T => 'T - u ---======================================================================= --- Generate Slot 3 Predicate Vector ---======================================================================= -makePredicateBitVector pl == --called by NRTbuildFunctor - if $insideCategoryPackageIfTrue = true then - pl := union(pl,$categoryPredicateList) - $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas - for p in removeAttributePredicates pl repeat - pred := simpBool transHasCode p - atom pred => 'skip --skip over T and NIL - if isHasDollarPred pred then - lasts := insert(pred,lasts) - for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) - else - firsts := insert(pred,firsts) - firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) - lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) - firstCode:= - ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] - lastCode := augmentPredCode(# firstPl,lastPl) - $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates - [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 - -augmentPredCode(n,lastPl) == - ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) - delta := 2 ** n - l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); - delta:=2 * delta; u) for x in pl] - -augmentPredVector(dollar,value) == - QSETREFV(dollar,3,value + QVELT(dollar,3)) - -isHasDollarPred pred == - pred is [op,:r] => - MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] - MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ - false - -stripOutNonDollarPreds pred == - pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => - "append"/[stripOutNonDollarPreds x for x in r] - not isHasDollarPred pred => [pred] - nil - -removeAttributePredicates pl == - [fn p for p in pl] where - fn p == - p is [op,:argl] and op in '(AND and OR or NOT not) => - makePrefixForm(fnl argl,op) - p is ['has,'$,['ATTRIBUTE,a]] => - sayBrightlyNT '"Predicate: " - PRINT p - sayBrightlyNT '" replaced by: " - PRINT LASSOC(a,$NRTattributeAlist) - p - fnl p == [fn x for x in p] - -transHasCode x == - atom x => x - op := QCAR x - MEMQ(op,'(HasCategory HasAttribute)) => x - EQ(op,'has) => compHasFormat x - [transHasCode y for y in x] - -mungeAddGensyms(u,gal) == - ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == - atom x => x - g := LASSOC(x,gal) => - n = 0 => ['LET,g,x] - g - [first x,:[fn(y,gal,n + 1) for y in rest x]] - -orderByContainment pl == - null pl or null rest pl => pl - max := first pl - for x in rest pl repeat - if (y := CONTAINED(max,x)) then - if null ASSOC(max,$predGensymAlist) - then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] - else if CONTAINED(x,max) - then if null ASSOC(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] - if y then max := x - [max,:orderByContainment delete(max,pl)] - -buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == - null l => n - n := n + n - if QCAR l then n := n + 1 - fn(rest l,n) - -buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == - null l => acc - if CAR l then acc := acc + n - fn(acc,n + n,rest l) - -testBitVector(vec,i) == ---bit vector indices are always 1 larger than position in vector - EQ(i,0) => true - LOGBITP(i - 1,vec) - -bitsOf n == - n = 0 => 0 - 1 + bitsOf (n/2) - ---======================================================================= --- Generate Slot 4 Constructor Vectors ---======================================================================= ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -NRTmakeCategoryAlist() == - $depthAssocCache: local := MAKE_-HASHTABLE 'ID - pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] - $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] - opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) - newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] - slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) - | (k := predicateBitIndex b) ^= -1] - slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] - sixEtc := [5 + i for i in 1..#$pairlis] - formals := ASSOCRIGHT $pairlis - for x in slot1 repeat RPLACA(x,EQSUBSTLIST(sixEtc,formals,CAR x)) - -----------code to make a new style slot4----------------- - predList := ASSOCRIGHT slot1 --is list of predicate indices - maxPredList := "MAX"/predList - catformvec := ASSOCLEFT slot1 - maxElement := "MAX"/$byteVec - ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], - ['CONS, MKQ LIST2VEC slot0, - ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], - ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] - --NOTE: this is new form: old form satisfies VECP CDDR form - ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -encodeCatform x == - k := NRTassocIndex x => k - atom x or atom rest x => x - [first x,:[encodeCatform y for y in rest x]] - -NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) - -hasDefaultPackage catname == - defname := INTERN STRCONC(catname,'"&") - constructor? defname => defname ---MEMQ(defname,allConstructors()) => defname - nil - - ---======================================================================= --- Generate Category Level Alist ---======================================================================= -orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) - -depthAssocList u == - u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 - REMDUP ("append"/[depthAssoc(y) for y in u]) - -depthAssoc x == - y := HGET($depthAssocCache,x) => y - x is ['Join,:u] or (u := getCatAncestors x) => - v := depthAssocList u - HPUT($depthAssocCache,x,[[x,:n],:v]) - where n == 1 + "MAX"/[rest y for y in v] - HPUT($depthAssocCache,x,[[x,:0]]) - -getCatAncestors x == [CAAR y for y in parentsOf opOf x] - -listOfEntries form == - atom form => form - form is [op,:l] => - op = 'Join => "append"/[listOfEntries x for x in l] - op = 'CATEGORY => listOfCategoryEntries rest l - op = 'PROGN => listOfCategoryEntries l - op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] - op in '(ATTRIBUTE SIGNATURE) => nil - [form] - categoryFormatError() - -listOfCategoryEntries l == - null l => nil - l is [[op,:u],:v] => - firstItemList:= - op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => - [first u] - MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil - op = 'IF and u is [pred,conseq,alternate] => - listOfCategoryEntriesIf(pred,conseq,alternate) - categoryFormatError() - [:firstItemList,:listOfCategoryEntries v] - l is ['PROGN,:l] => listOfCategoryEntries l - l is '(NIL) => nil - sayBrightly '"unexpected category format encountered:" - pp l - -listOfCategoryEntriesIf(pred,conseq,alternate) == - alternate in '(noBranch NIL) => - conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) - [fn for x in listOfEntries conseq] where fn == - x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] - ['IF,pred,x] - notPred := makePrefixForm(pred,'NOT) - conseq is ['IF,p,c,a] => - listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) - [gn for x in listOfEntries conseq] where gn == - x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] - ['IF,notPred,x] - ---======================================================================= --- Display Template ---======================================================================= -dc(:r) == - con := KAR r - options := KDR r - ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) - null ok => - sayBrightly '"Format is: dc(,option)" - sayBrightly - '"options are: all (default), slots, atts, cats, data, ops, optable" - option := KAR options - option = 'all or null option => dcAll con - option = 'slots => dcSlots con - option = 'atts => dcAtts con - option = 'cats => dcCats con - option = 'data => dcData con - option = 'ops => dcOps con - option = 'size => dcSize( con,'full) - option = 'optable => dcOpTable con - -dcSlots con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - for i in 5..MAXINDEX template repeat - sayBrightlyNT bright i - item := template.i - item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) - null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] - atom item => sayBrightly ['"fun ",item] - item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] - sayBrightly concat('"lazy ",form2String formatSlotDomain i) - -dcOpLatchPrint(op,index) == - numvec := getCodeVector() - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := dcSig(numvec,index + 1,numOfArgs) - index := index + numOfArgs + 1 - namePart := concat(bright "from", - dollarPercentTran form2String formatSlotDomain whereNumber) - sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] - -getInfovec name == - u := GETL(name,'infovec) => u - GETL(name,'LOADED) => nil - fullLibName := GETDATABASE(name,'OBJECT) or return nil - startTimingProcess 'load - loadLibNoUpdate(name, name, fullLibName) - GETL(name,'infovec) - -getOpSegment index == - numOfArgs := (vec := getCodeVector()).index - [vec.i for i in index..(index + numOfArgs + 3)] - -getCodeVector() == - proto4 := $infovec.3 - u := CDDR proto4 - VECP u => u --old style - CDR u --new style - -formatSlotDomain x == - x = 0 => ["$"] - x = 2 => ["$$"] - INTEGERP x => - val := $infovec.0.x - null val => [STRCONC('"#",STRINGIMAGE (x - 5))] - formatSlotDomain val - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatSlotDomain y for y in rest x]] - ---======================================================================= --- Display OpTable ---======================================================================= -dcOpTable con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - $predvec: local := GETDATABASE(con,'PREDICATES) - opTable := $infovec.1 - for i in 0..MAXINDEX opTable repeat - op := opTable.i - i := i + 1 - startIndex := opTable.i - stopIndex := - i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() - opTable.(i + 2) - curIndex := startIndex - while curIndex < stopIndex repeat - curIndex := dcOpPrint(op,curIndex) - -dcOpPrint(op,index) == - numvec := getCodeVector() - segment := getOpSegment index - numOfArgs := numvec.index - index := index + 1 - predNumber := numvec.index - index := index + 1 - signumList := dcSig(numvec,index,numOfArgs) - index := index + numOfArgs + 1 - slotNumber := numvec.index - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - namePart := bright - slotNumber = 0 => '"subsumed by next entry" - slotNumber = 1 => '"missing" - name := $infovec.0.slotNumber - atom name => name - '"looked up" - sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] - index + 1 - -dcSig(numvec,index,numOfArgs) == - [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] - -dcPreds con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - for i in 0..MAXINDEX $predvec repeat - sayBrightlyNT bright (i + 1) - sayBrightly pred2English $predvec.i - -dcAtts con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - attList := $infovec.2 - for [a,:predNumber] in attList for i in 0.. repeat - sayBrightlyNT bright i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - sayBrightly [a,:suffix] - -dcCats con == - name := abbreviation? con or con - $infovec: local := getInfovec name - u := $infovec.3 - VECP CDDR u => dcCats1 con --old style slot4 - $predvec:= GETDATABASE(con,'PREDICATES) - catpredvec := CAR u - catinfo := CADR u - catvec := CADDR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - form := catvec.i - predNumber := catpredvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcCats1 con == - $predvec:= GETDATABASE(con,'PREDICATES) - u := $infovec.3 - catvec := CADR u - catinfo := CAR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - [form,:predNumber] := catvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcData con == - name := abbreviation? con or con - $infovec: local := getInfovec name - sayBrightly '"Operation data from slot 1" - PRINT_-FULL $infovec.1 - vec := getCodeVector() - vec := (PAIRP vec => CDR vec; vec) - sayBrightly ['"Information vector has ",SIZE vec,'" entries"] - dcData1 vec - -dcData1 vec == - n := MAXINDEX vec - tens := n / 10 - for i in 0..tens repeat - start := 10*i - sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) - sayBrightlyNT '" |" - for j in start..MIN(start + 9,n) repeat - sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) - sayNewLine() - vec - -dcSize(:options) == - con := KAR options - options := rest options - null con => dcSizeAll() - quiet := MEMQ('quiet,options) - full := MEMQ('full,options) - name := abbreviation? con or con - infovec := getInfovec name - template := infovec.0 - maxindex := MAXINDEX template - latch := 0 --# of go get slots - lazy := 0 --# of lazy domain slots - fun := 0 --# of function slots - lazyNodes := 0 --# of nodes needed for lazy domain slots - for i in 5..maxindex repeat - atom (item := template.i) => fun := fun + 1 - INTEGERP first item => latch := latch + 1 - 'T => - lazy := lazy + 1 - lazyNodes := lazyNodes + numberOfNodes item - tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) - -- functions are free in the template vector - oSize := vectorSize(SIZE infovec.1) - aSize := numberOfNodes infovec.2 - slot4 := infovec.3 - catvec := - VECP CDDR slot4 => CADR slot4 - CADDR slot4 - n := MAXINDEX catvec - cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), - nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) - codeVector := - VECP CDDR slot4 => CDDR slot4 - CDDDR slot4 - vSize := halfWordSize(SIZE codeVector) - itotal := sum(tSize,oSize,aSize,cSize,vSize) - if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] - if null quiet then - lookupFun := getLookupFun infovec - suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") - sayBrightly ['"template = ",tSize] - sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] - sayBrightly ['"attributes = ",aSize] - sayBrightly ['"categories = ",cSize] - sayBrightly ['"data vector = ",vSize] - if null quiet then - sayBrightly ['"number of function slots (one extra node) = ",fun] - sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] - sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] - sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] - vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) - vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) - --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm - if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] - etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) - if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] - vtotal - -dcSizeAll() == - count := 0 - total := 0 - for x in allConstructors() | null atom GETL(x,'infovec) repeat - count := count + 1 - s := dcSize(x,'quiet) - sayBrightly [s,'" : ",x] - total := total + s - sayBrightly '"------------total-------------" - sayBrightly [count," constructors; ",total," BYTES"] - -sum(:l) == +/l - -nodeSize(n) == 12 * n - -vectorSize(n) == 4 * (1 + n) - -halfWordSize(n) == - n < 128 => n / 2 - n < 256 => n - 2 * n - -numberOfNodes(x) == - atom x => 0 - 1 + numberOfNodes first x + numberOfNodes rest x - -template con == - con := abbreviation? con or con - ppTemplate (getInfovec con).0 - -ppTemplate vec == - for i in 0..MAXINDEX vec repeat - sayBrightlyNT bright i - pp vec.i - -infovec con == - con := abbreviation? con or con - u := getInfovec con - sayBrightly '"---------------slot 0 is template-------------------" - ppTemplate u.0 - sayBrightly '"---------------slot 1 is op table-------------------" - PRINT_-FULL u.1 - sayBrightly '"---------------slot 2 is attribute list-------------" - PRINT_-FULL u.2 - sayBrightly '"---------------slot 3.0 is catpredvec---------------" - PRINT_-FULL u.3.0 - sayBrightly '"---------------slot 3.1 is catinfovec---------------" - PRINT_-FULL u.3.1 - sayBrightly '"---------------slot 3.2 is catvec-------------------" - PRINT_-FULL u.3.2 - sayBrightly '"---------------tail of slot 3 is datavector---------" - dcData1 CDDDR u.3 - 'done - -dcAll con == - con := abbreviation? con or con - $infovec : local := getInfovec con - complete? := - #$infovec = 4 => false - $infovec.4 = 'lookupComplete - sayBrightly '"----------------Template-----------------" - dcSlots con - sayBrightly - complete? => '"----------Complete Ops----------------" - '"----------Incomplete Ops---------------" - dcOpTable con - sayBrightly '"----------------Atts-----------------" - dcAtts con - sayBrightly '"----------------Preds-----------------" - dcPreds con - sayBrightly '"----------------Cats-----------------" - dcCats con - sayBrightly '"----------------Data------------------" - dcData con - sayBrightly '"----------------Size------------------" - dcSize(con,'full) - 'done - -dcOps conname == - for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat - for [sig,slot,pred,key,:.] in u repeat - suffix := - atom pred => nil - concat('" if ",pred2English pred) - key = 'Subsumed => - sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] - sayBrightly [:formatOpSignature(op,sig),:suffix] - ---======================================================================= --- Compute the lookup function (complete or incomplete) ---======================================================================= -NRTgetLookupFunction(domform,exCategory,addForm) == - domform := SUBLIS($pairlis,domform) - addForm := SUBLIS($pairlis,addForm) - $why: local := nil - atom addForm => 'lookupComplete - extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) - if null extends then - [u,msg,:v] := $why - sayBrightly '"--------------non extending category----------------------" - sayBrightlyNT ['"..",:bright form2String domform,"of cat "] - PRINT u - sayBrightlyNT bright msg - if v then PRINT CAR v else TERPRI() - extends => 'lookupIncomplete - 'lookupComplete - -getExportCategory form == - [op,:argl] := form - op = 'Record => ['RecordCategory,:argl] - op = 'Union => ['UnionCategory,:argl] - functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) - [[.,target,:tl],:.] := functorModemap - EQSUBSTLIST(argl,$FormalMapVariableList,target) - -NRTextendsCategory1(domform,exCategory,addForm) == - addForm is ['Tuple,:r] => - and/[extendsCategory(domform,exCategory,x) for x in r] - extendsCategory(domform,exCategory,addForm) - ---======================================================================= --- Compute if a domain constructor is forgetful functor ---======================================================================= -extendsCategory(dom,u,v) == - --does category u extend category v (yes iff u contains everything in v) - --is dom of category u also of category v? - u=v => true - v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) - v := substSlotNumbers(v,$template,$functorForm) - extendsCategoryBasic0(dom,u,v) => true - $why := - v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] - [u,'" has no",v] - nil - -extendsCategoryBasic0(dom,u,v) == - v is ['IF,p,['ATTRIBUTE,c],.] => - uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr - null atom c and isCategoryForm(c,nil) => - slot4 := uVec.4 - LASSOC(c,CADR slot4) is [=p,:.] - slot2 := uVec.2 - LASSOC(c,slot2) is [=p,:.] - extendsCategoryBasic(dom,u,v) - -extendsCategoryBasic(dom,u,v) == - u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] - u = v => true - uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr - isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) - v is ['SIGNATURE,op,sig] => - or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] - u is ['CATEGORY,.,:l] => - v is ['IF,:.] => member(v,l) - nil - nil - -catExtendsCat?(u,v,uvec) == - u = v => true - uvec := uvec or compMakeCategoryObject(u,$EmptyEnvironment).expr - slot4 := uvec.4 - prinAncestorList := CAR slot4 - member(v,prinAncestorList) => true - vOp := KAR v - if similarForm := ASSOC(vOp,prinAncestorList) then - PRINT u - sayBrightlyNT '" extends " - PRINT similarForm - sayBrightlyNT '" but not " - PRINT v - or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] - -substSlotNumbers(form,template,domain) == - form is [op,:.] and - MEMQ(op,allConstructors()) => expandType(form,template,domain) - form is ['SIGNATURE,op,sig] => - ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] - form is ['CATEGORY,k,:u] => - ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] - expandType(form,template,domain) - -expandType(lazyt,template,domform) == - atom lazyt => expandTypeArgs(lazyt,template,domform) - [functorName,:argl] := lazyt - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] - for [.,tag,dom] in argl]] - lazyt is ['local,x] => - n := POSN1(x,$FormalMapVariableList) - ELT(domform,1 + n) - [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] - -expandTypeArgs(u,template,domform) == - u = '$ => u --template.0 -------eliminate this as $ is rep by 0 - INTEGERP u => expandType(templateVal(template, domform, u), template,domform) - u is ['NRTEVAL,y] => y --eval y - u is ['QUOTE,y] => y - atom u => u - expandType(u,template,domform) - -templateVal(template,domform,index) == ---returns a domform or a lazy slot - index = 0 => harhar() --template - template.index - diff --git a/src/interp/nrunopt.boot.pamphlet b/src/interp/nrunopt.boot.pamphlet new file mode 100644 index 00000000..672131fc --- /dev/null +++ b/src/interp/nrunopt.boot.pamphlet @@ -0,0 +1,929 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/nrunopt.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--======================================================================= +-- Generate Code to Create Infovec +--======================================================================= +getInfovecCode() == +--Function called by compDefineFunctor1 to create infovec at compile time + ['LIST, + MKQ makeDomainTemplate $template, + MKQ makeCompactDirect $NRTslot1Info, + MKQ NRTgenFinalAttributeAlist(), + NRTmakeCategoryAlist(), + MKQ $lookupFunction] + +--======================================================================= +-- Generation of Domain Vector Template (Compile Time) +--======================================================================= +makeDomainTemplate vec == +--NOTES: This function is called at compile time to create the template +-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 + newVec := GETREFV SIZE vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + newVec.index := + atom item => item + null atom first item => makeGoGetSlot(item,index) + item + $byteVec := "append"/NREVERSE $byteVec + newVec + +makeGoGetSlot(item,index) == +--NOTES: creates byte vec strings for LATCH slots +--these parts of the $byteVec are created first; see also makeCompactDirect + [sig,whereToGo,op,:flag] := item + n := #sig - 1 + newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] + $byteVec := [newcode,:$byteVec] + curAddress := $byteAddress + $byteAddress := $byteAddress + n + 4 + [curAddress,:op] + +--======================================================================= +-- Generate OpTable at Compile Time +--======================================================================= +--> called by getInfovecCode (see top of this file) from compDefineFunctor1 +makeCompactDirect u == + $predListLength :local := LENGTH $NRTslot1PredicateList + $byteVecAcc: local := nil + [nam,[addForm,:opList]] := u + --pp opList + d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] + $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] + LIST2VEC ("append"/d) + +makeCompactDirect1(op,items) == +--NOTES: creates byte codes for ops implemented by the domain + curAddress := $byteAddress + $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) + newcodes := + "append"/[u for y in orderBySubsumption items | u := fn y] or return nil + $byteVecAcc := [newcodes,:$byteVecAcc] + curAddress + where fn y == + [sig,:r] := y + r = ['Subsumed] => + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature + --identified by a 0 in slot position + if r is [n,:s] then + slot := + n is [p,:.] => p --the CDR is linenumber of function definition + n + predCode := + s is [pred,:.] => predicateBitIndex pred + 0 + --> drop items which are not present (predCode = -1) + predCode = -1 => return nil + --> drop items with NIL slots if lookup function is incomplete + if null slot then + $lookupFunction = 'lookupIncomplete => return nil + slot := 1 --signals that operation is not present + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] + res + +orderBySubsumption items == + acc := subacc := nil + for x in items repeat + not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] + acc := [x,:acc] + y := z := nil + for [a,b,:.] in subacc | b repeat + --NOTE: b = nil means that the signature a will appear in acc, that this + -- entry is be ignored (e.g. init: -> $ in ULS) + while (u := ASSOC(b,subacc)) repeat b := CADR u + u := ASSOC(b,acc) or systemError nil + if null CADR u then u := [CAR u,1] --mark as missing operation + y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed + z := insert(b,z) --mark a signature as already present + [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming + +makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where +--$isOpPackageName = true only for an exported operation of a default package + fn == + x = '_$_$ => 2 + x = '$ => 0 + NULL INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] +-- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages + x + +--======================================================================= +-- Instantiation Code (Stuffslots) +--======================================================================= +stuffDomainSlots dollar == + domname := devaluate dollar + infovec := GETL(opOf domname,'infovec) + lookupFunction := getLookupFun infovec + lookupFunction := + lookupFunction = 'lookupIncomplete => function lookupIncomplete + function lookupComplete + template := infovec.0 + if template.5 then stuffSlot(dollar,5,template.5) + for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat + stuffSlot(dollar,i,item) + dollar.1 := LIST(lookupFunction,dollar,infovec.1) + dollar.2 := infovec.2 + proto4 := infovec.3 + dollar.4 := + VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style + bitVector := dollar.3 + predvec := CAR proto4 + packagevec := CADR proto4 + auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn == + null testBitVector(bitVector,predvec.i) => nil + packagevec.i or 'T + [auxvec,:CDDR proto4] + +getLookupFun infovec == + MAXINDEX infovec = 4 => infovec.4 + 'lookupIncomplete + +stuffSlot(dollar,i,item) == + dollar.i := + atom item => [SYMBOL_-FUNCTION item,:dollar] + item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] + item is ['CONS,.,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil +-- [dollar,i,:item] --old form +-- $isOpPackageName = 'T => SUBST(0,6,item) + item --new form +--======================================================================= +-- Generate Slot 2 Attribute Alist +--======================================================================= +NRTgenInitialAttributeAlist attributeList == + --alist has form ((item pred)...) where some items are constructor forms + alist := [x for x in attributeList | -- throw out constructors + null MEMQ(opOf first x,allConstructors())] + $lisplibAttributes := simplifyAttributeAlist + [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] + +simplifyAttributeAlist al == + al is [[a,:b],:r] => + u := [x for x in r | x is [=a,:b]] + null u => [first al,:simplifyAttributeAlist rest al] + pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + s := [x for x in r | x isnt [=a,:b]] + [[a,:pred],:simplifyAttributeAlist s] + nil + +NRTgenFinalAttributeAlist() == + [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] + +predicateBitIndex x == + pn(x,nil) where + pn(x,flag) == + u := simpBool transHasCode x + u = 'T => 0 + u = nil => -1 + p := POSN1(u,$NRTslot1PredicateList) => p + 1 + null flag => pn(predicateBitIndexRemop x,true) + systemError nil + +predicateBitIndexRemop p== +--transform attribute predicates taken out by removeAttributePredicates + p is [op,:argl] and op in '(AND and OR or NOT not) => + simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) + p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) + p + +predicateBitRef x == + x = 'T => 'T + ['testBitVector,'pv_$,predicateBitIndex x] + +makePrefixForm(u,op) == + u := MKPF(u,op) + u = ''T => 'T + u +--======================================================================= +-- Generate Slot 3 Predicate Vector +--======================================================================= +makePredicateBitVector pl == --called by NRTbuildFunctor + if $insideCategoryPackageIfTrue = true then + pl := union(pl,$categoryPredicateList) + $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas + for p in removeAttributePredicates pl repeat + pred := simpBool transHasCode p + atom pred => 'skip --skip over T and NIL + if isHasDollarPred pred then + lasts := insert(pred,lasts) + for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) + else + firsts := insert(pred,firsts) + firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) + lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) + firstCode:= + ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] + lastCode := augmentPredCode(# firstPl,lastPl) + $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates + [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 + +augmentPredCode(n,lastPl) == + ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) + delta := 2 ** n + l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); + delta:=2 * delta; u) for x in pl] + +augmentPredVector(dollar,value) == + QSETREFV(dollar,3,value + QVELT(dollar,3)) + +isHasDollarPred pred == + pred is [op,:r] => + MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] + MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ + false + +stripOutNonDollarPreds pred == + pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => + "append"/[stripOutNonDollarPreds x for x in r] + not isHasDollarPred pred => [pred] + nil + +removeAttributePredicates pl == + [fn p for p in pl] where + fn p == + p is [op,:argl] and op in '(AND and OR or NOT not) => + makePrefixForm(fnl argl,op) + p is ['has,'$,['ATTRIBUTE,a]] => + sayBrightlyNT '"Predicate: " + PRINT p + sayBrightlyNT '" replaced by: " + PRINT LASSOC(a,$NRTattributeAlist) + p + fnl p == [fn x for x in p] + +transHasCode x == + atom x => x + op := QCAR x + MEMQ(op,'(HasCategory HasAttribute)) => x + EQ(op,'has) => compHasFormat x + [transHasCode y for y in x] + +mungeAddGensyms(u,gal) == + ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == + atom x => x + g := LASSOC(x,gal) => + n = 0 => ['LET,g,x] + g + [first x,:[fn(y,gal,n + 1) for y in rest x]] + +orderByContainment pl == + null pl or null rest pl => pl + max := first pl + for x in rest pl repeat + if (y := CONTAINED(max,x)) then + if null ASSOC(max,$predGensymAlist) + then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] + else if CONTAINED(x,max) + then if null ASSOC(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] + if y then max := x + [max,:orderByContainment delete(max,pl)] + +buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == + null l => n + n := n + n + if QCAR l then n := n + 1 + fn(rest l,n) + +buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == + null l => acc + if CAR l then acc := acc + n + fn(acc,n + n,rest l) + +testBitVector(vec,i) == +--bit vector indices are always 1 larger than position in vector + EQ(i,0) => true + LOGBITP(i - 1,vec) + +bitsOf n == + n = 0 => 0 + 1 + bitsOf (n/2) + +--======================================================================= +-- Generate Slot 4 Constructor Vectors +--======================================================================= +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +NRTmakeCategoryAlist() == + $depthAssocCache: local := MAKE_-HASHTABLE 'ID + pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] + $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] + opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) + newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] + slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) + | (k := predicateBitIndex b) ^= -1] + slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] + sixEtc := [5 + i for i in 1..#$pairlis] + formals := ASSOCRIGHT $pairlis + for x in slot1 repeat RPLACA(x,EQSUBSTLIST(sixEtc,formals,CAR x)) + -----------code to make a new style slot4----------------- + predList := ASSOCRIGHT slot1 --is list of predicate indices + maxPredList := "MAX"/predList + catformvec := ASSOCLEFT slot1 + maxElement := "MAX"/$byteVec + ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], + ['CONS, MKQ LIST2VEC slot0, + ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], + ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] + --NOTE: this is new form: old form satisfies VECP CDDR form + +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +encodeCatform x == + k := NRTassocIndex x => k + atom x or atom rest x => x + [first x,:[encodeCatform y for y in rest x]] + +NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) + +hasDefaultPackage catname == + defname := INTERN STRCONC(catname,'"&") + constructor? defname => defname +--MEMQ(defname,allConstructors()) => defname + nil + + +--======================================================================= +-- Generate Category Level Alist +--======================================================================= +orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) + +depthAssocList u == + u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 + REMDUP ("append"/[depthAssoc(y) for y in u]) + +depthAssoc x == + y := HGET($depthAssocCache,x) => y + x is ['Join,:u] or (u := getCatAncestors x) => + v := depthAssocList u + HPUT($depthAssocCache,x,[[x,:n],:v]) + where n == 1 + "MAX"/[rest y for y in v] + HPUT($depthAssocCache,x,[[x,:0]]) + +getCatAncestors x == [CAAR y for y in parentsOf opOf x] + +listOfEntries form == + atom form => form + form is [op,:l] => + op = 'Join => "append"/[listOfEntries x for x in l] + op = 'CATEGORY => listOfCategoryEntries rest l + op = 'PROGN => listOfCategoryEntries l + op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] + op in '(ATTRIBUTE SIGNATURE) => nil + [form] + categoryFormatError() + +listOfCategoryEntries l == + null l => nil + l is [[op,:u],:v] => + firstItemList:= + op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => + [first u] + MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil + op = 'IF and u is [pred,conseq,alternate] => + listOfCategoryEntriesIf(pred,conseq,alternate) + categoryFormatError() + [:firstItemList,:listOfCategoryEntries v] + l is ['PROGN,:l] => listOfCategoryEntries l + l is '(NIL) => nil + sayBrightly '"unexpected category format encountered:" + pp l + +listOfCategoryEntriesIf(pred,conseq,alternate) == + alternate in '(noBranch NIL) => + conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) + [fn for x in listOfEntries conseq] where fn == + x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] + ['IF,pred,x] + notPred := makePrefixForm(pred,'NOT) + conseq is ['IF,p,c,a] => + listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) + [gn for x in listOfEntries conseq] where gn == + x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] + ['IF,notPred,x] + +--======================================================================= +-- Display Template +--======================================================================= +dc(:r) == + con := KAR r + options := KDR r + ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) + null ok => + sayBrightly '"Format is: dc(,option)" + sayBrightly + '"options are: all (default), slots, atts, cats, data, ops, optable" + option := KAR options + option = 'all or null option => dcAll con + option = 'slots => dcSlots con + option = 'atts => dcAtts con + option = 'cats => dcCats con + option = 'data => dcData con + option = 'ops => dcOps con + option = 'size => dcSize( con,'full) + option = 'optable => dcOpTable con + +dcSlots con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + for i in 5..MAXINDEX template repeat + sayBrightlyNT bright i + item := template.i + item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) + null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] + atom item => sayBrightly ['"fun ",item] + item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] + sayBrightly concat('"lazy ",form2String formatSlotDomain i) + +dcOpLatchPrint(op,index) == + numvec := getCodeVector() + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := dcSig(numvec,index + 1,numOfArgs) + index := index + numOfArgs + 1 + namePart := concat(bright "from", + dollarPercentTran form2String formatSlotDomain whereNumber) + sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] + +getInfovec name == + u := GETL(name,'infovec) => u + GETL(name,'LOADED) => nil + fullLibName := GETDATABASE(name,'OBJECT) or return nil + startTimingProcess 'load + loadLibNoUpdate(name, name, fullLibName) + GETL(name,'infovec) + +getOpSegment index == + numOfArgs := (vec := getCodeVector()).index + [vec.i for i in index..(index + numOfArgs + 3)] + +getCodeVector() == + proto4 := $infovec.3 + u := CDDR proto4 + VECP u => u --old style + CDR u --new style + +formatSlotDomain x == + x = 0 => ["$"] + x = 2 => ["$$"] + INTEGERP x => + val := $infovec.0.x + null val => [STRCONC('"#",STRINGIMAGE (x - 5))] + formatSlotDomain val + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatSlotDomain y for y in rest x]] + +--======================================================================= +-- Display OpTable +--======================================================================= +dcOpTable con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + $predvec: local := GETDATABASE(con,'PREDICATES) + opTable := $infovec.1 + for i in 0..MAXINDEX opTable repeat + op := opTable.i + i := i + 1 + startIndex := opTable.i + stopIndex := + i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() + opTable.(i + 2) + curIndex := startIndex + while curIndex < stopIndex repeat + curIndex := dcOpPrint(op,curIndex) + +dcOpPrint(op,index) == + numvec := getCodeVector() + segment := getOpSegment index + numOfArgs := numvec.index + index := index + 1 + predNumber := numvec.index + index := index + 1 + signumList := dcSig(numvec,index,numOfArgs) + index := index + numOfArgs + 1 + slotNumber := numvec.index + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + namePart := bright + slotNumber = 0 => '"subsumed by next entry" + slotNumber = 1 => '"missing" + name := $infovec.0.slotNumber + atom name => name + '"looked up" + sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] + index + 1 + +dcSig(numvec,index,numOfArgs) == + [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] + +dcPreds con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + for i in 0..MAXINDEX $predvec repeat + sayBrightlyNT bright (i + 1) + sayBrightly pred2English $predvec.i + +dcAtts con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + attList := $infovec.2 + for [a,:predNumber] in attList for i in 0.. repeat + sayBrightlyNT bright i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + sayBrightly [a,:suffix] + +dcCats con == + name := abbreviation? con or con + $infovec: local := getInfovec name + u := $infovec.3 + VECP CDDR u => dcCats1 con --old style slot4 + $predvec:= GETDATABASE(con,'PREDICATES) + catpredvec := CAR u + catinfo := CADR u + catvec := CADDR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + form := catvec.i + predNumber := catpredvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcCats1 con == + $predvec:= GETDATABASE(con,'PREDICATES) + u := $infovec.3 + catvec := CADR u + catinfo := CAR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + [form,:predNumber] := catvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcData con == + name := abbreviation? con or con + $infovec: local := getInfovec name + sayBrightly '"Operation data from slot 1" + PRINT_-FULL $infovec.1 + vec := getCodeVector() + vec := (PAIRP vec => CDR vec; vec) + sayBrightly ['"Information vector has ",SIZE vec,'" entries"] + dcData1 vec + +dcData1 vec == + n := MAXINDEX vec + tens := n / 10 + for i in 0..tens repeat + start := 10*i + sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) + sayBrightlyNT '" |" + for j in start..MIN(start + 9,n) repeat + sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) + sayNewLine() + vec + +dcSize(:options) == + con := KAR options + options := rest options + null con => dcSizeAll() + quiet := MEMQ('quiet,options) + full := MEMQ('full,options) + name := abbreviation? con or con + infovec := getInfovec name + template := infovec.0 + maxindex := MAXINDEX template + latch := 0 --# of go get slots + lazy := 0 --# of lazy domain slots + fun := 0 --# of function slots + lazyNodes := 0 --# of nodes needed for lazy domain slots + for i in 5..maxindex repeat + atom (item := template.i) => fun := fun + 1 + INTEGERP first item => latch := latch + 1 + 'T => + lazy := lazy + 1 + lazyNodes := lazyNodes + numberOfNodes item + tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) + -- functions are free in the template vector + oSize := vectorSize(SIZE infovec.1) + aSize := numberOfNodes infovec.2 + slot4 := infovec.3 + catvec := + VECP CDDR slot4 => CADR slot4 + CADDR slot4 + n := MAXINDEX catvec + cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), + nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) + codeVector := + VECP CDDR slot4 => CDDR slot4 + CDDDR slot4 + vSize := halfWordSize(SIZE codeVector) + itotal := sum(tSize,oSize,aSize,cSize,vSize) + if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] + if null quiet then + lookupFun := getLookupFun infovec + suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") + sayBrightly ['"template = ",tSize] + sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] + sayBrightly ['"attributes = ",aSize] + sayBrightly ['"categories = ",cSize] + sayBrightly ['"data vector = ",vSize] + if null quiet then + sayBrightly ['"number of function slots (one extra node) = ",fun] + sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] + sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] + sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] + vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) + vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) + --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm + if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] + etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) + if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] + vtotal + +dcSizeAll() == + count := 0 + total := 0 + for x in allConstructors() | null atom GETL(x,'infovec) repeat + count := count + 1 + s := dcSize(x,'quiet) + sayBrightly [s,'" : ",x] + total := total + s + sayBrightly '"------------total-------------" + sayBrightly [count," constructors; ",total," BYTES"] + +sum(:l) == +/l + +nodeSize(n) == 12 * n + +vectorSize(n) == 4 * (1 + n) + +halfWordSize(n) == + n < 128 => n / 2 + n < 256 => n + 2 * n + +numberOfNodes(x) == + atom x => 0 + 1 + numberOfNodes first x + numberOfNodes rest x + +template con == + con := abbreviation? con or con + ppTemplate (getInfovec con).0 + +ppTemplate vec == + for i in 0..MAXINDEX vec repeat + sayBrightlyNT bright i + pp vec.i + +infovec con == + con := abbreviation? con or con + u := getInfovec con + sayBrightly '"---------------slot 0 is template-------------------" + ppTemplate u.0 + sayBrightly '"---------------slot 1 is op table-------------------" + PRINT_-FULL u.1 + sayBrightly '"---------------slot 2 is attribute list-------------" + PRINT_-FULL u.2 + sayBrightly '"---------------slot 3.0 is catpredvec---------------" + PRINT_-FULL u.3.0 + sayBrightly '"---------------slot 3.1 is catinfovec---------------" + PRINT_-FULL u.3.1 + sayBrightly '"---------------slot 3.2 is catvec-------------------" + PRINT_-FULL u.3.2 + sayBrightly '"---------------tail of slot 3 is datavector---------" + dcData1 CDDDR u.3 + 'done + +dcAll con == + con := abbreviation? con or con + $infovec : local := getInfovec con + complete? := + #$infovec = 4 => false + $infovec.4 = 'lookupComplete + sayBrightly '"----------------Template-----------------" + dcSlots con + sayBrightly + complete? => '"----------Complete Ops----------------" + '"----------Incomplete Ops---------------" + dcOpTable con + sayBrightly '"----------------Atts-----------------" + dcAtts con + sayBrightly '"----------------Preds-----------------" + dcPreds con + sayBrightly '"----------------Cats-----------------" + dcCats con + sayBrightly '"----------------Data------------------" + dcData con + sayBrightly '"----------------Size------------------" + dcSize(con,'full) + 'done + +dcOps conname == + for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat + for [sig,slot,pred,key,:.] in u repeat + suffix := + atom pred => nil + concat('" if ",pred2English pred) + key = 'Subsumed => + sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] + sayBrightly [:formatOpSignature(op,sig),:suffix] + +--======================================================================= +-- Compute the lookup function (complete or incomplete) +--======================================================================= +NRTgetLookupFunction(domform,exCategory,addForm) == + domform := SUBLIS($pairlis,domform) + addForm := SUBLIS($pairlis,addForm) + $why: local := nil + atom addForm => 'lookupComplete + extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) + if null extends then + [u,msg,:v] := $why + sayBrightly '"--------------non extending category----------------------" + sayBrightlyNT ['"..",:bright form2String domform,"of cat "] + PRINT u + sayBrightlyNT bright msg + if v then PRINT CAR v else TERPRI() + extends => 'lookupIncomplete + 'lookupComplete + +getExportCategory form == + [op,:argl] := form + op = 'Record => ['RecordCategory,:argl] + op = 'Union => ['UnionCategory,:argl] + functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) + [[.,target,:tl],:.] := functorModemap + EQSUBSTLIST(argl,$FormalMapVariableList,target) + +NRTextendsCategory1(domform,exCategory,addForm) == + addForm is ['Tuple,:r] => + and/[extendsCategory(domform,exCategory,x) for x in r] + extendsCategory(domform,exCategory,addForm) + +--======================================================================= +-- Compute if a domain constructor is forgetful functor +--======================================================================= +extendsCategory(dom,u,v) == + --does category u extend category v (yes iff u contains everything in v) + --is dom of category u also of category v? + u=v => true + v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) + v := substSlotNumbers(v,$template,$functorForm) + extendsCategoryBasic0(dom,u,v) => true + $why := + v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] + [u,'" has no",v] + nil + +extendsCategoryBasic0(dom,u,v) == + v is ['IF,p,['ATTRIBUTE,c],.] => + uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr + null atom c and isCategoryForm(c,nil) => + slot4 := uVec.4 + LASSOC(c,CADR slot4) is [=p,:.] + slot2 := uVec.2 + LASSOC(c,slot2) is [=p,:.] + extendsCategoryBasic(dom,u,v) + +extendsCategoryBasic(dom,u,v) == + u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] + u = v => true + uVec := compMakeCategoryObject(u,$EmptyEnvironment).expr + isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) + v is ['SIGNATURE,op,sig] => + or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] + u is ['CATEGORY,.,:l] => + v is ['IF,:.] => member(v,l) + nil + nil + +catExtendsCat?(u,v,uvec) == + u = v => true + uvec := uvec or compMakeCategoryObject(u,$EmptyEnvironment).expr + slot4 := uvec.4 + prinAncestorList := CAR slot4 + member(v,prinAncestorList) => true + vOp := KAR v + if similarForm := ASSOC(vOp,prinAncestorList) then + PRINT u + sayBrightlyNT '" extends " + PRINT similarForm + sayBrightlyNT '" but not " + PRINT v + or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] + +substSlotNumbers(form,template,domain) == + form is [op,:.] and + MEMQ(op,allConstructors()) => expandType(form,template,domain) + form is ['SIGNATURE,op,sig] => + ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] + form is ['CATEGORY,k,:u] => + ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] + expandType(form,template,domain) + +expandType(lazyt,template,domform) == + atom lazyt => expandTypeArgs(lazyt,template,domform) + [functorName,:argl] := lazyt + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] + for [.,tag,dom] in argl]] + lazyt is ['local,x] => + n := POSN1(x,$FormalMapVariableList) + ELT(domform,1 + n) + [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] + +expandTypeArgs(u,template,domform) == + u = '$ => u --template.0 -------eliminate this as $ is rep by 0 + INTEGERP u => expandType(templateVal(template, domform, u), template,domform) + u is ['NRTEVAL,y] => y --eval y + u is ['QUOTE,y] => y + atom u => u + expandType(u,template,domform) + +templateVal(template,domform,index) == +--returns a domform or a lazy slot + index = 0 => harhar() --template + template.index + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/nruntime.boot b/src/interp/nruntime.boot deleted file mode 100644 index 23606999..00000000 --- a/src/interp/nruntime.boot +++ /dev/null @@ -1,58 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -unloadOneConstructor(cnam,fn) == - REMPROP(cnam,'LOADED) - SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) - -devaluateDeeply x == - VECP x => devaluate x - atom x => x - [devaluateDeeply y for y in x] - -lookupDisplay(op,sig,vectorOrForm,suffix) == - null $NRTmonitorIfTrue => nil - prefix := (suffix = '"" => ">"; "<") - sayBrightly - concat(prefix,formatOpSignature(op,sig), - '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) - -isInstantiated [op,:argl] == - u:= lassocShiftWithFunction(argl,HGET($ConstructorCache,op),'domainEqualList) - => CDRwithIncrement u - nil - -isCategoryPackageName nam == - p := PNAME opOf nam - p.(MAXINDEX p) = char '_& - - diff --git a/src/interp/nruntime.boot.pamphlet b/src/interp/nruntime.boot.pamphlet new file mode 100644 index 00000000..c2d809d1 --- /dev/null +++ b/src/interp/nruntime.boot.pamphlet @@ -0,0 +1,80 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp nruntime.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +unloadOneConstructor(cnam,fn) == + REMPROP(cnam,'LOADED) + SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +devaluateDeeply x == + VECP x => devaluate x + atom x => x + [devaluateDeeply y for y in x] + +lookupDisplay(op,sig,vectorOrForm,suffix) == + null $NRTmonitorIfTrue => nil + prefix := (suffix = '"" => ">"; "<") + sayBrightly + concat(prefix,formatOpSignature(op,sig), + '" from ", prefix2String devaluateDeeply vectorOrForm,suffix) + +isInstantiated [op,:argl] == + u:= lassocShiftWithFunction(argl,HGET($ConstructorCache,op),'domainEqualList) + => CDRwithIncrement u + nil + +isCategoryPackageName nam == + p := PNAME opOf nam + p.(MAXINDEX p) = char '_& + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/osyscmd.boot b/src/interp/osyscmd.boot deleted file mode 100644 index 996d53f8..00000000 --- a/src/interp/osyscmd.boot +++ /dev/null @@ -1,53 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - - -InterpExecuteSpadSystemCommand string == - CATCH($intCoerceFailure, - CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) - -ExecuteInterpSystemCommand string == - string := intProcessSynonyms(string) - $currentLine:local:=string - string:=SUBSTRING(string,1,nil) - string = '"" => nil - doSystemCommand string - ---------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) -parseFromString(s) == - s := next(function ncloopParse, - next(function lineoftoks,incString s)) - StreamNull s => nil - pf2Sex macroExpanded first rest first s - diff --git a/src/interp/osyscmd.boot.pamphlet b/src/interp/osyscmd.boot.pamphlet new file mode 100644 index 00000000..c1afede2 --- /dev/null +++ b/src/interp/osyscmd.boot.pamphlet @@ -0,0 +1,75 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp osyscmd.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + + +InterpExecuteSpadSystemCommand string == + CATCH($intCoerceFailure, + CATCH($intSpadReader, ExecuteInterpSystemCommand string) ) + +ExecuteInterpSystemCommand string == + string := intProcessSynonyms(string) + $currentLine:local:=string + string:=SUBSTRING(string,1,nil) + string = '"" => nil + doSystemCommand string + +--------------------> NEW DEFINITION (see i-syscmd.boot.pamphlet) +parseFromString(s) == + s := next(function ncloopParse, + next(function lineoftoks,incString s)) + StreamNull s => nil + pf2Sex macroExpanded first rest first s + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/package.boot b/src/interp/package.boot deleted file mode 100644 index 399838ef..00000000 --- a/src/interp/package.boot +++ /dev/null @@ -1,274 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -isPackageFunction() == - -- called by compile/putInLocalDomainReferences ---+ - nil - -processFunctorOrPackage(form,signature,data,localParList,m,e) == ---+ - processFunctor(form,signature,data,localParList,e) - -processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == - $GENNO: local:= 0 --for GENVAR() - $catsig: local - --used in ProcessCond - $maximalViews: local - --read by ProcessCond - $ResetItems: local - --stores those items that get SETQed, and may need re-processing - $catvecList: local:= [$domainShell] - $catNames: local:= ["$"] ---PRINT $definition ---PRINT ($catsig,:argssig) ---PRETTYPRINT code - catvec:= $domainShell --from compDefineFunctor - $getDomainCode:= optFunctorBody $getDomainCode - --the purpose of this is so ProcessCond recognises such items - code:= PackageDescendCode(code,true,nil) - if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where - setPackageCode locals == - locals':=[[u,:i] for u in locals for i in 0.. | u] - locals'' :=[] - while locals' repeat - for v in locals' repeat - [u,:i]:=v - if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] - then - locals'':=[v,:locals''] - locals':=delete(v,locals') - precomp:=code:=[] - for elem in locals'' repeat - [u,:i]:=elem - if ATOM u then u':=u - else - u':=opt(u,precomp) where - opt(u,alist) == - ATOM u => u - for v in u repeat - if (a:=ASSOC(v,alist)) then - [.,:i]:=a - u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where - replace(old,new,l) == - l isnt [h,:t] => l - h = old => [new,:t] - [h,:replace(old,new,t)] - v':=opt(v,alist) - EQ(v,v') => nil - u:=replace(v,v',u) - u - precomp:=[elem,:precomp] - code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] - nreverse code - code:= - ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], - --It is important to place this code here, - --after $ is set up - --slam functor with shell - --the order of steps in this PROGN are critical - addToSlam($definition,"$"),code,[ - "SETELT","$",0, mkDomainConstructor $definition],: --- If we call addMutableArg this early, then recurise calls to this domain --- (e.g. while testing predicates) will generate new domains => trouble --- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: - [["SETELT","$",position(name,locals),name] - for name in $ResetItems | MEMQ(name,locals)], - :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) - (LIST (GENSYM)));[]) ], - "$"] - for u in $getDomainCode repeat - u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => - $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) - $packagesUsed:=union($functorLocalParameters,$packagesUsed) - $getDomainCode:= nil - --if we didn't kill this, DEFINE would insert it in the wrong place - optFunctorBody code - -subTree(u,v) == - v=u => true - ATOM v => nil - or/[subTree(u,v') for v' in v] - -mkList u == - u => ["LIST",:u] - nil - -setPackageLocals(pac,locs) == - for var in locs for i in 0.. | var^=nil repeat pac.i:= var - -PackageDescendCode(code,flag,viewAssoc) == - --flag is true if we are walking down code always executed - --nil if we are in conditional code - code=nil => nil - code="noBranch" => nil - code is ["add",base,:codelist] => - systemError '"packages may not have add clauses" - code is ["PROGN",:codelist] => - ["PROGN",: - [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] - code is ["COND",:condlist] => - c:= - ["COND",: - [[u2:= ProcessCond(first u,viewAssoc),: - (if null u2 - then nil - else - [PackageDescendCode(v,flag and TruthP u2, - if first u is ["HasCategory",dom,cat] - then [[dom,:cat],:viewAssoc] - else viewAssoc) for v in rest u])] for u in condlist]] - TruthP CAADR c => ["PROGN",:CDADR c] - c - code is ["LET",name,body,:.] => - if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] - if body is [a,:.] and isFunctor a - then $packagesUsed:=[body,:$packagesUsed] - code - code is ["CodeDefine",sig,implem] => - --Generated by doIt in COMPILER BOOT - dom:= "$" - dom:= - u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] - dom - body:= ["CONS",implem,dom] - SetFunctionSlots(sig,body,flag,"original") - code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) - --Yes, I know that's a hack, but how else do you kill a line? - code is ["LIST",:.] => nil - code is ["MDEF",:.] => nil - code is ["devaluate",:.] => nil - code is ["call",:.] => code - code is ["SETELT",:.] => code - code is ["QSETREFV",:.] => code - stackWarning ["unknown Package code ",code] - code - -mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == - domainOrPackage^="domain" => - [opSig,pred,["PAC","$",name]] where - name() == encodeFunctionName(op,domainOrPackage,sig,":",count) - null flag => [opSig,pred,["ELT","$",count]] - first flag="constant" => [[op,sig],pred,["CONST","$",count]] - systemError ["unknown variable mode: ",flag] - -optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == - RPLACA(x,functionName) - RPLACD(x,[:arglist,packageVariableOrForm]) - x - ---% Code for encoding function names inside package or domain - -encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) - == - signature':= substitute("$",package,signature) - reducedSig:= mkRepititionAssoc [:rest signature',first signature'] - encodedSig:= - ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where - encodedPair() == - n=1 => encodeItem x - STRCONC(STRINGIMAGE n,encodeItem x) - encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", - encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) - if $LISPLIB then - $lisplibSignatureAlist:= - [[encodedName,:signature'],:$lisplibSignatureAlist] - encodedName - -splitEncodedFunctionName(encodedName, sep) == - -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL - -- sep0 is the separator used in "encodeFunctionName". - sep0 := '";" - if not STRINGP encodedName then - encodedName := STRINGIMAGE encodedName - null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil - null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner --- This is picked up in compile for inner functions in partial compilation - null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil - s1 := SUBSTRING(encodedName, 0, p1) - s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) - s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) - s4 := SUBSTRING(encodedName, p3+1, nil) - [s1, s2, s3, s4] - -mkRepititionAssoc l == - mkRepfun(l,1) where - mkRepfun(l,n) == - null l => nil - l is [x] => [[n,:x]] - l is [x, =x,:l'] => mkRepfun(rest l,n+1) - [[n,:first l],:mkRepfun(rest l,1)] - -encodeItem x == - x is [op,:argl] => getCaps op - IDENTP x => PNAME x - STRINGIMAGE x - -getCaps x == - s:= STRINGIMAGE x - clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] - null clist => '"__" - "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] - ---% abbreviation code - -getAbbreviation(name,c) == - --returns abbreviation of name with c arguments - x := constructor? name - X := ASSQ(x,$abbreviationTable) => - N:= ASSQ(name,rest X) => - C:= ASSQ(c,rest N) => rest C --already there - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest N,[[c,:newAbbreviation],:rest N]) - newAbbreviation - newAbbreviation:= mkAbbrev(X,x) - RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) - newAbbreviation - $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] - x - -mkAbbrev(X,x) == addSuffix(alistSize rest X,x) - -alistSize c == - count(c,1) where - count(x,level) == - level=2 => #x - null x => 0 - count(CDAR x,level+1)+count(rest x,level) - -addSuffix(n,u) == - ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) - INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) - - diff --git a/src/interp/package.boot.pamphlet b/src/interp/package.boot.pamphlet new file mode 100644 index 00000000..f97f86ac --- /dev/null +++ b/src/interp/package.boot.pamphlet @@ -0,0 +1,300 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/package.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +isPackageFunction() == + -- called by compile/putInLocalDomainReferences +--+ + nil + +processFunctorOrPackage(form,signature,data,localParList,m,e) == +--+ + processFunctor(form,signature,data,localParList,e) + +processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) == + $GENNO: local:= 0 --for GENVAR() + $catsig: local + --used in ProcessCond + $maximalViews: local + --read by ProcessCond + $ResetItems: local + --stores those items that get SETQed, and may need re-processing + $catvecList: local:= [$domainShell] + $catNames: local:= ["$"] +--PRINT $definition +--PRINT ($catsig,:argssig) +--PRETTYPRINT code + catvec:= $domainShell --from compDefineFunctor + $getDomainCode:= optFunctorBody $getDomainCode + --the purpose of this is so ProcessCond recognises such items + code:= PackageDescendCode(code,true,nil) + if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where + setPackageCode locals == + locals':=[[u,:i] for u in locals for i in 0.. | u] + locals'' :=[] + while locals' repeat + for v in locals' repeat + [u,:i]:=v + if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals'] + then + locals'':=[v,:locals''] + locals':=delete(v,locals') + precomp:=code:=[] + for elem in locals'' repeat + [u,:i]:=elem + if ATOM u then u':=u + else + u':=opt(u,precomp) where + opt(u,alist) == + ATOM u => u + for v in u repeat + if (a:=ASSOC(v,alist)) then + [.,:i]:=a + u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where + replace(old,new,l) == + l isnt [h,:t] => l + h = old => [new,:t] + [h,:replace(old,new,t)] + v':=opt(v,alist) + EQ(v,v') => nil + u:=replace(v,v',u) + u + precomp:=[elem,:precomp] + code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code] + nreverse code + code:= + ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]], + --It is important to place this code here, + --after $ is set up + --slam functor with shell + --the order of steps in this PROGN are critical + addToSlam($definition,"$"),code,[ + "SETELT","$",0, mkDomainConstructor $definition],: +-- If we call addMutableArg this early, then recurise calls to this domain +-- (e.g. while testing predicates) will generate new domains => trouble +-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],: + [["SETELT","$",position(name,locals),name] + for name in $ResetItems | MEMQ(name,locals)], + :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0)) + (LIST (GENSYM)));[]) ], + "$"] + for u in $getDomainCode repeat + u is ['LET,.,u'] and u' is ['getDomainView,.,u''] => + $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed) + $packagesUsed:=union($functorLocalParameters,$packagesUsed) + $getDomainCode:= nil + --if we didn't kill this, DEFINE would insert it in the wrong place + optFunctorBody code + +subTree(u,v) == + v=u => true + ATOM v => nil + or/[subTree(u,v') for v' in v] + +mkList u == + u => ["LIST",:u] + nil + +setPackageLocals(pac,locs) == + for var in locs for i in 0.. | var^=nil repeat pac.i:= var + +PackageDescendCode(code,flag,viewAssoc) == + --flag is true if we are walking down code always executed + --nil if we are in conditional code + code=nil => nil + code="noBranch" => nil + code is ["add",base,:codelist] => + systemError '"packages may not have add clauses" + code is ["PROGN",:codelist] => + ["PROGN",: + [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]] + code is ["COND",:condlist] => + c:= + ["COND",: + [[u2:= ProcessCond(first u,viewAssoc),: + (if null u2 + then nil + else + [PackageDescendCode(v,flag and TruthP u2, + if first u is ["HasCategory",dom,cat] + then [[dom,:cat],:viewAssoc] + else viewAssoc) for v in rest u])] for u in condlist]] + TruthP CAADR c => ["PROGN",:CDADR c] + c + code is ["LET",name,body,:.] => + if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems] + if body is [a,:.] and isFunctor a + then $packagesUsed:=[body,:$packagesUsed] + code + code is ["CodeDefine",sig,implem] => + --Generated by doIt in COMPILER BOOT + dom:= "$" + dom:= + u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u] + dom + body:= ["CONS",implem,dom] + SetFunctionSlots(sig,body,flag,"original") + code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL)) + --Yes, I know that's a hack, but how else do you kill a line? + code is ["LIST",:.] => nil + code is ["MDEF",:.] => nil + code is ["devaluate",:.] => nil + code is ["call",:.] => code + code is ["SETELT",:.] => code + code is ["QSETREFV",:.] => code + stackWarning ["unknown Package code ",code] + code + +mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) == + domainOrPackage^="domain" => + [opSig,pred,["PAC","$",name]] where + name() == encodeFunctionName(op,domainOrPackage,sig,":",count) + null flag => [opSig,pred,["ELT","$",count]] + first flag="constant" => [[op,sig],pred,["CONST","$",count]] + systemError ["unknown variable mode: ",flag] + +optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) == + RPLACA(x,functionName) + RPLACD(x,[:arglist,packageVariableOrForm]) + x + +--% Code for encoding function names inside package or domain + +encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count) + == + signature':= substitute("$",package,signature) + reducedSig:= mkRepititionAssoc [:rest signature',first signature'] + encodedSig:= + ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where + encodedPair() == + n=1 => encodeItem x + STRCONC(STRINGIMAGE n,encodeItem x) + encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";", + encodeItem fun,";",encodedSig, sep,STRINGIMAGE count) + if $LISPLIB then + $lisplibSignatureAlist:= + [[encodedName,:signature'],:$lisplibSignatureAlist] + encodedName + +splitEncodedFunctionName(encodedName, sep) == + -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL + -- sep0 is the separator used in "encodeFunctionName". + sep0 := '";" + if not STRINGP encodedName then + encodedName := STRINGIMAGE encodedName + null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil + null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner +-- This is picked up in compile for inner functions in partial compilation + null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil + s1 := SUBSTRING(encodedName, 0, p1) + s2 := SUBSTRING(encodedName, p1+1, p2-p1-1) + s3 := SUBSTRING(encodedName, p2+1, p3-p2-1) + s4 := SUBSTRING(encodedName, p3+1, nil) + [s1, s2, s3, s4] + +mkRepititionAssoc l == + mkRepfun(l,1) where + mkRepfun(l,n) == + null l => nil + l is [x] => [[n,:x]] + l is [x, =x,:l'] => mkRepfun(rest l,n+1) + [[n,:first l],:mkRepfun(rest l,1)] + +encodeItem x == + x is [op,:argl] => getCaps op + IDENTP x => PNAME x + STRINGIMAGE x + +getCaps x == + s:= STRINGIMAGE x + clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)] + null clist => '"__" + "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]] + +--% abbreviation code + +getAbbreviation(name,c) == + --returns abbreviation of name with c arguments + x := constructor? name + X := ASSQ(x,$abbreviationTable) => + N:= ASSQ(name,rest X) => + C:= ASSQ(c,rest N) => rest C --already there + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest N,[[c,:newAbbreviation],:rest N]) + newAbbreviation + newAbbreviation:= mkAbbrev(X,x) + RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X]) + newAbbreviation + $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] + x + +mkAbbrev(X,x) == addSuffix(alistSize rest X,x) + +alistSize c == + count(c,1) where + count(x,level) == + level=2 => #x + null x => 0 + count(CDAR x,level+1)+count(rest x,level) + +addSuffix(n,u) == + ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n) + INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/packtran.boot b/src/interp/packtran.boot deleted file mode 100644 index 9634b9b6..00000000 --- a/src/interp/packtran.boot +++ /dev/null @@ -1,60 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- The $useNewParser flag controls which parser will be used in the interpreter --- If nil then the old parser is used, otherwise Bill Burge's parser is used -$useNewParser := true - -rePackageTran(sex, package) == - _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package - packageTran sex - -packageTran sex == --- destructively translate all the symbols in the given s-expression to the --- current package - SYMBOLP sex => - EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex - INTERN STRING sex - CONSP sex => - RPLACA(sex, packageTran CAR sex) - RPLACD(sex, packageTran CDR sex) - sex - sex - -zeroOneTran sex == --- destructively translate the symbols |0| and |1| to their --- integer counterparts - NSUBST("$EmptyMode", "?", sex) - sex - diff --git a/src/interp/packtran.boot.pamphlet b/src/interp/packtran.boot.pamphlet new file mode 100644 index 00000000..b1814ddf --- /dev/null +++ b/src/interp/packtran.boot.pamphlet @@ -0,0 +1,86 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp packtran.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- The $useNewParser flag controls which parser will be used in the interpreter +-- If nil then the old parser is used, otherwise Bill Burge's parser is used +$useNewParser := true + +rePackageTran(sex, package) == + _*PACKAGE_* : fluid := FIND_-PACKAGE STRING package + packageTran sex + +packageTran sex == +-- destructively translate all the symbols in the given s-expression to the +-- current package + SYMBOLP sex => + EQ(_*PACKAGE_*, SYMBOL_-PACKAGE sex) => sex + INTERN STRING sex + CONSP sex => + RPLACA(sex, packageTran CAR sex) + RPLACD(sex, packageTran CDR sex) + sex + sex + +zeroOneTran sex == +-- destructively translate the symbols |0| and |1| to their +-- integer counterparts + NSUBST("$EmptyMode", "?", sex) + sex + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/pathname.boot b/src/interp/pathname.boot deleted file mode 100644 index f10cf327..00000000 --- a/src/interp/pathname.boot +++ /dev/null @@ -1,143 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- This file implements the Common Lisp pathname functions for --- Lisp/VM. On VM, a filename is 3-list consisting of the filename, --- filetype and filemode. We also UPCASE everything. - --- This file also contains some other VM specific functions for --- dealing with files. - ---% Common Lisp Pathname Functions - -pathname? p == p=[] or PATHNAMEP p - -pathname p == - p = [] => p - PATHNAMEP p => p - not PAIRP p => PATHNAME p - if #p>2 then p:=[p.0,p.1] - PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) - -namestring p == NAMESTRING pathname p - -pathnameName p == PATHNAME_-NAME pathname p - -pathnameType p == PATHNAME_-TYPE pathname p - -pathnameTypeId p == UPCASE object2Identifier pathnameType p - -pathnameDirectory p == - NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) - -deleteFile f == _$ERASE pathname f - -isExistingFile f == --- p := pathname f - --member(p,$existingFiles) => true - if MAKE_-INPUT_-FILENAME f - then - --$existingFiles := [p,:$existingFiles] - true - else false - ---% Scratchpad II File Name Functions - -makePathname(name,type,dir) == - -- Common Lisp version of this will have to be written - -- using MAKE-PATHNAME and the optional args. - pathname [object2String name,object2String type] - -mergePathnames(a,b) == - (fn := pathnameName(a)) = '"*" => b - fn ^= pathnameName(b) => a - (ft := pathnameType(a)) = '"*" => b - ft ^= pathnameType(b) => a - (fm := pathnameDirectory(a)) = ['"*"] => b - a - -isSystemDirectory dir == EVERY(function CHAR_=,$SPADROOT,dir) - --- the next function is an improved version of the one in DEBUG LISP - -_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) - -newMKINFILENAM(infile) == - NULL infile => nil - file := infile := pathname infile - repeat - fn := pathnameName file - nfile := $FINDFILE (file,$sourceFileTypes) - null nfile => - nfile := file - if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) - else sayKeyedMsg("S2IL0003",[namestring file]) - ans := queryUserKeyedMsg("S2IL0017",NIL) - if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 - else n := 1 - nfn := UPCASE STRING2ID_-N(ans,n) - (nfn = 0) or (nfn = 'QUIT) => - sayKeyedMsg("S2IL0018",NIL) - THROW('FILENAM,NIL) - nfn = 'CREATE => return 'fromThisLoop - file := pathname ans - return 'fromThisLoop - if nfile then pathname nfile - else NIL - - -getFunctionSourceFile fun == - null (f := getFunctionSourceFile1 fun) => NIL - if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f - f - -getFunctionSourceFile1 fun == - -- returns NIL or [fn,ft,fm] - (file := KDR GETL(fun,'DEFLOC)) => pathname file - null ((fileinfo := FUNLOC fun) or - (fileinfo := FUNLOC unabbrev fun)) => - u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) - NIL - 3 = #fileinfo => - [fn,ft,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn,ft] - [fn,$FUNCTION] := fileinfo - newMKINFILENAM pathname [fn] - -updateSourceFiles p == - p := pathname p - p := pathname [pathnameName p, pathnameType p, '"*"] - if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then - $sourceFiles := insert(p, $sourceFiles) - p diff --git a/src/interp/pathname.boot.pamphlet b/src/interp/pathname.boot.pamphlet new file mode 100644 index 00000000..300d2c41 --- /dev/null +++ b/src/interp/pathname.boot.pamphlet @@ -0,0 +1,165 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pathname.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- This file implements the Common Lisp pathname functions for +-- Lisp/VM. On VM, a filename is 3-list consisting of the filename, +-- filetype and filemode. We also UPCASE everything. + +-- This file also contains some other VM specific functions for +-- dealing with files. + +--% Common Lisp Pathname Functions + +pathname? p == p=[] or PATHNAMEP p + +pathname p == + p = [] => p + PATHNAMEP p => p + not PAIRP p => PATHNAME p + if #p>2 then p:=[p.0,p.1] + PATHNAME APPLY(FUNCTION MAKE_-FILENAME, p) + +namestring p == NAMESTRING pathname p + +pathnameName p == PATHNAME_-NAME pathname p + +pathnameType p == PATHNAME_-TYPE pathname p + +pathnameTypeId p == UPCASE object2Identifier pathnameType p + +pathnameDirectory p == + NAMESTRING MAKE_-PATHNAME(LispKeyword '"DIRECTORY",PATHNAME_-DIRECTORY pathname p) + +deleteFile f == _$ERASE pathname f + +isExistingFile f == +-- p := pathname f + --member(p,$existingFiles) => true + if MAKE_-INPUT_-FILENAME f + then + --$existingFiles := [p,:$existingFiles] + true + else false + +--% Scratchpad II File Name Functions + +makePathname(name,type,dir) == + -- Common Lisp version of this will have to be written + -- using MAKE-PATHNAME and the optional args. + pathname [object2String name,object2String type] + +mergePathnames(a,b) == + (fn := pathnameName(a)) = '"*" => b + fn ^= pathnameName(b) => a + (ft := pathnameType(a)) = '"*" => b + ft ^= pathnameType(b) => a + (fm := pathnameDirectory(a)) = ['"*"] => b + a + +isSystemDirectory dir == EVERY(function CHAR_=,$SPADROOT,dir) + +-- the next function is an improved version of the one in DEBUG LISP + +_/MKINFILENAM(infile) == CATCH('FILNAM, newMKINFILENAM infile) + +newMKINFILENAM(infile) == + NULL infile => nil + file := infile := pathname infile + repeat + fn := pathnameName file + nfile := $FINDFILE (file,$sourceFileTypes) + null nfile => + nfile := file + if fn = '"*" or fn = '"NIL" then sayKeyedMsg("S2IL0016",NIL) + else sayKeyedMsg("S2IL0003",[namestring file]) + ans := queryUserKeyedMsg("S2IL0017",NIL) + if (SIZE(ans) > 0) and ('")" = SUBSTRING(ans,0,1)) then n := 2 + else n := 1 + nfn := UPCASE STRING2ID_-N(ans,n) + (nfn = 0) or (nfn = 'QUIT) => + sayKeyedMsg("S2IL0018",NIL) + THROW('FILENAM,NIL) + nfn = 'CREATE => return 'fromThisLoop + file := pathname ans + return 'fromThisLoop + if nfile then pathname nfile + else NIL + + +getFunctionSourceFile fun == + null (f := getFunctionSourceFile1 fun) => NIL + if MAKE_-INPUT_-FILENAME(f) then updateSourceFiles f + f + +getFunctionSourceFile1 fun == + -- returns NIL or [fn,ft,fm] + (file := KDR GETL(fun,'DEFLOC)) => pathname file + null ((fileinfo := FUNLOC fun) or + (fileinfo := FUNLOC unabbrev fun)) => + u := bootFind fun => getFunctionSourceFile1 SETQ($FUNCTION,INTERN u) + NIL + 3 = #fileinfo => + [fn,ft,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn,ft] + [fn,$FUNCTION] := fileinfo + newMKINFILENAM pathname [fn] + +updateSourceFiles p == + p := pathname p + p := pathname [pathnameName p, pathnameType p, '"*"] + if MAKE_-INPUT_-FILENAME p and pathnameTypeId p in '(BOOT LISP META) then + $sourceFiles := insert(p, $sourceFiles) + p +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/pf2atree.boot b/src/interp/pf2atree.boot deleted file mode 100644 index 0ea1cf7f..00000000 --- a/src/interp/pf2atree.boot +++ /dev/null @@ -1,553 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- not hooked in yet - --- BB parser tree to interpreter vectorized attributed trees. --- Used to interface the BB parser --- technology to the interpreter. The input is a parseTree and the --- output is an interpreter attributed tree. - -SETANDFILEQ($useParserSrcPos, true) -SETANDFILEQ($transferParserSrcPos, true) - -pf2Sexpr pf == packageTran (pf2Sex1)(pf) - -pf2Atree pf == - (intUnsetQuiet)() - - $insideRule: local := false - $insideApplication: local := false - $insideSEQ: local := false - - -- we set the following because we will be using some things - -- within pf2sex.boot and they are in the spadcomp package. - - ($insideRule): local := false - ($insideApplication): local := false - ($insideSEQ): local := false - - pf2Atree1 pf - -pf2Atree1 pf == - -- some simple things that are really just S-expressions - - (pfNothing?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfSymbol?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfLiteral?)(pf) => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - (pfId?) pf => - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - - -- Now some compound forms - - (pfApplication?)(pf) => - pfApplication2Atree pf - - (pfTuple?)(pf) => - [mkAtreeNodeWithSrcPos("Tuple",pf), - :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] - - (pfIf?)(pf) => - condPf := (pfIfCond)(pf) - condPart := pf2Atree1 condPf - thenPart := pf2Atree1 (pfIfThen)(pf) - elsePart := pf2Atree1 (pfIfElse)(pf) - ifPart := mkAtreeNodeWithSrcPos("IF", pf) - thenPart = "noBranch" => - [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], - elsePart, thenPart] - [ifPart, condPart, thenPart, elsePart] - - (pfTagged?)(pf) => - tag := (pfTaggedTag)(pf) - tagPart := - (pfTuple?) tag => - ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] - pf2Sexpr(tag) - [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, - pf2Sexpr((pfTaggedExpr)(pf))] - - (pfCoerceto?)(pf) => - [mkAtreeNodeWithSrcPos("COERCE",pf), - pf2Atree1 (pfCoercetoExpr)(pf), - pf2Sexpr((pfCoercetoType)(pf))] - - (pfPretend?)(pf) => - [mkAtreeNodeWithSrcPos("pretend",pf), - pf2Atree1 (pfPretendExpr)(pf), - pf2Sexpr((pfPretendType)(pf))] - - (pfFromdom?)(pf) => - op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) - if op = "braceFromCurly" then op := "SEQ" -- ?? - - op = 0 => - -- 0$Foo => Zero()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("Zero",pf)]] - op = 1 => - -- 1$Foo => One()$Foo - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]] - INTEGERP op => - -- n$Foo => n * One()$Foo - [mkAtreeNodeWithSrcPos("*",pf), - mkAtree1WithSrcPos(op,pf), - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - [mkAtreeNodeWithSrcPos("One",pf)]]] - - [mkAtreeNodeWithSrcPos("Dollar",pf), - pf2Sexpr((pfFromdomDomain)(pf)), - mkAtreeNodeWithSrcPos(op,pf)] - - (pfSequence?)(pf) => - pfSequence2Atree pf - - (pfExit?)(pf) => - $insideSEQ => - [mkAtreeNodeWithSrcPos("exit",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf)] - [mkAtreeNodeWithSrcPos("IF",pf), - pf2Atree1 (pfExitCond)(pf), - pf2Atree1 (pfExitExpr)(pf), "noBranch"] - - (pfLoop?)(pf) => - [mkAtreeNodeWithSrcPos("REPEAT",pf), - :loopIters2Atree (pf0LoopIterators)(pf)] - - (pfCollect?)(pf) => - pfCollect2Atree(pf) - - (pfForin?)(pf) => - ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], - pf2Atree1 (pfForinWhole)(pf)] - - (pfWhile?)(pf) => - ["WHILE", pf2Atree1((pfWhileCond)(pf))] - - (pfSuchthat?)(pf) => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) - ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] - - (pfDo?)(pf) => - pf2Atree1 (pfDoBody)(pf) - --- (pfTyped?)(pf) => --- type := pfTypedType pf --- pfNothing? type => pf2Atree1 pfTypedId pf --- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] - - (pfAssign?)(pf) => - -- declarations on the lhs are broken out into another - -- statement preceding the LET of the id(s) - lhsThings := (pf0AssignLhsItems)(pf) - if #lhsThings = 1 and (pfTuple?)(first lhsThings) then - lhsThings := (pf0TupleParts)(first lhsThings) - decls := nil - ids := nil - for x in lhsThings repeat - (pfTagged?)(x) => - decls := [x, :decls] - ids := [(pfTaggedTag)(x), :ids] - ids := [x, :ids] - idList := [pf2Atree1 x for x in reverse ids] - if #idList ^= 1 then idList := - [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] - else idList := first idList - x := [mkAtreeNodeWithSrcPos("LET",pf), - idList, pf2Atree1 (pfAssignRhs)(pf)] - decls => - [mkAtreeNodeWithSrcPos("SEQ",pf), - :[pf2Atree1 decl for decl in nreverse decls], x] - x - --- (pfDefinition?)(pf) => --- pfDefinition2Atree pf - --- (pfLambda?)(pf) => --- pfLambda2Atree pf --- (pfRestrict?)(pf) => --- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] - - (pfFree?)(pf) => - [mkAtreeNodeWithSrcPos("free",pf), - :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] - (pfLocal?)(pf) => - [mkAtreeNodeWithSrcPos("local",pf), - :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] - - (pfWrong?)(pf) => - spadThrow() - - -- next 3 are probably be handled in pfApplication2Atree - - (pfAnd?)(pf) => - [mkAtreeNodeWithSrcPos("and",pf), - pf2Atree1 (pfAndLeft)(pf), - pf2Atree1 (pfAndRight)(pf)] - (pfOr?)(pf) => - [mkAtreeNodeWithSrcPos("or",pf), - pf2Atree1 (pfOrLeft)(pf), - pf2Atree1 (pfOrRight)(pf)] - (pfNot?)(pf) => - [mkAtreeNodeWithSrcPos("not",pf), - pf2Atree1 (pfNotArg)(pf)] - --- (pfNovalue?)(pf) => --- intSetQuiet() --- ["SEQ", pf2Atree1 pfNovalueExpr pf] --- (pfRule?)(pf) => --- pfRule2Atree pf - - (pfBreak?)(pf) => - [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] - - (pfMacro?)(pf) => - tree := mkAtree1WithSrcPos('(void), pf) - putValue(tree,objNewWrap(voidValue(),$Void)) - putModeSet(tree,[$Void]) - tree - - (pfReturn?)(pf) => - [mkAtreeNodeWithSrcPos("return",pf), - pf2Atree1 (pfReturnExpr)(pf)] - - (pfIterate?)(pf) => - [mkAtreeNodeWithSrcPos("iterate",pf)] - --- (pfWhere?)(pf) => --- args := [pf2Atree1 p for p in pf0WhereContext pf] --- #args = 1 => --- ["where", pf2Atree1 pfWhereExpr pf, :args] --- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] - - mkAtree1WithSrcPos(pf2Sexpr(pf), pf) - --- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) --- - -pfApplication2Atree pf == - $insideApplication: local := true - ($insideApplication): local := true - - opPf := (pfApplicationOp)(pf) - op := packageTran ((opTran)(pfOp2Sex)(opPf)) - op = "->" => - args := (pf0TupleParts)((pfApplicationArg)(pf)) - if (pfTuple?)(CAR args) then - typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] - else - typeList := [pf2Atree1 CAR args] - args := [pf2Atree1 CADR args, :typeList] - [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] - - (symEqual)(op, '":") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("multiple",opPf), - pf2Atree (pfApplicationArg)(pf)] - - (symEqual)(op, '"?") and $insideRule = 'left => - [mkAtreeNodeWithSrcPos("optional",opPf), - pf2Atree (pfApplicationArg)(pf)] - - args := (pfApplicationArg)(pf) - - (pfTuple?)(args) => ---! symEqual(op, '"|") and $insideRule = 'left => ---! pfSuchThat2Atree args - argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] - - (symEqual)(op, '">") => - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] - (symEqual)(op, '">=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] - (symEqual)(op, '"<=") => - [mkAtreeNodeWithSrcPos("not",opPf), - [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] - (symEqual)(op, '"AND") => - [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] - (symEqual)(op, '"OR") => - [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] - (symEqual) (op, '"Iterate") => - [mkAtreeNodeWithSrcPos("iterate",opPf)] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] - (symEqual)(op, '"braceFromCurly") => - argAtree and getUnname first argAtree = "SEQ" => argAtree - [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), :argAtree] ---! val := (hasOptArgs?)(argSex) => [op, :val] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] - - op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => - [mkAtreeNodeWithSrcPos("applyQuote",opPf), - mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - (symEqual)(op, '"braceFromCurly") => - x := pf2Atree1 args - x and getUnname x = "SEQ" => x - [mkAtreeNodeWithSrcPos("SEQ",opPf), x] - (symEqual)(op, '"by") => - [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] - -- handle package call - (pfFromdom?)(opPf) => - opAtree := pf2Atree1 opPf - [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] - -- regular call - [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] - --- pfDefinition2Atree pf == --- --! $insideApplication => --- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, --- --! pf2Atree1 pfDefinitionRhs pf] --- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] --- #idList ^= 1 => --- systemError '"lhs of definition must be a single item in the interpreter" --- id := first idList --- rhs := (pfDefinitionRhs)(pf) --- [argList, :body] := pfLambdaTran rhs --- ["DEF", (argList = 'id => id; [id, :argList]), :body] - --- pfLambdaTran pf == --- pfLambda? pf => --- argTypeList := nil --- argList := nil --- for arg in pf0LambdaArgs pf repeat --- pfTyped? arg => --- argList := [pfCollectArgTran pfTypedId arg, :argList] --- pfNothing? pfTypedType arg => --- argTypeList := [nil, :argTypeList] --- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] --- systemError '"definition args should be typed" --- argList := nreverse argList --- retType := --- pfNothing? pfLambdaRets pf => nil --- pf2Atree1 pfLambdaRets pf --- argTypeList := [retType, :nreverse argTypeList] --- [argList, :[argTypeList, [nil for arg in argTypeList], --- pf2Atree1 pfLambdaBody pf]] --- ['id, :['(()), '(()), pf2Atree1 pf]] --- --- pfLambda2Atree pf == --- [argList, :body] := pfLambdaTran pf --- ["ADEF", argList, :body] --- --- pfCollectArgTran pf == --- pfCollect? pf => --- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] --- id := pf2Atree1 pfCollectBody pf --- conds is [["|", cond]] => --- ["|", id, cond] --- [id, :conds] --- pf2Atree1 pf --- - -pfSequence2Atree pf == - $insideSEQ: local := true - ($insideSEQ): local := true - - seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) - seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) - seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - [mkAtreeNodeWithSrcPos("ruleset",pf), - [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] - seq - -pfSequence2Atree0(seqList, pf) == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => - item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, - pfSequence2Atree0(rest seqList, pf)] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] - --- --- float2Atree num == --- eIndex := SEARCH('"e", num) --- mantPart := --- eIndex => SUBSEQ(num, 0, eIndex) --- num --- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) --- dotIndex := SEARCH('".", mantPart) --- intPart := --- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) --- READ_-FROM_-STRING mantPart --- fracPartString := --- dotIndex => SUBSEQ(mantPart, dotIndex+1) --- '"0" --- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, --- LENGTH fracPartString, expPart) --- [., frac, :exp] := bfForm --- [["$elt", intNewFloat(), 'float], frac, exp, 10] --- - -loopIters2Atree iterList == - -- could probably do a better job of getting accurate SrcPos info onto parts - result := nil - for iter in iterList repeat - -- ON and UNTIL forms are no longer supported - sex := pf2Sexpr(iter) - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter)] - result := [newIter, :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), - mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] - result := [newIter, :result] - sex is ['IN, var, s] => - newIter := ["IN", var, mkAtree1 s] - result := [newIter, :result] - result := [pf2Atree1(iter), :result] - nreverse result - -pfCollect2Atree pf == - atree := [mkAtree1WithSrcPos("COLLECT",pf), - :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), - pf2Atree1 (pfCollectBody)(pf)] - - -- next are for what appears to a parser screw-up - sex := ["COLLECT", - :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), - pf2Sexpr (pfCollectBody)(pf)] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - [., [., condAtree], varAtree] := atree - ["SUCHTHAT", varAtree, condAtree] - - atree - --- --- pfRule2Atree pf == --- $quotedOpList:local := nil --- $predicateList:local := nil --- $multiVarPredicateList:local := nil --- lhs := pfLhsRule2Atree pfRuleLhsItems pf --- rhs := pfRhsRule2Atree pfRuleRhs pf --- lhs := ruleLhsTran lhs --- rulePredicateTran --- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] --- ["rule", lhs, rhs] --- --- --- ruleLhsTran ruleLhs == --- for pred in $predicateList repeat --- [name, predLhs, :predRhs] := pred --- vars := patternVarsOf predRhs --- CDR vars => -- if there is more than one patternVariable --- ruleLhs := NSUBST(predLhs, name, ruleLhs) --- $multiVarPredicateList := [pred, :$multiVarPredicateList] --- predicate := --- [., var] := predLhs --- ["suchThat", predLhs, ["ADEF", [var], --- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] --- ruleLhs := NSUBST(predicate, name, ruleLhs) --- ruleLhs --- --- rulePredicateTran rule == --- null $multiVarPredicateList => rule --- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] --- predBody := --- CDR $multiVarPredicateList => --- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in --- $multiVarPredicateList]] --- [[.,.,:rhs],:.] := $multiVarPredicateList --- pvarPredTran(rhs, varList) --- ['suchThat, rule, --- ['construct, :[["QUOTE", var] for var in varList]], --- ['ADEF, '(predicateVariable), --- '((Boolean) (List (Expression (Integer)))), '(() ()), --- predBody]] --- --- pvarPredTran(rhs, varList) == --- for var in varList for i in 1.. repeat --- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) --- rhs --- --- patternVarsOf expr == --- patternVarsOf1(expr, nil) --- --- patternVarsOf1(expr, varList) == --- NULL expr => varList --- ATOM expr => --- null SYMBOLP expr => varList --- SymMemQ(expr, varList) => varList --- [expr, :varList] --- expr is [op, :argl] => --- for arg in argl repeat --- varList := patternVarsOf1(arg, varList) --- varList --- varList --- --- pfLhsRule2Atree lhs == --- $insideRule: local := 'left --- ($insideRule): local := 'left --- pf2Atree1 lhs --- --- --- pfRhsRule2Atree rhs == --- $insideRule: local := 'right --- ($insideRule): local := 'right --- pf2Atree1 rhs --- - --- pfSuchThat2Atree args == --- name := GENTEMP() --- argList := pf0TupleParts args --- lhsSex := pf2Atree1 CAR argList --- rhsSex := pf2Atree CADR argList --- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] --- name diff --git a/src/interp/pf2atree.boot.pamphlet b/src/interp/pf2atree.boot.pamphlet new file mode 100644 index 00000000..29e85ad1 --- /dev/null +++ b/src/interp/pf2atree.boot.pamphlet @@ -0,0 +1,575 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pf2atree.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- not hooked in yet + +-- BB parser tree to interpreter vectorized attributed trees. +-- Used to interface the BB parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an interpreter attributed tree. + +SETANDFILEQ($useParserSrcPos, true) +SETANDFILEQ($transferParserSrcPos, true) + +pf2Sexpr pf == packageTran (pf2Sex1)(pf) + +pf2Atree pf == + (intUnsetQuiet)() + + $insideRule: local := false + $insideApplication: local := false + $insideSEQ: local := false + + -- we set the following because we will be using some things + -- within pf2sex.boot and they are in the spadcomp package. + + ($insideRule): local := false + ($insideApplication): local := false + ($insideSEQ): local := false + + pf2Atree1 pf + +pf2Atree1 pf == + -- some simple things that are really just S-expressions + + (pfNothing?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfSymbol?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfLiteral?)(pf) => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + (pfId?) pf => + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + + -- Now some compound forms + + (pfApplication?)(pf) => + pfApplication2Atree pf + + (pfTuple?)(pf) => + [mkAtreeNodeWithSrcPos("Tuple",pf), + :[pf2Atree1 x for x in (pf0TupleParts)(pf)]] + + (pfIf?)(pf) => + condPf := (pfIfCond)(pf) + condPart := pf2Atree1 condPf + thenPart := pf2Atree1 (pfIfThen)(pf) + elsePart := pf2Atree1 (pfIfElse)(pf) + ifPart := mkAtreeNodeWithSrcPos("IF", pf) + thenPart = "noBranch" => + [ifPart, [mkAtreeNodeWithSrcPos("not", condPf), condPart], + elsePart, thenPart] + [ifPart, condPart, thenPart, elsePart] + + (pfTagged?)(pf) => + tag := (pfTaggedTag)(pf) + tagPart := + (pfTuple?) tag => + ["Tuple", :[pf2Sexpr(arg) for arg in (pf0TupleParts)(tag)]] + pf2Sexpr(tag) + [mkAtreeNodeWithSrcPos("Declare",pf), tagPart, + pf2Sexpr((pfTaggedExpr)(pf))] + + (pfCoerceto?)(pf) => + [mkAtreeNodeWithSrcPos("COERCE",pf), + pf2Atree1 (pfCoercetoExpr)(pf), + pf2Sexpr((pfCoercetoType)(pf))] + + (pfPretend?)(pf) => + [mkAtreeNodeWithSrcPos("pretend",pf), + pf2Atree1 (pfPretendExpr)(pf), + pf2Sexpr((pfPretendType)(pf))] + + (pfFromdom?)(pf) => + op := packageTran (opTran)(pf2Sexpr((pfFromdomWhat)(pf))) + if op = "braceFromCurly" then op := "SEQ" -- ?? + + op = 0 => + -- 0$Foo => Zero()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("Zero",pf)]] + op = 1 => + -- 1$Foo => One()$Foo + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]] + INTEGERP op => + -- n$Foo => n * One()$Foo + [mkAtreeNodeWithSrcPos("*",pf), + mkAtree1WithSrcPos(op,pf), + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + [mkAtreeNodeWithSrcPos("One",pf)]]] + + [mkAtreeNodeWithSrcPos("Dollar",pf), + pf2Sexpr((pfFromdomDomain)(pf)), + mkAtreeNodeWithSrcPos(op,pf)] + + (pfSequence?)(pf) => + pfSequence2Atree pf + + (pfExit?)(pf) => + $insideSEQ => + [mkAtreeNodeWithSrcPos("exit",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf)] + [mkAtreeNodeWithSrcPos("IF",pf), + pf2Atree1 (pfExitCond)(pf), + pf2Atree1 (pfExitExpr)(pf), "noBranch"] + + (pfLoop?)(pf) => + [mkAtreeNodeWithSrcPos("REPEAT",pf), + :loopIters2Atree (pf0LoopIterators)(pf)] + + (pfCollect?)(pf) => + pfCollect2Atree(pf) + + (pfForin?)(pf) => + ["IN", :[pf2Atree1 x for x in (pf0ForinLhs)(pf)], + pf2Atree1 (pfForinWhole)(pf)] + + (pfWhile?)(pf) => + ["WHILE", pf2Atree1((pfWhileCond)(pf))] + + (pfSuchthat?)(pf) => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Atree1: pfSuchThat"]) + ["SUCHTHAT", pf2Atree1 (pfSuchthatCond)(pf)] + + (pfDo?)(pf) => + pf2Atree1 (pfDoBody)(pf) + +-- (pfTyped?)(pf) => +-- type := pfTypedType pf +-- pfNothing? type => pf2Atree1 pfTypedId pf +-- [":", pf2Atree1 pfTypedId pf, pf2Atree1 pfTypedType pf] + + (pfAssign?)(pf) => + -- declarations on the lhs are broken out into another + -- statement preceding the LET of the id(s) + lhsThings := (pf0AssignLhsItems)(pf) + if #lhsThings = 1 and (pfTuple?)(first lhsThings) then + lhsThings := (pf0TupleParts)(first lhsThings) + decls := nil + ids := nil + for x in lhsThings repeat + (pfTagged?)(x) => + decls := [x, :decls] + ids := [(pfTaggedTag)(x), :ids] + ids := [x, :ids] + idList := [pf2Atree1 x for x in reverse ids] + if #idList ^= 1 then idList := + [mkAtreeNodeWithSrcPos("Tuple",pf), :idList] + else idList := first idList + x := [mkAtreeNodeWithSrcPos("LET",pf), + idList, pf2Atree1 (pfAssignRhs)(pf)] + decls => + [mkAtreeNodeWithSrcPos("SEQ",pf), + :[pf2Atree1 decl for decl in nreverse decls], x] + x + +-- (pfDefinition?)(pf) => +-- pfDefinition2Atree pf + +-- (pfLambda?)(pf) => +-- pfLambda2Atree pf +-- (pfRestrict?)(pf) => +-- ["@", pf2Atree1 pfRestrictExpr pf, pf2Atree1 pfRestrictType pf] + + (pfFree?)(pf) => + [mkAtreeNodeWithSrcPos("free",pf), + :[pf2Atree1 item for item in (pf0FreeItems)(pf)]] + (pfLocal?)(pf) => + [mkAtreeNodeWithSrcPos("local",pf), + :[pf2Atree1 item for item in (pf0LocalItems)(pf)]] + + (pfWrong?)(pf) => + spadThrow() + + -- next 3 are probably be handled in pfApplication2Atree + + (pfAnd?)(pf) => + [mkAtreeNodeWithSrcPos("and",pf), + pf2Atree1 (pfAndLeft)(pf), + pf2Atree1 (pfAndRight)(pf)] + (pfOr?)(pf) => + [mkAtreeNodeWithSrcPos("or",pf), + pf2Atree1 (pfOrLeft)(pf), + pf2Atree1 (pfOrRight)(pf)] + (pfNot?)(pf) => + [mkAtreeNodeWithSrcPos("not",pf), + pf2Atree1 (pfNotArg)(pf)] + +-- (pfNovalue?)(pf) => +-- intSetQuiet() +-- ["SEQ", pf2Atree1 pfNovalueExpr pf] +-- (pfRule?)(pf) => +-- pfRule2Atree pf + + (pfBreak?)(pf) => + [mkAtreeNodeWithSrcPos("break",pf), (pfBreakFrom)(pf)] + + (pfMacro?)(pf) => + tree := mkAtree1WithSrcPos('(void), pf) + putValue(tree,objNewWrap(voidValue(),$Void)) + putModeSet(tree,[$Void]) + tree + + (pfReturn?)(pf) => + [mkAtreeNodeWithSrcPos("return",pf), + pf2Atree1 (pfReturnExpr)(pf)] + + (pfIterate?)(pf) => + [mkAtreeNodeWithSrcPos("iterate",pf)] + +-- (pfWhere?)(pf) => +-- args := [pf2Atree1 p for p in pf0WhereContext pf] +-- #args = 1 => +-- ["where", pf2Atree1 pfWhereExpr pf, :args] +-- ["where", pf2Atree1 pfWhereExpr pf, ["SEQ", :args]] + + mkAtree1WithSrcPos(pf2Sexpr(pf), pf) + +-- keyedSystemError('"S2GE0017", ['"pf2Atree1"]) +-- + +pfApplication2Atree pf == + $insideApplication: local := true + ($insideApplication): local := true + + opPf := (pfApplicationOp)(pf) + op := packageTran ((opTran)(pfOp2Sex)(opPf)) + op = "->" => + args := (pf0TupleParts)((pfApplicationArg)(pf)) + if (pfTuple?)(CAR args) then + typeList := [pf2Atree1 arg for arg in (pf0TupleParts)(CAR args)] + else + typeList := [pf2Atree1 CAR args] + args := [pf2Atree1 CADR args, :typeList] + [mkAtreeNodeWithSrcPos("Mapping", opPf), :args] + + (symEqual)(op, '":") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("multiple",opPf), + pf2Atree (pfApplicationArg)(pf)] + + (symEqual)(op, '"?") and $insideRule = 'left => + [mkAtreeNodeWithSrcPos("optional",opPf), + pf2Atree (pfApplicationArg)(pf)] + + args := (pfApplicationArg)(pf) + + (pfTuple?)(args) => +--! symEqual(op, '"|") and $insideRule = 'left => +--! pfSuchThat2Atree args + argAtree := [pf2Atree1 arg for arg in (pf0TupleParts)(args)] + + (symEqual)(op, '">") => + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)] + (symEqual)(op, '">=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :argAtree]] + (symEqual)(op, '"<=") => + [mkAtreeNodeWithSrcPos("not",opPf), + [mkAtreeNodeWithSrcPos("<",opPf), :reverse(argAtree)]] + (symEqual)(op, '"AND") => + [mkAtreeNodeWithSrcPos("and",opPf), :argAtree] + (symEqual)(op, '"OR") => + [mkAtreeNodeWithSrcPos("or",opPf), :argAtree] + (symEqual) (op, '"Iterate") => + [mkAtreeNodeWithSrcPos("iterate",opPf)] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), :argAtree] + (symEqual)(op, '"braceFromCurly") => + argAtree and getUnname first argAtree = "SEQ" => argAtree + [mkAtreeNodeWithSrcPos("SEQ",opPf), :argAtree] + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), :argAtree] +--! val := (hasOptArgs?)(argSex) => [op, :val] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, :argAtree]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), :argAtree] + + op is [qt, realOp] and (symEqual)(qt, '"QUOTE") => + [mkAtreeNodeWithSrcPos("applyQuote",opPf), + mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + (symEqual)(op, '"braceFromCurly") => + x := pf2Atree1 args + x and getUnname x = "SEQ" => x + [mkAtreeNodeWithSrcPos("SEQ",opPf), x] + (symEqual)(op, '"by") => + [mkAtreeNodeWithSrcPos("BY",opPf), pf2Atree1 args] + -- handle package call + (pfFromdom?)(opPf) => + opAtree := pf2Atree1 opPf + [CAR opAtree, CADR opAtree, [CADDR opAtree, pf2Atree1 args]] + -- regular call + [mkAtreeNodeWithSrcPos(op,opPf), pf2Atree1 args] + +-- pfDefinition2Atree pf == +-- --! $insideApplication => +-- --! ["OPTARG", pf2Atree1 CAR pf0DefinitionLhsItems pf, +-- --! pf2Atree1 pfDefinitionRhs pf] +-- idList := [pf2Atree1 x for x in (pf0DefinitionLhsItems)(pf)] +-- #idList ^= 1 => +-- systemError '"lhs of definition must be a single item in the interpreter" +-- id := first idList +-- rhs := (pfDefinitionRhs)(pf) +-- [argList, :body] := pfLambdaTran rhs +-- ["DEF", (argList = 'id => id; [id, :argList]), :body] + +-- pfLambdaTran pf == +-- pfLambda? pf => +-- argTypeList := nil +-- argList := nil +-- for arg in pf0LambdaArgs pf repeat +-- pfTyped? arg => +-- argList := [pfCollectArgTran pfTypedId arg, :argList] +-- pfNothing? pfTypedType arg => +-- argTypeList := [nil, :argTypeList] +-- argTypeList := [pf2Atree1 pfTypedType arg, :argTypeList] +-- systemError '"definition args should be typed" +-- argList := nreverse argList +-- retType := +-- pfNothing? pfLambdaRets pf => nil +-- pf2Atree1 pfLambdaRets pf +-- argTypeList := [retType, :nreverse argTypeList] +-- [argList, :[argTypeList, [nil for arg in argTypeList], +-- pf2Atree1 pfLambdaBody pf]] +-- ['id, :['(()), '(()), pf2Atree1 pf]] +-- +-- pfLambda2Atree pf == +-- [argList, :body] := pfLambdaTran pf +-- ["ADEF", argList, :body] +-- +-- pfCollectArgTran pf == +-- pfCollect? pf => +-- conds := [pf2Atree1 x for x in pfParts pfCollectIterators pf] +-- id := pf2Atree1 pfCollectBody pf +-- conds is [["|", cond]] => +-- ["|", id, cond] +-- [id, :conds] +-- pf2Atree1 pf +-- + +pfSequence2Atree pf == + $insideSEQ: local := true + ($insideSEQ): local := true + + seq := pfSequence2Atree0([pf2Atree1 x for x in (pf0SequenceArgs)(pf)], pf) + seqSex := (pfSequence2Sex0)([pf2Sexpr(x) for x in (pf0SequenceArgs)(pf)]) + seqSex is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + [mkAtreeNodeWithSrcPos("ruleset",pf), + [mkAtreeNodeWithSrcPos("construct",pf), :rest seq]] + seq + +pfSequence2Atree0(seqList, pf) == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is [exitVal, cond, value] and getUnname(exitVal) = "exit" => + item := [mkAtreeNodeWithSrcPos("IF",pf), cond, value, + pfSequence2Atree0(rest seqList, pf)] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + [mkAtreeNodeWithSrcPos("SEQ",pf), :nreverse seqTranList] + +-- +-- float2Atree num == +-- eIndex := SEARCH('"e", num) +-- mantPart := +-- eIndex => SUBSEQ(num, 0, eIndex) +-- num +-- expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) +-- dotIndex := SEARCH('".", mantPart) +-- intPart := +-- dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) +-- READ_-FROM_-STRING mantPart +-- fracPartString := +-- dotIndex => SUBSEQ(mantPart, dotIndex+1) +-- '"0" +-- bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, +-- LENGTH fracPartString, expPart) +-- [., frac, :exp] := bfForm +-- [["$elt", intNewFloat(), 'float], frac, exp, 10] +-- + +loopIters2Atree iterList == + -- could probably do a better job of getting accurate SrcPos info onto parts + result := nil + for iter in iterList repeat + -- ON and UNTIL forms are no longer supported + sex := pf2Sexpr(iter) + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter)] + result := [newIter, :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(incr, iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + newIter := ["STEP", var, mkAtree1WithSrcPos(i,iter), + mkAtree1WithSrcPos(1,iter), mkAtree1WithSrcPos(j,iter)] + result := [newIter, :result] + sex is ['IN, var, s] => + newIter := ["IN", var, mkAtree1 s] + result := [newIter, :result] + result := [pf2Atree1(iter), :result] + nreverse result + +pfCollect2Atree pf == + atree := [mkAtree1WithSrcPos("COLLECT",pf), + :loopIters2Atree (pfParts)((pfCollectIterators)(pf)), + pf2Atree1 (pfCollectBody)(pf)] + + -- next are for what appears to a parser screw-up + sex := ["COLLECT", + :(loopIters2Sex)((pfParts)((pfCollectIterators)(pf))), + pf2Sexpr (pfCollectBody)(pf)] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + [., [., condAtree], varAtree] := atree + ["SUCHTHAT", varAtree, condAtree] + + atree + +-- +-- pfRule2Atree pf == +-- $quotedOpList:local := nil +-- $predicateList:local := nil +-- $multiVarPredicateList:local := nil +-- lhs := pfLhsRule2Atree pfRuleLhsItems pf +-- rhs := pfRhsRule2Atree pfRuleRhs pf +-- lhs := ruleLhsTran lhs +-- rulePredicateTran +-- $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] +-- ["rule", lhs, rhs] +-- +-- +-- ruleLhsTran ruleLhs == +-- for pred in $predicateList repeat +-- [name, predLhs, :predRhs] := pred +-- vars := patternVarsOf predRhs +-- CDR vars => -- if there is more than one patternVariable +-- ruleLhs := NSUBST(predLhs, name, ruleLhs) +-- $multiVarPredicateList := [pred, :$multiVarPredicateList] +-- predicate := +-- [., var] := predLhs +-- ["suchThat", predLhs, ["ADEF", [var], +-- '((Boolean) (Expression (Integer))), '(() ()), predRhs]] +-- ruleLhs := NSUBST(predicate, name, ruleLhs) +-- ruleLhs +-- +-- rulePredicateTran rule == +-- null $multiVarPredicateList => rule +-- varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] +-- predBody := +-- CDR $multiVarPredicateList => +-- ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in +-- $multiVarPredicateList]] +-- [[.,.,:rhs],:.] := $multiVarPredicateList +-- pvarPredTran(rhs, varList) +-- ['suchThat, rule, +-- ['construct, :[["QUOTE", var] for var in varList]], +-- ['ADEF, '(predicateVariable), +-- '((Boolean) (List (Expression (Integer)))), '(() ()), +-- predBody]] +-- +-- pvarPredTran(rhs, varList) == +-- for var in varList for i in 1.. repeat +-- rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) +-- rhs +-- +-- patternVarsOf expr == +-- patternVarsOf1(expr, nil) +-- +-- patternVarsOf1(expr, varList) == +-- NULL expr => varList +-- ATOM expr => +-- null SYMBOLP expr => varList +-- SymMemQ(expr, varList) => varList +-- [expr, :varList] +-- expr is [op, :argl] => +-- for arg in argl repeat +-- varList := patternVarsOf1(arg, varList) +-- varList +-- varList +-- +-- pfLhsRule2Atree lhs == +-- $insideRule: local := 'left +-- ($insideRule): local := 'left +-- pf2Atree1 lhs +-- +-- +-- pfRhsRule2Atree rhs == +-- $insideRule: local := 'right +-- ($insideRule): local := 'right +-- pf2Atree1 rhs +-- + +-- pfSuchThat2Atree args == +-- name := GENTEMP() +-- argList := pf0TupleParts args +-- lhsSex := pf2Atree1 CAR argList +-- rhsSex := pf2Atree CADR argList +-- $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] +-- name +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/pf2sex.boot b/src/interp/pf2sex.boot deleted file mode 100644 index da4c7b19..00000000 --- a/src/interp/pf2sex.boot +++ /dev/null @@ -1,461 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -$dotdot := INTERN('"..", '"BOOT") -$specificMsgTags := nil - --- Pftree to s-expression translation. Used to interface the new parser --- technology to the interpreter. The input is a parseTree and the --- output is an old-parser-style s-expression - -pf2Sex pf == - intUnsetQuiet() - $insideRule:local := false - $insideApplication: local := false - $insideSEQ: local := false - pf2Sex1 pf - -pf2Sex1 pf == - pfNothing? pf => - "noBranch" - pfSymbol? pf => - $insideRule = 'left => - s := pfSymbolSymbol pf - ["constant", ["QUOTE", s]] - ["QUOTE", pfSymbolSymbol pf] - pfLiteral? pf => - pfLiteral2Sex pf - pfId? pf => - $insideRule => - s := pfIdSymbol pf - SymMemQ(s, '(%pi %e %i)) => s - ["QUOTE", s] - pfIdSymbol pf - pfApplication? pf => - pfApplication2Sex pf - pfTuple? pf => - ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] - pfIf? pf => - ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] - pfTagged? pf => - tag := pfTaggedTag pf - tagPart := - pfTuple? tag => - ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] - pf2Sex1 tag - [":", tagPart, pf2Sex1 pfTaggedExpr pf] - pfCoerceto? pf => - ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] - pfPretend? pf => - ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] - pfFromdom? pf => - op := opTran pf2Sex1 pfFromdomWhat pf --- if op = "braceFromCurly" then op := "brace" - if op = "braceFromCurly" then op := "SEQ" - ["$elt", pf2Sex1 pfFromdomDomain pf, op] - pfSequence? pf => - pfSequence2Sex pf - pfExit? pf => - $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] - ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] - pfLoop? pf => - ["REPEAT", :loopIters2Sex pf0LoopIterators pf] - pfCollect? pf => - pfCollect2Sex pf - pfForin? pf => - ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] - pfWhile? pf => - ["WHILE", pf2Sex1 pfWhileCond pf] - pfSuchthat? pf => - $insideRule = 'left => - keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) - ["|", pf2Sex1 pfSuchthatCond pf] - pfDo? pf => - pf2Sex1 pfDoBody pf - pfTyped? pf => - type := pfTypedType pf - pfNothing? type => pf2Sex1 pfTypedId pf - [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] - pfAssign? pf => - idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] - if #idList ^= 1 then idList := ['Tuple, :idList] - else idList := first idList - ["LET", idList, pf2Sex1 pfAssignRhs pf] - pfDefinition? pf => - pfDefinition2Sex pf - pfLambda? pf => - pfLambda2Sex pf - pfMLambda? pf => - "/throwAway" - pfRestrict? pf => - ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] - pfFree? pf => - ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] - pfLocal? pf => - ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] - pfWrong? pf => - spadThrow() - pfAnd? pf => - ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] - pfOr? pf => - ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] - pfNot? pf => - ["not", pf2Sex1 pfNotArg pf] - pfNovalue? pf => - intSetQuiet() - ["SEQ", pf2Sex1 pfNovalueExpr pf] - pfRule? pf => - pfRule2Sex pf - pfBreak? pf => - ["break", pfBreakFrom pf] - pfMacro? pf => - "/throwAway" - pfReturn? pf => - ["return", pf2Sex1 pfReturnExpr pf] - pfIterate? pf => - ["iterate"] - pfWhere? pf => - args := [pf2Sex1 p for p in pf0WhereContext pf] - #args = 1 => - ["where", pf2Sex1 pfWhereExpr pf, :args] - ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] - - -- under strange circumstances/piling, system commands can wind - -- up in expressions. This just passes it through as a string for - -- the user to figure out what happened. - pfAbSynOp(pf) = "command" => tokPart(pf) - - keyedSystemError('"S2GE0017", ['"pf2Sex1"]) - -pfLiteral2Sex pf == - type := pfLiteralClass pf - type = 'integer => - READ_-FROM_-STRING pfLiteralString pf - type = 'string or type = 'char => - pfLiteralString pf - type = 'float => - float2Sex pfLiteralString pf - type = 'symbol => - $insideRule => - s := pfSymbolSymbol pf - ["QUOTE", s] - pfSymbolSymbol pf - type = 'expression => - ["QUOTE", pfLeafToken pf] - keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) - -symEqual(sym, sym2) == EQ(sym, sym2) - -SymMemQ(sy, l) == MEMQ(sy, l) - -pmDontQuote? sy == - SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ - sin cos tan cot sec csc asin acos atan acot asec acsc _ - sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) - -pfOp2Sex pf == - alreadyQuoted := pfSymbol? pf - op := pf2Sex1 pf - op is ["QUOTE", realOp] => - $insideRule = 'left => realOp - $insideRule = 'right => - pmDontQuote? realOp => realOp - $quotedOpList := [op, :$quotedOpList] - op - symEqual(realOp, "|") => realOp - symEqual(realOp, ":") => realOp - symEqual(realOp, "?") => realOp - op - op - -pfApplication2Sex pf == - $insideApplication: local := true - op := pfOp2Sex pfApplicationOp pf - op := opTran op - op = "->" => - args := pf0TupleParts pfApplicationArg pf - if pfTuple? CAR args then - typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] - else - typeList := [pf2Sex1 CAR args] - args := [pf2Sex1 CADR args, :typeList] - ["Mapping", :args] - symEqual(op, ":") and $insideRule = 'left => - ["multiple", pf2Sex pfApplicationArg pf] - symEqual(op, "?") and $insideRule = 'left => - ["optional", pf2Sex pfApplicationArg pf] - args := pfApplicationArg pf - pfTuple? args => - symEqual(op, "|") and $insideRule = 'left => - pfSuchThat2Sex args - argSex := rest pf2Sex1 args - symEqual(op, ">") => - ["<", CADR argSex, CAR argSex] - symEqual(op, ">=") => - ["not", ["<", CAR argSex, CADR argSex]] - symEqual(op, "<=") => - ["not", ["<", CADR argSex, CAR argSex]] --- symEqual(op, "reduce") and (#argSex) = 2 => --- ["REDUCE", first argSex, 0, CADR argSex] - symEqual(op, "AND") => - ["and", CAR argSex, CADR argSex] - symEqual(op, "OR") => - ["or", CAR argSex, CADR argSex] - symEqual(op, "Iterate") => - ["iterate"] - symEqual(op, "by") => - ["BY", :argSex] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", :argSex]] - argSex is ["SEQ",:.] => argSex - ["SEQ", :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, :argSex] - val := hasOptArgs? argSex => [op, :val] - [op, :argSex] - op is [qt, realOp] and symEqual(qt, "QUOTE") => - ["applyQuote", op, pf2Sex1 args] - symEqual(op, "braceFromCurly") => --- ["brace", ["construct", pf2Sex1 args]] - x := pf2Sex1 args - x is ["SEQ", :.] => x - ["SEQ", x] - symEqual(op, "by") => - ["BY", pf2Sex1 args] - [op, pf2Sex1 args] - -hasOptArgs? argSex == - nonOpt := nil - opt := nil - for arg in argSex repeat - arg is ["OPTARG", lhs, rhs] => - opt := [[lhs, rhs], :opt] - nonOpt := [arg, :nonOpt] - null opt => nil - NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) - -pfDefinition2Sex pf == - $insideApplication => - ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, - pf2Sex1 pfDefinitionRhs pf] - idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] - #idList ^= 1 => - systemError '"lhs of definition must be a single item in the interpreter" - id := first idList - rhs := pfDefinitionRhs pf - [argList, :body] := pfLambdaTran rhs - ["DEF", (argList = 'id => id; [id, :argList]), :body] - -pfLambdaTran pf == - pfLambda? pf => - argTypeList := nil - argList := nil - for arg in pf0LambdaArgs pf repeat - pfTyped? arg => - argList := [pfCollectArgTran pfTypedId arg, :argList] - pfNothing? pfTypedType arg => - argTypeList := [nil, :argTypeList] - argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] - systemError '"definition args should be typed" - argList := nreverse argList - retType := - pfNothing? pfLambdaRets pf => nil - pf2Sex1 pfLambdaRets pf - argTypeList := [retType, :nreverse argTypeList] - [argList, :[argTypeList, [nil for arg in argTypeList], - pf2Sex1 pfLambdaBody pf]] - ['id, :['(()), '(()), pf2Sex1 pf]] - -pfLambda2Sex pf == - [argList, :body] := pfLambdaTran pf - ["ADEF", argList, :body] - -pfCollectArgTran pf == - pfCollect? pf => - conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] - id := pf2Sex1 pfCollectBody pf - conds is [["|", cond]] => - ["|", id, cond] - [id, :conds] - pf2Sex1 pf - -opTran op == - op = $dotdot => "SEGMENT" - op = "[]" => "construct" - op = "{}" => "braceFromCurly" - op = "IS" => "is" - op - -pfSequence2Sex pf == - $insideSEQ:local := true - seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] - seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => - ["ruleset", ["construct", :ruleList]] - seq - -pfSequence2Sex0 seqList == - null seqList => "noBranch" - seqTranList := [] - while seqList ^= nil repeat - item := first seqList - item is ["exit", cond, value] => - item := ["IF", cond, value, pfSequence2Sex0 rest seqList] - seqTranList := [item, :seqTranList] - seqList := nil - seqTranList := [item ,:seqTranList] - seqList := rest seqList - #seqTranList = 1 => first seqTranList - ["SEQ", :nreverse seqTranList] - -float2Sex num == - eIndex := SEARCH('"e", num) - mantPart := - eIndex => SUBSEQ(num, 0, eIndex) - num - expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) - dotIndex := SEARCH('".", mantPart) - intPart := - dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) - READ_-FROM_-STRING mantPart - fracPartString := - dotIndex => SUBSEQ(mantPart, dotIndex+1) - '"0" - bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, - LENGTH fracPartString, expPart) - $useBFasDefault => - [., frac, :exp] := bfForm - [["$elt", intNewFloat(), 'float], frac, exp, 10] - bfForm - -loopIters2Sex iterList == - result := nil - for iter in iterList repeat - sex := pf2Sex1 iter - sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => - result := [['STEP, var, i, incr], :result] - sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => - result := [['STEP, var, i, incr, j], :result] - sex is ['IN, var, ['SEGMENT, i, j]] => - result := [['STEP, var, i, 1, j], :result] - result := [sex, :result] - nreverse result - -pfCollect2Sex pf == - sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, - pf2Sex1 pfCollectBody pf] - sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => - ["|", var, cond] - sex - -pfRule2Sex pf == - $quotedOpList:local := nil - $predicateList:local := nil - $multiVarPredicateList:local := nil - lhs := pfLhsRule2Sex pfRuleLhsItems pf - rhs := pfRhsRule2Sex pfRuleRhs pf - lhs := ruleLhsTran lhs - rulePredicateTran - $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] - ["rule", lhs, rhs] - - -ruleLhsTran ruleLhs == - for pred in $predicateList repeat - [name, predLhs, :predRhs] := pred - vars := patternVarsOf predRhs - CDR vars => -- if there is more than one patternVariable - ruleLhs := NSUBST(predLhs, name, ruleLhs) - $multiVarPredicateList := [pred, :$multiVarPredicateList] - predicate := - [., var] := predLhs - ["suchThat", predLhs, ["ADEF", [var], - '((Boolean) (Expression (Integer))), '(() ()), predRhs]] - ruleLhs := NSUBST(predicate, name, ruleLhs) - ruleLhs - -rulePredicateTran rule == - null $multiVarPredicateList => rule - varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] - predBody := - CDR $multiVarPredicateList => - ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in - $multiVarPredicateList]] - [[.,.,:rhs],:.] := $multiVarPredicateList - pvarPredTran(rhs, varList) - ['suchThat, rule, - ['construct, :[["QUOTE", var] for var in varList]], - ['ADEF, '(predicateVariable), - '((Boolean) (List (Expression (Integer)))), '(() ()), - predBody]] - -pvarPredTran(rhs, varList) == - for var in varList for i in 1.. repeat - rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) - rhs - -patternVarsOf expr == - patternVarsOf1(expr, nil) - -patternVarsOf1(expr, varList) == - NULL expr => varList - ATOM expr => - null SYMBOLP expr => varList - SymMemQ(expr, varList) => varList - [expr, :varList] - expr is [op, :argl] => - for arg in argl repeat - varList := patternVarsOf1(arg, varList) - varList - varList - -pfLhsRule2Sex lhs == - $insideRule: local := 'left - pf2Sex1 lhs - - -pfRhsRule2Sex rhs == - $insideRule: local := 'right - pf2Sex1 rhs - -pfSuchThat2Sex args == - name := GENTEMP() - argList := pf0TupleParts args - lhsSex := pf2Sex1 CAR argList - rhsSex := pf2Sex CADR argList - $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] - name - - - - diff --git a/src/interp/pf2sex.boot.pamphlet b/src/interp/pf2sex.boot.pamphlet new file mode 100644 index 00000000..a5ea9b6e --- /dev/null +++ b/src/interp/pf2sex.boot.pamphlet @@ -0,0 +1,526 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pf2sex.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{Changes} +In the function [[float2Sex]] we need to special case the return value +if the global variable [[$useBFasDefault]] is set to true. This variable +allows ``big'' floating point values. + +The change can be seen from this email from Greg Vanuxem: +\begin{verbatim} +Attached is the patch (pf2sex.patch) that allows the use +of DoubleFloat by default in the interpreter. Test it. + +(1) -> 1.7+7.2 + + (1) 8.9 + Type: Float +(2) -> 1.7-7.2 + + (2) - 5.5 + Type: Float +(3) -> -1.7-7.2 + + (3) - 8.9 + Type: Float +(4) -> )boot $useBFasDefault:=false + +(SPADLET |$useBFasDefault| NIL) +Value = NIL + +(4) -> 1.7+7.2 + + (4) 8.9000000000000004 + Type: DoubleFloat +(5) -> 1.7-7.2 + + (5) - 5.5 + Type: DoubleFloat +(6) -> -1.7-7.2 + + (6) - 8.9000000000000004 + Type: DoubleFloat + + + +\end{verbatim} +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +$dotdot := INTERN('"..", '"BOOT") +$specificMsgTags := nil + +-- Pftree to s-expression translation. Used to interface the new parser +-- technology to the interpreter. The input is a parseTree and the +-- output is an old-parser-style s-expression + +pf2Sex pf == + intUnsetQuiet() + $insideRule:local := false + $insideApplication: local := false + $insideSEQ: local := false + pf2Sex1 pf + +pf2Sex1 pf == + pfNothing? pf => + "noBranch" + pfSymbol? pf => + $insideRule = 'left => + s := pfSymbolSymbol pf + ["constant", ["QUOTE", s]] + ["QUOTE", pfSymbolSymbol pf] + pfLiteral? pf => + pfLiteral2Sex pf + pfId? pf => + $insideRule => + s := pfIdSymbol pf + SymMemQ(s, '(%pi %e %i)) => s + ["QUOTE", s] + pfIdSymbol pf + pfApplication? pf => + pfApplication2Sex pf + pfTuple? pf => + ["Tuple", :[pf2Sex1 x for x in pf0TupleParts pf]] + pfIf? pf => + ['IF, pf2Sex1 pfIfCond pf, pf2Sex1 pfIfThen pf, pf2Sex1 pfIfElse pf] + pfTagged? pf => + tag := pfTaggedTag pf + tagPart := + pfTuple? tag => + ['Tuple, :[pf2Sex1 arg for arg in pf0TupleParts tag]] + pf2Sex1 tag + [":", tagPart, pf2Sex1 pfTaggedExpr pf] + pfCoerceto? pf => + ["::", pf2Sex1 pfCoercetoExpr pf, pf2Sex1 pfCoercetoType pf] + pfPretend? pf => + ["pretend", pf2Sex1 pfPretendExpr pf, pf2Sex1 pfPretendType pf] + pfFromdom? pf => + op := opTran pf2Sex1 pfFromdomWhat pf +-- if op = "braceFromCurly" then op := "brace" + if op = "braceFromCurly" then op := "SEQ" + ["$elt", pf2Sex1 pfFromdomDomain pf, op] + pfSequence? pf => + pfSequence2Sex pf + pfExit? pf => + $insideSEQ => ["exit", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf] + ["IF", pf2Sex1 pfExitCond pf, pf2Sex1 pfExitExpr pf, "noBranch"] + pfLoop? pf => + ["REPEAT", :loopIters2Sex pf0LoopIterators pf] + pfCollect? pf => + pfCollect2Sex pf + pfForin? pf => + ["IN", :[pf2Sex1 x for x in pf0ForinLhs pf], pf2Sex1 pfForinWhole pf] + pfWhile? pf => + ["WHILE", pf2Sex1 pfWhileCond pf] + pfSuchthat? pf => + $insideRule = 'left => + keyedSystemError('"S2GE0017", ['"pf2Sex1: pfSuchThat"]) + ["|", pf2Sex1 pfSuchthatCond pf] + pfDo? pf => + pf2Sex1 pfDoBody pf + pfTyped? pf => + type := pfTypedType pf + pfNothing? type => pf2Sex1 pfTypedId pf + [":", pf2Sex1 pfTypedId pf, pf2Sex1 pfTypedType pf] + pfAssign? pf => + idList := [pf2Sex1 x for x in pf0AssignLhsItems pf] + if #idList ^= 1 then idList := ['Tuple, :idList] + else idList := first idList + ["LET", idList, pf2Sex1 pfAssignRhs pf] + pfDefinition? pf => + pfDefinition2Sex pf + pfLambda? pf => + pfLambda2Sex pf + pfMLambda? pf => + "/throwAway" + pfRestrict? pf => + ["@", pf2Sex1 pfRestrictExpr pf, pf2Sex1 pfRestrictType pf] + pfFree? pf => + ['free, :[pf2Sex1 item for item in pf0FreeItems pf]] + pfLocal? pf => + ['local, :[pf2Sex1 item for item in pf0LocalItems pf]] + pfWrong? pf => + spadThrow() + pfAnd? pf => + ["and", pf2Sex1 pfAndLeft pf, pf2Sex1 pfAndRight pf] + pfOr? pf => + ["or", pf2Sex1 pfOrLeft pf, pf2Sex1 pfOrRight pf] + pfNot? pf => + ["not", pf2Sex1 pfNotArg pf] + pfNovalue? pf => + intSetQuiet() + ["SEQ", pf2Sex1 pfNovalueExpr pf] + pfRule? pf => + pfRule2Sex pf + pfBreak? pf => + ["break", pfBreakFrom pf] + pfMacro? pf => + "/throwAway" + pfReturn? pf => + ["return", pf2Sex1 pfReturnExpr pf] + pfIterate? pf => + ["iterate"] + pfWhere? pf => + args := [pf2Sex1 p for p in pf0WhereContext pf] + #args = 1 => + ["where", pf2Sex1 pfWhereExpr pf, :args] + ["where", pf2Sex1 pfWhereExpr pf, ["SEQ", :args]] + + -- under strange circumstances/piling, system commands can wind + -- up in expressions. This just passes it through as a string for + -- the user to figure out what happened. + pfAbSynOp(pf) = "command" => tokPart(pf) + + keyedSystemError('"S2GE0017", ['"pf2Sex1"]) + +pfLiteral2Sex pf == + type := pfLiteralClass pf + type = 'integer => + READ_-FROM_-STRING pfLiteralString pf + type = 'string or type = 'char => + pfLiteralString pf + type = 'float => + float2Sex pfLiteralString pf + type = 'symbol => + $insideRule => + s := pfSymbolSymbol pf + ["QUOTE", s] + pfSymbolSymbol pf + type = 'expression => + ["QUOTE", pfLeafToken pf] + keyedSystemError('"S2GE0017", ['"pfLiteral2Sex: unexpected form"]) + +symEqual(sym, sym2) == EQ(sym, sym2) + +SymMemQ(sy, l) == MEMQ(sy, l) + +pmDontQuote? sy == + SymMemQ(sy, '(_+ _- _* _*_* _^ _/ log exp pi sqrt ei li erf ci si dilog _ + sin cos tan cot sec csc asin acos atan acot asec acsc _ + sinh cosh tanh coth sech csch asinh acosh atanh acoth asech acsc)) + +pfOp2Sex pf == + alreadyQuoted := pfSymbol? pf + op := pf2Sex1 pf + op is ["QUOTE", realOp] => + $insideRule = 'left => realOp + $insideRule = 'right => + pmDontQuote? realOp => realOp + $quotedOpList := [op, :$quotedOpList] + op + symEqual(realOp, "|") => realOp + symEqual(realOp, ":") => realOp + symEqual(realOp, "?") => realOp + op + op + +pfApplication2Sex pf == + $insideApplication: local := true + op := pfOp2Sex pfApplicationOp pf + op := opTran op + op = "->" => + args := pf0TupleParts pfApplicationArg pf + if pfTuple? CAR args then + typeList := [pf2Sex1 arg for arg in pf0TupleParts CAR args] + else + typeList := [pf2Sex1 CAR args] + args := [pf2Sex1 CADR args, :typeList] + ["Mapping", :args] + symEqual(op, ":") and $insideRule = 'left => + ["multiple", pf2Sex pfApplicationArg pf] + symEqual(op, "?") and $insideRule = 'left => + ["optional", pf2Sex pfApplicationArg pf] + args := pfApplicationArg pf + pfTuple? args => + symEqual(op, "|") and $insideRule = 'left => + pfSuchThat2Sex args + argSex := rest pf2Sex1 args + symEqual(op, ">") => + ["<", CADR argSex, CAR argSex] + symEqual(op, ">=") => + ["not", ["<", CAR argSex, CADR argSex]] + symEqual(op, "<=") => + ["not", ["<", CADR argSex, CAR argSex]] +-- symEqual(op, "reduce") and (#argSex) = 2 => +-- ["REDUCE", first argSex, 0, CADR argSex] + symEqual(op, "AND") => + ["and", CAR argSex, CADR argSex] + symEqual(op, "OR") => + ["or", CAR argSex, CADR argSex] + symEqual(op, "Iterate") => + ["iterate"] + symEqual(op, "by") => + ["BY", :argSex] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", :argSex]] + argSex is ["SEQ",:.] => argSex + ["SEQ", :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, :argSex] + val := hasOptArgs? argSex => [op, :val] + [op, :argSex] + op is [qt, realOp] and symEqual(qt, "QUOTE") => + ["applyQuote", op, pf2Sex1 args] + symEqual(op, "braceFromCurly") => +-- ["brace", ["construct", pf2Sex1 args]] + x := pf2Sex1 args + x is ["SEQ", :.] => x + ["SEQ", x] + symEqual(op, "by") => + ["BY", pf2Sex1 args] + [op, pf2Sex1 args] + +hasOptArgs? argSex == + nonOpt := nil + opt := nil + for arg in argSex repeat + arg is ["OPTARG", lhs, rhs] => + opt := [[lhs, rhs], :opt] + nonOpt := [arg, :nonOpt] + null opt => nil + NCONC (nreverse nonOpt, [["construct", :nreverse opt]]) + +pfDefinition2Sex pf == + $insideApplication => + ["OPTARG", pf2Sex1 CAR pf0DefinitionLhsItems pf, + pf2Sex1 pfDefinitionRhs pf] + idList := [pf2Sex1 x for x in pf0DefinitionLhsItems pf] + #idList ^= 1 => + systemError '"lhs of definition must be a single item in the interpreter" + id := first idList + rhs := pfDefinitionRhs pf + [argList, :body] := pfLambdaTran rhs + ["DEF", (argList = 'id => id; [id, :argList]), :body] + +pfLambdaTran pf == + pfLambda? pf => + argTypeList := nil + argList := nil + for arg in pf0LambdaArgs pf repeat + pfTyped? arg => + argList := [pfCollectArgTran pfTypedId arg, :argList] + pfNothing? pfTypedType arg => + argTypeList := [nil, :argTypeList] + argTypeList := [pf2Sex1 pfTypedType arg, :argTypeList] + systemError '"definition args should be typed" + argList := nreverse argList + retType := + pfNothing? pfLambdaRets pf => nil + pf2Sex1 pfLambdaRets pf + argTypeList := [retType, :nreverse argTypeList] + [argList, :[argTypeList, [nil for arg in argTypeList], + pf2Sex1 pfLambdaBody pf]] + ['id, :['(()), '(()), pf2Sex1 pf]] + +pfLambda2Sex pf == + [argList, :body] := pfLambdaTran pf + ["ADEF", argList, :body] + +pfCollectArgTran pf == + pfCollect? pf => + conds := [pf2Sex1 x for x in pfParts pfCollectIterators pf] + id := pf2Sex1 pfCollectBody pf + conds is [["|", cond]] => + ["|", id, cond] + [id, :conds] + pf2Sex1 pf + +opTran op == + op = $dotdot => "SEGMENT" + op = "[]" => "construct" + op = "{}" => "braceFromCurly" + op = "IS" => "is" + op + +pfSequence2Sex pf == + $insideSEQ:local := true + seq := pfSequence2Sex0 [pf2Sex1 x for x in pf0SequenceArgs pf] + seq is ["SEQ", :ruleList] and ruleList is [["rule", :.], :.] => + ["ruleset", ["construct", :ruleList]] + seq + +pfSequence2Sex0 seqList == + null seqList => "noBranch" + seqTranList := [] + while seqList ^= nil repeat + item := first seqList + item is ["exit", cond, value] => + item := ["IF", cond, value, pfSequence2Sex0 rest seqList] + seqTranList := [item, :seqTranList] + seqList := nil + seqTranList := [item ,:seqTranList] + seqList := rest seqList + #seqTranList = 1 => first seqTranList + ["SEQ", :nreverse seqTranList] + +float2Sex num == + eIndex := SEARCH('"e", num) + mantPart := + eIndex => SUBSEQ(num, 0, eIndex) + num + expPart := (eIndex => READ_-FROM_-STRING SUBSEQ(num, eIndex+1); 0) + dotIndex := SEARCH('".", mantPart) + intPart := + dotIndex => READ_-FROM_-STRING SUBSEQ(mantPart, 0, dotIndex) + READ_-FROM_-STRING mantPart + fracPartString := + dotIndex => SUBSEQ(mantPart, dotIndex+1) + '"0" + bfForm := MAKE_-FLOAT(intPart, READ_-FROM_-STRING fracPartString, + LENGTH fracPartString, expPart) + $useBFasDefault => + [., frac, :exp] := bfForm + [["$elt", intNewFloat(), 'float], frac, exp, 10] + bfForm + +loopIters2Sex iterList == + result := nil + for iter in iterList repeat + sex := pf2Sex1 iter + sex is ['IN, var, ['SEGMENT, i, ["BY", incr]]] => + result := [['STEP, var, i, incr], :result] + sex is ['IN, var, ["BY", ['SEGMENT, i, j], incr]] => + result := [['STEP, var, i, incr, j], :result] + sex is ['IN, var, ['SEGMENT, i, j]] => + result := [['STEP, var, i, 1, j], :result] + result := [sex, :result] + nreverse result + +pfCollect2Sex pf == + sex := ["COLLECT", :loopIters2Sex pfParts pfCollectIterators pf, + pf2Sex1 pfCollectBody pf] + sex is ["COLLECT", ["|", cond], var] and SYMBOLP var => + ["|", var, cond] + sex + +pfRule2Sex pf == + $quotedOpList:local := nil + $predicateList:local := nil + $multiVarPredicateList:local := nil + lhs := pfLhsRule2Sex pfRuleLhsItems pf + rhs := pfRhsRule2Sex pfRuleRhs pf + lhs := ruleLhsTran lhs + rulePredicateTran + $quotedOpList => ["rule", lhs, rhs, ["construct", :$quotedOpList]] + ["rule", lhs, rhs] + + +ruleLhsTran ruleLhs == + for pred in $predicateList repeat + [name, predLhs, :predRhs] := pred + vars := patternVarsOf predRhs + CDR vars => -- if there is more than one patternVariable + ruleLhs := NSUBST(predLhs, name, ruleLhs) + $multiVarPredicateList := [pred, :$multiVarPredicateList] + predicate := + [., var] := predLhs + ["suchThat", predLhs, ["ADEF", [var], + '((Boolean) (Expression (Integer))), '(() ()), predRhs]] + ruleLhs := NSUBST(predicate, name, ruleLhs) + ruleLhs + +rulePredicateTran rule == + null $multiVarPredicateList => rule + varList := patternVarsOf [rhs for [.,.,:rhs] in $multiVarPredicateList] + predBody := + CDR $multiVarPredicateList => + ['AND, :[:pvarPredTran(rhs, varList) for [.,.,:rhs] in + $multiVarPredicateList]] + [[.,.,:rhs],:.] := $multiVarPredicateList + pvarPredTran(rhs, varList) + ['suchThat, rule, + ['construct, :[["QUOTE", var] for var in varList]], + ['ADEF, '(predicateVariable), + '((Boolean) (List (Expression (Integer)))), '(() ()), + predBody]] + +pvarPredTran(rhs, varList) == + for var in varList for i in 1.. repeat + rhs := NSUBST(['elt, 'predicateVariable, i], var, rhs) + rhs + +patternVarsOf expr == + patternVarsOf1(expr, nil) + +patternVarsOf1(expr, varList) == + NULL expr => varList + ATOM expr => + null SYMBOLP expr => varList + SymMemQ(expr, varList) => varList + [expr, :varList] + expr is [op, :argl] => + for arg in argl repeat + varList := patternVarsOf1(arg, varList) + varList + varList + +pfLhsRule2Sex lhs == + $insideRule: local := 'left + pf2Sex1 lhs + + +pfRhsRule2Sex rhs == + $insideRule: local := 'right + pf2Sex1 rhs + +pfSuchThat2Sex args == + name := GENTEMP() + argList := pf0TupleParts args + lhsSex := pf2Sex1 CAR argList + rhsSex := pf2Sex CADR argList + $predicateList := [[name, lhsSex, :rhsSex], :$predicateList] + name + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot deleted file mode 100644 index c5a3619d..00000000 --- a/src/interp/postpar.boot +++ /dev/null @@ -1,529 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -import '"postprop" -)package "BOOT" - -$postStack := [] - ---% Yet Another Parser Transformation File ---These functions are used by for BOOT and SPAD code ---(see new2OldLisp, e.g.) - -postTransform y == - x:= y - u:= postTran x - if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= - [":",["LISTOF",:l,y],t] - postTransformCheck u - aplTran u - -displayPreCompilationErrors() == - n:= #($postStack:= REMDUP NREVERSE $postStack) - n=0 => nil - errors:= - 1 '"errors" - '"error" - if $InteractiveMode - then sayBrightly ['" Semantic ",errors,'" detected: "] - else - heading:= - $topOp ^= '$topOp => ['" ",$topOp,'" has"] - ['" You have"] - sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] - if 1 - postAtom x - op := first x - SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) - op is ["elt",a,b] => - u:= postTran [b,:rest x] - [postTran op,:rest u] - op is ["Scripts",:.] => - postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) - op^=(y:= postOp op) => [y,:postTranList rest x] - postForm x - -postTranList x == [postTran y for y in x] - -postBigFloat x == - [.,mant,:expon] := x - $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon - eltword := if $InteractiveMode then "$elt" else "elt" - postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] - -postAdd ["add",a,:b] == - null b => postCapsule a - ["add",postTran a,postCapsule first b] - -checkWarning msg == postError concat('"Parsing error: ",msg) - -checkWarningIndentation() == - checkWarning ['"Apparent indentation error following",:bright "add"] - -postCapsule x == - x isnt [op,:.] => checkWarningIndentation() - INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] - op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] - op = "if" => ["CAPSULE",postBlockItem x] - checkWarningIndentation() - -postQUOTE x == x - -postColon u == - u is [":",x] => [":",postTran x] - u is [":",x,y] => [":",postTran x,:postType y] - -postColonColon u == - -- for Lisp package calling - -- boot syntax is package::fun but probably need to parenthesize it - $BOOT and u is ["::",package,fun] => - INTERN(STRINGIMAGE fun, package) - postForm u - -postAtSign ["@",x,y] == ["@",postTran x,:postType y] - -postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] - -postConstruct u == - u is ["construct",b] => - a:= (b is [",",:.] => comma2Tuple b; b) - a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] - a is ["Tuple",:l] => - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["construct",postTran a] - u - -postError msg == - BUMPERRORCOUNT 'precompilation - xmsg:= - $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] - msg - $postStack:= [xmsg,:$postStack] - nil - -postMakeCons l == - null l => "nil" - l is [[":",a],:l'] => - l' => ["append",postTran a,postMakeCons l'] - postTran a - ["cons",postTran first l,postMakeCons rest l] - -postAtom x == - $BOOT => x - x=0 => '(Zero) - x=1 => '(One) - EQ(x,'T) => 'T_$ -- rename T in spad code to T$ - IDENTP x and GETDATABASE(x,'NILADIC) => LIST x - x - -postBlock ["Block",:l,x] == - ["SEQ",:postBlockItemList l,["exit",postTran x]] - -postBlockItemList l == [postBlockItem x for x in l] - -postBlockItem x == - x:= postTran x - x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => - [":",["LISTOF",:l,y],t] - x - -postCategory (u is ["CATEGORY",:l]) == - --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible - null l => u - op := - $insidePostCategoryIfTrue = true => "PROGN" - "CATEGORY" - [op,:[fn x for x in l]] where fn x == - $insidePostCategoryIfTrue: local := true - postTran x - -postComma u == postTuple comma2Tuple u - -comma2Tuple u == ["Tuple",:postFlatten(u,",")] - -postDef [defOp,lhs,rhs] == ---+ - lhs is ["macro",name] => postMDef ["==>",name,rhs] - - if not($BOOT) then recordHeaderDocumentation nil - if $maxSignatureLineNumber ^= 0 then - $docList := [["constructor",:$headerDocumentation],:$docList] - $maxSignatureLineNumber := 0 - --reset this for next constructor; see recordDocumentation - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - if null $InteractiveMode and atom form then form := LIST form - newLhs:= - atom form => form - [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] - [op,:postDefArgs argl] - argTypeList:= - atom form => nil - [(x is [":",.,t] => t; nil) for x in rest form] - typeList:= [targetType,:argTypeList] - if atom form then form := [form] - specialCaseForm := [nil for x in form] - ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] - -postDefArgs argl == - null argl => argl - argl is [[":",a],:b] => - b => postError - ['" Argument",:bright a,'"of indefinite length must be last"] - atom a or a is ["QUOTE",:.] => a - postError - ['" Argument",:bright a,'"of indefinite length must be a name"] - [first argl,:postDefArgs rest argl] - -postMDef(t) == - [.,lhs,rhs] := t - $InteractiveMode and not $BOOT => - lhs := postTran lhs - null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) - ["MDEF",lhs,NIL,NIL,postTran rhs] - lhs:= postTran lhs - [form,targetType]:= - lhs is [":",:.] => rest lhs - [lhs,nil] - form:= - atom form => LIST form - form - newLhs:= [(x is [":",a,:.] => a; x) for x in form] - typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] - ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] - -postElt (u is [.,a,b]) == - a:= postTran a - b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] - ["elt",a,postTran b] - -postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] - - -postFlatten(x,op) == - x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] - LIST x - -postForm (u is [op,:argl]) == - x:= - atom op => - argl':= postTranList argl - op':= - true=> op - $BOOT => op - GET(op,'Led) or GET(op,'Nud) or op = 'IN => op - numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) - INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) - [op',:argl'] - op is ["Scripts",:.] => [:postTran op,:postTranList argl] - u:= postTranList u - if u is [["Tuple",:.],:.] then - postError ['" ",:bright u, - '"is illegal because tuples cannot be applied_!",'%l, - '" Did you misuse infix dot?"] - u - x is [.,["Tuple",:y]] => [first x,:y] - x - -postQuote [.,a] == ["QUOTE",a] - -postScriptsForm(["Scripts",op,a],argl) == - [getScriptName(op,a,#argl),:postTranScripts a,:argl] - -postScripts ["Scripts",op,a] == - [getScriptName(op,a,0),:postTranScripts a] - -getScriptName(op,a,numberOfFunctionalArgs) == - if null IDENTP op then - postError ['" ",op,'" cannot have scripts"] - INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, - decodeScripts a,PNAME op) - -postTranScripts a == - a is ["PrefixSC",b] => postTranScripts b - a is [";",:b] => "append"/[postTranScripts y for y in b] - a is [",",:b] => - ("append"/[fn postTran y for y in b]) where - fn x == - x is ["Tuple",:y] => y - LIST x - LIST postTran a - -decodeScripts a == - a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) - a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) - a is [",",:b] => - STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) - STRINGIMAGE 1 - -postIf t == - t isnt ["if",:l] => t - ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) - for x in l]] - -postJoin ["Join",a,:l] == - a:= postTran a - l:= postTranList l - if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l - := LIST ["CATEGORY",b] - al:= - a is ["Tuple",:c] => c - LIST a - ["Join",:al,:l] - -postMapping u == - u isnt ["->",source,target] => u - ["Mapping",postTran target,:unTuple postTran source] - -postOp x == - x=":=" => - $BOOT => "SPADLET" - "LET" - x=":-" => "LETD" - x="Attribute" => "ATTRIBUTE" - x - -postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] - -postSEGMENT ["SEGMENT",a,b] == - key:= [a,'"..",:(b => [b]; nil)] - postError ['" Improper placement of segment",:bright key] - -postCollect [constructOp,:m,x] == - x is [["elt",D,"construct"],:y] => - postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] - itl:= postIteratorList m - x:= (x is ["construct",r] => r; x) --added 84/8/31 - y:= postTran x - finish(constructOp,itl,y) where - finish(op,itl,y) == - y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] - y is ["Tuple",:l] => - newBody:= - or/[x is [":",y] for x in l] => postMakeCons l - or/[x is ["SEGMENT",:.] for x in l] => tuple2List l - ["construct",:postTranList l] - ["REDUCE","append",0,[op,:itl,newBody]] - [op,:itl,y] - -postTupleCollect [constructOp,:m,x] == - postCollect [constructOp,:m,["construct",x]] - -postIteratorList x == - x is [p,:l] => - (p:= postTran p) is ["IN",y,u] => - u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] - [["IN",y,postInSeq u],:postIteratorList l] - [p,:postIteratorList l] - x - -postin arg == - arg isnt ["in",i,seq] => systemErrorHere '"postin" - ["in",postTran i, postInSeq seq] - -postIn arg == - arg isnt ["IN",i,seq] => systemErrorHere '"postIn" - ["IN",postTran i,postInSeq seq] - -postInSeq seq == - seq is ["SEGMENT",p,q] => postTranSegment(p,q) - seq is ["Tuple",:l] => tuple2List l - postTran seq - -postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] - -tuple2List l == - l is [a,:l'] => - u:= tuple2List l' - a is ["SEGMENT",p,q] => - null u => ["construct",postTranSegment(p,q)] - $InteractiveMode and null $BOOT => - ["append",["construct",postTranSegment(p,q)],tuple2List l'] - ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] - null u => ["construct",postTran a] - ["cons",postTran a,tuple2List l'] - nil - -SEGMENT(a,b) == [i for i in a..b] - -postReduce ["Reduce",op,expr] == - $InteractiveMode or expr is ["COLLECT",:.] => - ["REDUCE",op,0,postTran expr] - postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], - ["construct", g]]] - -postFlattenLeft(x,op) ==-- - x is [ =op,a,b] => [:postFlattenLeft(a,op),b] - [x] - -postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] - -postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] - ---------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) -postSignature ["Signature",op,sig] == - sig is ["->",:.] => - sig1:= postType sig - op:= postAtom (STRINGP op => INTERN op; op) - ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] - -killColons x == - atom x => x - x is ["Record",:.] => x - x is ["Union",:.] => x - x is [":",.,y] => killColons y - [killColons first x,:killColons rest x] - -postSlash ['_/,a,b] == - STRINGP a => postTran ["Reduce",INTERN a,b] - ['_/,postTran a,postTran b] - -removeSuperfluousMapping sig1 == - --get rid of this asap - sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] - sig1 - -postType typ == - typ is ["->",source,target] => - source="constant" => [LIST postTran target,"constant"] - LIST ["Mapping",postTran target,:unTuple postTran source] - typ is ["->",target] => LIST ["Mapping",postTran target] - LIST postTran typ - -postTuple u == - u is ["Tuple"] => u - u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) ---u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) - --RDJ: don't understand need for above statement that is commented out - -postWhere ["where",a,b] == - x:= - b is ["Block",:c] => c - LIST b - ["where",postTran a,:postTranList x] - -postWith ["with",a] == - $insidePostCategoryIfTrue: local := true - a:= postTran a - a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] - a is ["PROGN",:b] => ["CATEGORY",:b] - a - -postTransformCheck x == - $defOp: local:= nil - postcheck x - -postcheck x == - atom x => nil - x is ["DEF",form,[target,:.],:.] => - (setDefOp form; postcheckTarget target; postcheck rest rest x) - x is ["QUOTE",:.] => nil - postcheck first x - postcheck rest x - -setDefOp f == - if f is [":",g,:.] then f := g - f := (atom f => f; first f) - if $topOp then $defOp:= f else $topOp:= f - -postcheckTarget x == - -- doesn't seem that useful! - isPackageType x => nil - x is ["Join",:.] => nil - NIL - -isPackageType x == not CONTAINED("$",x) - -unTuple x == - x is ["Tuple",:y] => y - LIST x - ---% APL TRANSFORMATION OF INPUT - -aplTran x == - $BOOT => x - $GENNO: local := 0 - u:= aplTran1 x - containsBang u => throwKeyedMsg("S2IP0002",NIL) - u - -containsBang u == - atom u => EQ(u,"_!") - u is [="QUOTE",.] => false - or/[containsBang x for x in u] - -aplTran1 x == - atom x => x - [op,:argl1] := x - argl := aplTranList argl1 - -- unary case f ! y - op = "_!" => - argl is [f,y] => - y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] - $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] - ["map",f,aplTran1 y] - x --do not handle yet - -- multiple argument case - hasAplExtension argl is [arglAssoc,:futureArgl] => - -- choose the last aggregate type to be result of reshape - ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], - aplTran1 [op,:futureArgl]],CDAR arglAssoc] - [op,:argl] - -aplTranList x == - atom x => x - [aplTran1 first x,:aplTranList rest x] - -hasAplExtension argl == - or/[x is ["_!",:.] for x in argl] => - u:= [futureArg for x in argl] where futureArg() == - x is ["_!",y] => - z:= deepestExpression y - arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] - substitute(g,z,y) - x - [arglAssoc,:u] - nil - -deepestExpression x == - x is ["_!",y] => deepestExpression y - x diff --git a/src/interp/postpar.boot.pamphlet b/src/interp/postpar.boot.pamphlet new file mode 100644 index 00000000..67cf814a --- /dev/null +++ b/src/interp/postpar.boot.pamphlet @@ -0,0 +1,555 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\$SPAD/src/interp postpar.boot} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +import '"postprop" +)package "BOOT" + +$postStack := [] + +--% Yet Another Parser Transformation File +--These functions are used by for BOOT and SPAD code +--(see new2OldLisp, e.g.) + +postTransform y == + x:= y + u:= postTran x + if u is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) then u:= + [":",["LISTOF",:l,y],t] + postTransformCheck u + aplTran u + +displayPreCompilationErrors() == + n:= #($postStack:= REMDUP NREVERSE $postStack) + n=0 => nil + errors:= + 1 '"errors" + '"error" + if $InteractiveMode + then sayBrightly ['" Semantic ",errors,'" detected: "] + else + heading:= + $topOp ^= '$topOp => ['" ",$topOp,'" has"] + ['" You have"] + sayBrightly [:heading,'%b,n,'%d,'"precompilation ",errors,'":"] + if 1 + postAtom x + op := first x + SYMBOLP op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) + op is ["elt",a,b] => + u:= postTran [b,:rest x] + [postTran op,:rest u] + op is ["Scripts",:.] => + postScriptsForm(op,"append"/[unTuple postTran y for y in rest x]) + op^=(y:= postOp op) => [y,:postTranList rest x] + postForm x + +postTranList x == [postTran y for y in x] + +postBigFloat x == + [.,mant,:expon] := x + $BOOT => INT2RNUM(mant) * INT2RNUM(10) ** expon + eltword := if $InteractiveMode then "$elt" else "elt" + postTran [[eltword,'(Float),"float"],[",",[",",mant,expon],10]] + +postAdd ["add",a,:b] == + null b => postCapsule a + ["add",postTran a,postCapsule first b] + +checkWarning msg == postError concat('"Parsing error: ",msg) + +checkWarningIndentation() == + checkWarning ['"Apparent indentation error following",:bright "add"] + +postCapsule x == + x isnt [op,:.] => checkWarningIndentation() + INTEGERP op or op = "==" => ["CAPSULE",postBlockItem x] + op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] + op = "if" => ["CAPSULE",postBlockItem x] + checkWarningIndentation() + +postQUOTE x == x + +postColon u == + u is [":",x] => [":",postTran x] + u is [":",x,y] => [":",postTran x,:postType y] + +postColonColon u == + -- for Lisp package calling + -- boot syntax is package::fun but probably need to parenthesize it + $BOOT and u is ["::",package,fun] => + INTERN(STRINGIMAGE fun, package) + postForm u + +postAtSign ["@",x,y] == ["@",postTran x,:postType y] + +postPretend ["pretend",x,y] == ["pretend",postTran x,:postType y] + +postConstruct u == + u is ["construct",b] => + a:= (b is [",",:.] => comma2Tuple b; b) + a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] + a is ["Tuple",:l] => + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["construct",postTran a] + u + +postError msg == + BUMPERRORCOUNT 'precompilation + xmsg:= + $defOp ^= '$defOp and not $InteractiveMode => [$defOp,'": ",:msg] + msg + $postStack:= [xmsg,:$postStack] + nil + +postMakeCons l == + null l => "nil" + l is [[":",a],:l'] => + l' => ["append",postTran a,postMakeCons l'] + postTran a + ["cons",postTran first l,postMakeCons rest l] + +postAtom x == + $BOOT => x + x=0 => '(Zero) + x=1 => '(One) + EQ(x,'T) => 'T_$ -- rename T in spad code to T$ + IDENTP x and GETDATABASE(x,'NILADIC) => LIST x + x + +postBlock ["Block",:l,x] == + ["SEQ",:postBlockItemList l,["exit",postTran x]] + +postBlockItemList l == [postBlockItem x for x in l] + +postBlockItem x == + x:= postTran x + x is ["Tuple",:l,[":",y,t]] and (and/[IDENTP x for x in l]) => + [":",["LISTOF",:l,y],t] + x + +postCategory (u is ["CATEGORY",:l]) == + --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible + null l => u + op := + $insidePostCategoryIfTrue = true => "PROGN" + "CATEGORY" + [op,:[fn x for x in l]] where fn x == + $insidePostCategoryIfTrue: local := true + postTran x + +postComma u == postTuple comma2Tuple u + +comma2Tuple u == ["Tuple",:postFlatten(u,",")] + +postDef [defOp,lhs,rhs] == +--+ + lhs is ["macro",name] => postMDef ["==>",name,rhs] + + if not($BOOT) then recordHeaderDocumentation nil + if $maxSignatureLineNumber ^= 0 then + $docList := [["constructor",:$headerDocumentation],:$docList] + $maxSignatureLineNumber := 0 + --reset this for next constructor; see recordDocumentation + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + if null $InteractiveMode and atom form then form := LIST form + newLhs:= + atom form => form + [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] + [op,:postDefArgs argl] + argTypeList:= + atom form => nil + [(x is [":",.,t] => t; nil) for x in rest form] + typeList:= [targetType,:argTypeList] + if atom form then form := [form] + specialCaseForm := [nil for x in form] + ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] + +postDefArgs argl == + null argl => argl + argl is [[":",a],:b] => + b => postError + ['" Argument",:bright a,'"of indefinite length must be last"] + atom a or a is ["QUOTE",:.] => a + postError + ['" Argument",:bright a,'"of indefinite length must be a name"] + [first argl,:postDefArgs rest argl] + +postMDef(t) == + [.,lhs,rhs] := t + $InteractiveMode and not $BOOT => + lhs := postTran lhs + null IDENTP lhs => throwKeyedMsg("S2IP0001",NIL) + ["MDEF",lhs,NIL,NIL,postTran rhs] + lhs:= postTran lhs + [form,targetType]:= + lhs is [":",:.] => rest lhs + [lhs,nil] + form:= + atom form => LIST form + form + newLhs:= [(x is [":",a,:.] => a; x) for x in form] + typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] + ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] + +postElt (u is [.,a,b]) == + a:= postTran a + b is ["Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] + ["elt",a,postTran b] + +postExit ["=>",a,b] == ["IF",postTran a,["exit",postTran b],"noBranch"] + + +postFlatten(x,op) == + x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] + LIST x + +postForm (u is [op,:argl]) == + x:= + atom op => + argl':= postTranList argl + op':= + true=> op + $BOOT => op + GET(op,'Led) or GET(op,'Nud) or op = 'IN => op + numOfArgs:= (argl' is [["Tuple",:l]] => #l; 1) + INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) + [op',:argl'] + op is ["Scripts",:.] => [:postTran op,:postTranList argl] + u:= postTranList u + if u is [["Tuple",:.],:.] then + postError ['" ",:bright u, + '"is illegal because tuples cannot be applied_!",'%l, + '" Did you misuse infix dot?"] + u + x is [.,["Tuple",:y]] => [first x,:y] + x + +postQuote [.,a] == ["QUOTE",a] + +postScriptsForm(["Scripts",op,a],argl) == + [getScriptName(op,a,#argl),:postTranScripts a,:argl] + +postScripts ["Scripts",op,a] == + [getScriptName(op,a,0),:postTranScripts a] + +getScriptName(op,a,numberOfFunctionalArgs) == + if null IDENTP op then + postError ['" ",op,'" cannot have scripts"] + INTERNL("*",STRINGIMAGE numberOfFunctionalArgs, + decodeScripts a,PNAME op) + +postTranScripts a == + a is ["PrefixSC",b] => postTranScripts b + a is [";",:b] => "append"/[postTranScripts y for y in b] + a is [",",:b] => + ("append"/[fn postTran y for y in b]) where + fn x == + x is ["Tuple",:y] => y + LIST x + LIST postTran a + +decodeScripts a == + a is ["PrefixSC",b] => STRCONC(STRINGIMAGE 0,decodeScripts b) + a is [";",:b] => APPLX('STRCONC,[decodeScripts x for x in b]) + a is [",",:b] => + STRINGIMAGE fn a where fn a == (a is [",",:b] => +/[fn x for x in b]; 1) + STRINGIMAGE 1 + +postIf t == + t isnt ["if",:l] => t + ["IF",:[(null (x:= postTran x) and null $BOOT => "noBranch"; x) + for x in l]] + +postJoin ["Join",a,:l] == + a:= postTran a + l:= postTranList l + if l is [b] and b is [name,:.] and MEMQ(name,'(ATTRIBUTE SIGNATURE)) then l + := LIST ["CATEGORY",b] + al:= + a is ["Tuple",:c] => c + LIST a + ["Join",:al,:l] + +postMapping u == + u isnt ["->",source,target] => u + ["Mapping",postTran target,:unTuple postTran source] + +postOp x == + x=":=" => + $BOOT => "SPADLET" + "LET" + x=":-" => "LETD" + x="Attribute" => "ATTRIBUTE" + x + +postRepeat ["REPEAT",:m,x] == ["REPEAT",:postIteratorList m,postTran x] + +postSEGMENT ["SEGMENT",a,b] == + key:= [a,'"..",:(b => [b]; nil)] + postError ['" Improper placement of segment",:bright key] + +postCollect [constructOp,:m,x] == + x is [["elt",D,"construct"],:y] => + postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] + itl:= postIteratorList m + x:= (x is ["construct",r] => r; x) --added 84/8/31 + y:= postTran x + finish(constructOp,itl,y) where + finish(op,itl,y) == + y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] + y is ["Tuple",:l] => + newBody:= + or/[x is [":",y] for x in l] => postMakeCons l + or/[x is ["SEGMENT",:.] for x in l] => tuple2List l + ["construct",:postTranList l] + ["REDUCE","append",0,[op,:itl,newBody]] + [op,:itl,y] + +postTupleCollect [constructOp,:m,x] == + postCollect [constructOp,:m,["construct",x]] + +postIteratorList x == + x is [p,:l] => + (p:= postTran p) is ["IN",y,u] => + u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] + [["IN",y,postInSeq u],:postIteratorList l] + [p,:postIteratorList l] + x + +postin arg == + arg isnt ["in",i,seq] => systemErrorHere '"postin" + ["in",postTran i, postInSeq seq] + +postIn arg == + arg isnt ["IN",i,seq] => systemErrorHere '"postIn" + ["IN",postTran i,postInSeq seq] + +postInSeq seq == + seq is ["SEGMENT",p,q] => postTranSegment(p,q) + seq is ["Tuple",:l] => tuple2List l + postTran seq + +postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] + +tuple2List l == + l is [a,:l'] => + u:= tuple2List l' + a is ["SEGMENT",p,q] => + null u => ["construct",postTranSegment(p,q)] + $InteractiveMode and null $BOOT => + ["append",["construct",postTranSegment(p,q)],tuple2List l'] + ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] + null u => ["construct",postTran a] + ["cons",postTran a,tuple2List l'] + nil + +SEGMENT(a,b) == [i for i in a..b] + +postReduce ["Reduce",op,expr] == + $InteractiveMode or expr is ["COLLECT",:.] => + ["REDUCE",op,0,postTran expr] + postReduce ["Reduce",op,["COLLECT",["IN",g:= GENSYM(),expr], + ["construct", g]]] + +postFlattenLeft(x,op) ==-- + x is [ =op,a,b] => [:postFlattenLeft(a,op),b] + [x] + +postSemiColon u == postBlock ["Block",:postFlattenLeft(u,";")] + +postSequence ["Sequence",:l] == ['(elt $ makeRecord),:postTranList l] + +--------------------> NEW DEFINITION (see br-saturn.boot.pamphlet) +postSignature ["Signature",op,sig] == + sig is ["->",:.] => + sig1:= postType sig + op:= postAtom (STRINGP op => INTERN op; op) + ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] + +killColons x == + atom x => x + x is ["Record",:.] => x + x is ["Union",:.] => x + x is [":",.,y] => killColons y + [killColons first x,:killColons rest x] + +postSlash ['_/,a,b] == + STRINGP a => postTran ["Reduce",INTERN a,b] + ['_/,postTran a,postTran b] + +removeSuperfluousMapping sig1 == + --get rid of this asap + sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] + sig1 + +postType typ == + typ is ["->",source,target] => + source="constant" => [LIST postTran target,"constant"] + LIST ["Mapping",postTran target,:unTuple postTran source] + typ is ["->",target] => LIST ["Mapping",postTran target] + LIST postTran typ + +postTuple u == + u is ["Tuple"] => u + u is ["Tuple",:l,a] => (["Tuple",:postTranList rest u]) +--u is ["Tuple",:l,a] => (--a:= postTran a; ["Tuple",:postTranList rest u]) + --RDJ: don't understand need for above statement that is commented out + +postWhere ["where",a,b] == + x:= + b is ["Block",:c] => c + LIST b + ["where",postTran a,:postTranList x] + +postWith ["with",a] == + $insidePostCategoryIfTrue: local := true + a:= postTran a + a is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE IF)) => ["CATEGORY",a] + a is ["PROGN",:b] => ["CATEGORY",:b] + a + +postTransformCheck x == + $defOp: local:= nil + postcheck x + +postcheck x == + atom x => nil + x is ["DEF",form,[target,:.],:.] => + (setDefOp form; postcheckTarget target; postcheck rest rest x) + x is ["QUOTE",:.] => nil + postcheck first x + postcheck rest x + +setDefOp f == + if f is [":",g,:.] then f := g + f := (atom f => f; first f) + if $topOp then $defOp:= f else $topOp:= f + +postcheckTarget x == + -- doesn't seem that useful! + isPackageType x => nil + x is ["Join",:.] => nil + NIL + +isPackageType x == not CONTAINED("$",x) + +unTuple x == + x is ["Tuple",:y] => y + LIST x + +--% APL TRANSFORMATION OF INPUT + +aplTran x == + $BOOT => x + $GENNO: local := 0 + u:= aplTran1 x + containsBang u => throwKeyedMsg("S2IP0002",NIL) + u + +containsBang u == + atom u => EQ(u,"_!") + u is [="QUOTE",.] => false + or/[containsBang x for x in u] + +aplTran1 x == + atom x => x + [op,:argl1] := x + argl := aplTranList argl1 + -- unary case f ! y + op = "_!" => + argl is [f,y] => + y is [op',:y'] and op' = "_!" => aplTran1 [op,op,f,:y'] + $BOOT => ["COLLECT",["IN",g:=GENVAR(),aplTran1 y],[f,g]] + ["map",f,aplTran1 y] + x --do not handle yet + -- multiple argument case + hasAplExtension argl is [arglAssoc,:futureArgl] => + -- choose the last aggregate type to be result of reshape + ["reshape",["COLLECT",:[["IN",g,["ravel",a]] for [g,:a] in arglAssoc], + aplTran1 [op,:futureArgl]],CDAR arglAssoc] + [op,:argl] + +aplTranList x == + atom x => x + [aplTran1 first x,:aplTranList rest x] + +hasAplExtension argl == + or/[x is ["_!",:.] for x in argl] => + u:= [futureArg for x in argl] where futureArg() == + x is ["_!",y] => + z:= deepestExpression y + arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] + substitute(g,z,y) + x + [arglAssoc,:u] + nil + +deepestExpression x == + x is ["_!",y] => deepestExpression y + x +@ + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/profile.boot b/src/interp/profile.boot deleted file mode 100644 index b5cb25a1..00000000 --- a/src/interp/profile.boot +++ /dev/null @@ -1,89 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---$profileCompiler := true -$profileAlist := nil - -profileWrite() == --called from finalizeLisplib - outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") - _*PRINT_-PRETTY_* :local := 'T - PRINT_-FULL(profileTran $profileAlist,outStream) - SHUT outStream - -profileTran alist == - $profileHash := MAKE_-HASH_-TABLE() - for [opSig,:info] in alist repeat - op := opOf opSig - sig := KAR KDR opSig - HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) - [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] - -profileRecord(label,name,info) == --name: info is var: type or op: sig ---$profileAlist is ((op . alist1) ...) where --- alist1 is ((label . alist2) ...) where --- alist2 is ((name . info) ...) - if $insideCapsuleFunctionIfTrue then - op := $op - argl := CDR $form - opSig := [$op,$signatureOfForm] - else - op := 'constructor - argl := nil - opSig := [op] - if label = 'locals and MEMQ(name,argl) then label := 'arguments - alist1 := LASSOC(opSig,$profileAlist) - alist2 := LASSOC(label,alist1) - newAlist2 := insertAlist(name,info,alist2) - newAlist1 := insertAlist(label,newAlist2,alist1) - $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) - $profileAlist - -profileDisplay() == - profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) - for [op,:alist1] in $profileAlist | op ^= 'constructor repeat - profileDisplayOp(op,alist1) - -profileDisplayOp(op,alist1) == - sayBrightly op - if LASSOC('arguments,alist1) then - sayBrightly '" arguments" - for [x,:t] in MSORT LASSOC('arguments,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - if LASSOC('locals,alist1) then - sayBrightly '" locals" - for [x,:t] in MSORT LASSOC('locals,alist1) repeat - sayBrightly concat('" ",x,": ",prefix2String t) - for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat - sayBrightly concat('" ",prefix2String con) - for [op1,:sig] in MSORT alist2 repeat - sayBrightly ['" ",:formatOpSignature(op1,sig)] - diff --git a/src/interp/profile.boot.pamphlet b/src/interp/profile.boot.pamphlet new file mode 100644 index 00000000..e3b83f66 --- /dev/null +++ b/src/interp/profile.boot.pamphlet @@ -0,0 +1,111 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp profile.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--$profileCompiler := true +$profileAlist := nil + +profileWrite() == --called from finalizeLisplib + outStream := MAKE_-OUTSTREAM CONCAT(LIBSTREAM_-DIRNAME $libFile,'"/info") + _*PRINT_-PRETTY_* :local := 'T + PRINT_-FULL(profileTran $profileAlist,outStream) + SHUT outStream + +profileTran alist == + $profileHash := MAKE_-HASH_-TABLE() + for [opSig,:info] in alist repeat + op := opOf opSig + sig := KAR KDR opSig + HPUT($profileHash,op,[[sig,:info],:HGET($profileHash,op)]) + [[key,:HGET($profileHash,key)] for key in mySort HKEYS $profileHash] + +profileRecord(label,name,info) == --name: info is var: type or op: sig +--$profileAlist is ((op . alist1) ...) where +-- alist1 is ((label . alist2) ...) where +-- alist2 is ((name . info) ...) + if $insideCapsuleFunctionIfTrue then + op := $op + argl := CDR $form + opSig := [$op,$signatureOfForm] + else + op := 'constructor + argl := nil + opSig := [op] + if label = 'locals and MEMQ(name,argl) then label := 'arguments + alist1 := LASSOC(opSig,$profileAlist) + alist2 := LASSOC(label,alist1) + newAlist2 := insertAlist(name,info,alist2) + newAlist1 := insertAlist(label,newAlist2,alist1) + $profileAlist := insertAlist(opSig,newAlist1,$profileAlist) + $profileAlist + +profileDisplay() == + profileDisplayOp('constructor,LASSOC('constructor,$profileAlist) ) + for [op,:alist1] in $profileAlist | op ^= 'constructor repeat + profileDisplayOp(op,alist1) + +profileDisplayOp(op,alist1) == + sayBrightly op + if LASSOC('arguments,alist1) then + sayBrightly '" arguments" + for [x,:t] in MSORT LASSOC('arguments,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + if LASSOC('locals,alist1) then + sayBrightly '" locals" + for [x,:t] in MSORT LASSOC('locals,alist1) repeat + sayBrightly concat('" ",x,": ",prefix2String t) + for [con,:alist2] in alist1 | not MEMQ(con,'(locals arguments)) repeat + sayBrightly concat('" ",prefix2String con) + for [op1,:sig] in MSORT alist2 repeat + sayBrightly ['" ",:formatOpSignature(op1,sig)] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/pspad1.boot b/src/interp/pspad1.boot deleted file mode 100644 index b936eb77..00000000 --- a/src/interp/pspad1.boot +++ /dev/null @@ -1,741 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -$escapeWords := ["always", "assert", "but", "define", - "delay", "do", "except", "export", "extend", "fix", "fluid", - "from", "generate", "goto", "import", "inline", "never", "select", - "try", "yield"] -$pileStyle := false -$commentIndentation := 8 -$braceIndentation := 8 -$doNotResetMarginIfTrue := true -$marginStack := nil -$numberOfSpills := 0 -$lineFragmentBuffer:= nil -$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) -$lineBuffer := nil -$formatForcePren := nil -$underScore := char ('__) -$rightBraceFlag := nil -$semicolonFlag := nil -$newLineWritten := nil -$comments := nil -$noColonDeclaration := false -$renameAlist := '( - (SmallInteger . SingleInteger) - (SmallFloat . DoubleFloat) - (Void . _(_)) - (xquo . exquo) - (setelt . set_!) - (_$ . _%) - (_$_$ . _$) - (_*_* . _^) - (_^_= . _~_=) - (_^ . _~)) - ---$opRenameAlist := '( --- (and . AND) --- (or . OR) --- (not . NOT)) - - ---====================================================================== --- Main Translator Function ---====================================================================== ---% lisp-fragment to boot-fragment functions -lisp2Boot x == - --entry function - $fieldNames := nil - $pilesAreOkHere: local:= true - $commentsToPrint: local:= nil - $lineBuffer: local - $braceStack: local := nil - $marginStack: local:= [0] - --$autoLine is true except when inside a try---if true, lines are allowed to break - $autoLine:= true - $lineFragmentBuffer:= nil - $bc:=0 --brace count - $m:= 0 - $c:= $m - $numberOfSpills:= 0 - $lineLength:= 80 - format x - formatOutput REVERSE $lineFragmentBuffer - [fragmentsToLine y for y in REVERSE $lineBuffer] - -fragmentsToLine fragments == - string:= lispStringList2String fragments - line:= GETSTR 240 - for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) - line - -lispStringList2String x == - null x => '"" - atom x => STRINGIMAGE x - CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) - lispStringList2String CAR x - ---% routines for buffer and margin adjustment - -formatOutput x == - for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat - startY:= rest start - for [loc,comment] in stack repeat - commentY:= rest loc - gap:= startY-commentY - gap>0 => before:= [[commentY,first loc,gap,comment],:before] - gap=0 => same:= [[startY,1,gap,comment],:same] - true => after:= [[startY,first loc,-gap,comment],:after] - if before then putOut before - if same then - [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] - line:= fragmentsToLine x - x:= - #line+#y>$lineLength => - (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) - [line,y] - consLineBuffer x - for y in extraLines repeat consLineBuffer LIST y - if after then putOut after - $commentsToPrint:= nil - -consLineBuffer x == $lineBuffer := [x,:$lineBuffer] - -putOut x == - eject ("min"/[gap for [.,.,gap,:.] in x]) - for u in orderList x repeat addComment u - -eject n == for i in 2..n repeat consLineBuffer nil - -addComment u == - for x in mkCommentLines u repeat consLineBuffer LIST x - -mkCommentLines [.,n,.,s] == - lines:= breakComments s - lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] - [:l,last]:= lines1 - [:l,fragmentsToLine [last,"_}"]] - -breakComments s == - n:= containsString(s,PNAME "ENDOFLINECHR") => - #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] - LIST SUBSTRING(s,0,n) - LIST s - -containsString(x,y) == - --if string x contains string y, return start index - for i in 0..MAXINDEX x-MAXINDEX y repeat - and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i - ---====================================================================== --- Character/String Buffer Functions ---====================================================================== -consBuffer item == - if item = '"failed" then item := 'failed - n:= - STRINGP item => 2+#item - IDENTP item => #PNAME item - #STRINGIMAGE item - columnsLeft:= $lineLength-$c - if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 - columnsLeft:= $lineLength-$c - --cheat for semicolons, strings, and delimiters: they are NEVER too long - not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => - $autoLine => - --is true except within try - formatOutput REVERSE $lineFragmentBuffer - $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) - $lineFragmentBuffer:= LIST nBlanks $c - consBuffer item - nil - $lineFragmentBuffer:= - ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] - NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] - STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] - sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] - $lineFragmentBuffer - $rightBraceFlag := item = "}" - $semicolonFlag := item = "; " --prevents consecutive semicolons - $c:= $c+n - -isSpecialBufferItem item == - item = "; " or STRINGP item => true - false - -isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") - ---====================================================================== --- Formatting/Line Control Functions ---====================================================================== -newLine() == - null $autoLine => nil - $newLineWritten := true - formatOutput REVERSE $lineFragmentBuffer - $lineFragmentBuffer:= LIST nBlanks $m - $c:= $m - -optNewLine() == - $newLineWritten => newLine() - $c - -spillLine() == - null $autoLine => nil - formatOutput REVERSE $lineFragmentBuffer - $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) - $lineFragmentBuffer:= LIST nBlanks $c - $c - -indent() == - $m:= $m+2*($numberOfSpills+1) - $marginStack:= [$m,:$marginStack] - $numberOfSpills:= 0 - $m - -undent() == --- $doNotResetMarginIfTrue=true => --- pp '"hoho" --- $c - $marginStack is [m,:r] => - $marginStack := r - $m := m - 0 - -spill(fn,a) == - u := try FUNCALL(fn,a) => u - (nearMargin() or spillLine()) and FUNCALL(fn,a) - -formatSpill(fn,a) == - u := try FUNCALL(fn,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) - w := stay or undent() - v and w - -formatSpill2(fn,f,a) == - u := try FUNCALL(fn,f,a) => u - v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) - w := stay or undent() - v and w - -nearMargin() == - $c=$m or $c=$m+1 => $c - ---====================================================================== --- Main Formatting Functions ---====================================================================== -format(x,:options) == - oldC:= $c - qualification := IFCAR options - newCOrNil:= - x is [op,:argl] => - if op = 'return then argl := rest argl - n := #argl - op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) - op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => - formatDollar(name,p,argl) - op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => - formatDollar1(CAR argl,CADR argl) - fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) - if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op - n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => - formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) - n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => - formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) - formatForm x - formatAtom x - null newCOrNil => ($c:= oldC; nil) - null FIXP newCOrNil => error() - $c:= newCOrNil - - -getOp(op,kind) == - kind = 'Led => - MEMQ(op,'(_div _exquo)) => nil - GET(op,'Led) - GET(op,'Nud) - -formatDollar(name,p,argl) == - name := markMacroTran name - n := #argl - kind := (n=1 => "Nud"; "Led") - IDENTP name and GETL(p,kind) => format([p,:argl],name) - formatForcePren [p,:argl] and - (try (format "$$" and formatForcePren name) - or (indent() and format "$__" and formatForcePren name and undent())) - -formatMacroCheck name == - ATOM name => name - u := or/[x for [x,:y] in $globalMacroStack | y = name] => u - u := or/[x for [x,:y] in $localMacroStack | y = name] => u - [op,:argl] := name - MEMQ(op,'(Record Union)) => - pp ['"Cannot find: ",name] - name - [op,:[formatMacroCheck x for x in argl]] - -formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) - -formatDollar1(name,arg) == - id := - IDENTP name => name - name is [p] and GETL(p,'NILADIC) => p - name - format arg and format "$$" and formatForcePren id - - -formatForcePren x == - $formatForcePren: local := true - format x - -formatAtom(x,:options) == - if u := LASSOC(x,$renameAlist) then x := u - null x or isIdentifier x => - if MEMQ(x,$escapeWords) then - consBuffer $underScore - consBuffer ident2PrintImage PNAME x - consBuffer x - -formatFn(fn,x,$m,$c) == FUNCALL(fn,x) - -formatFree(['free,:u]) == - format 'free and format " " and formatComma u - -formatUnion(['Union,:r]) == - $count : local := 0 - formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == - x is [":",y,'Branch] => fn STRINGIMAGE y - STRINGP x => [":", INTERN x, ['Enumeration,x]] - x is [":",:.] => x - tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) - [":", tag, x] - -formatTestForPartial u == - u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => - ['Partial, S] - u - -formatEnumeration(y is ['Enumeration,:r]) == - r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" - formatForm y - -formatRecord(u) == formatFormNoColonDecl u - -formatFormNoColonDecl u == - $noColonDeclaration: local := true - formatForm u - -formatElt(u) == - u is ["elt",a,b] => formatApplication rest u - formatForm u - -formatForm (u) == - [op,:argl] := u - if MEMQ(op, '(Record Union)) then - $fieldNames := union(getFieldNames argl,$fieldNames) - MEMQ(op,'((QUOTE T) true)) => format "true" - MEMQ(op,'(false nil)) => format op - u='(Zero) => format 0 - u='(One) => format 1 - 1=#argl => formatApplication u - formatFunctionCall u - -formatFunctionCall u == - $pilesAreOkHere: local - spill("formatFunctionCall1",u) - -formatFunctionCall1 [op,:argl] == ---null argl and getConstructorProperty(op,'niladic) => formatOp op - null argl => - GETL(op,'NILADIC) => formatOp op - formatOp op and format "()" - formatOp op and formatFunctionCallTail argl - -formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" - -formatComma argl == - format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c - -formatOp op == - atom op => formatAtom op - formatPren op - -formatApplication u == - [op,a] := u - MEMQ(a, $fieldNames) => formatSelection u - atom op => - formatHasDotLeadOp a => formatOpPren(op,a) - formatApplication0 u - formatSelection u - -formatHasDotLeadOp u == - u is [op,:.] and (op = "." or not atom op) - -formatApplication0 u == ---format as f(x) as f x if possible - $pilesAreOkHere: local - formatSpill("formatApplication1",u) - -formatApplication1 u == - [op,x] := u - formatHasDollarOp x or $formatForcePren or - pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) - try (formatOp op and format " ") and - (try formatApplication2 x or - format "(" and formatApplication2 x and format ")") - -formatHasDollarOp x == - x is ["elt",a,b] and isTypeProbably? a - -isTypeProbably? x == - IDENTP x and UPPER_-CASE_-P (PNAME x).0 - -formatOpPren(op,x) == formatOp op and formatPren x - -formatApplication2 x == - leadOp := - x is [['elt,.,y],:.] => y - opOf x - MEMQ(leadOp,'(COLLECT LIST construct)) or - pspadBindingPowerOf("left",x)<1000 => formatPren x - format x - -formatDot ["dot",a,x] == - try (formatOp a and format ".") and - ATOM x => format x - formatPren x - -formatSelection u == - $pilesAreOkHere: local - formatSpill("formatSelection1",u) - -formatSelection1 [f,x] == formatSelectionOp f and format "." and - ATOM x => format x - formatPren x - -formatSelectionOp op == - op is [f,.] and not GET(f,'Nud) or - 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op - formatPren1("formatSelectionOp1",op) - -formatSelectionOp1 f == - f is [op,:argl] => - argl is [a] => - not ATOM op and ATOM a => formatSelection1 [op,a] - formatPren f - format f - formatOp f - -formatPren a == - $pilesAreOkHere: local - formatSpill("formatPrenAux",a) - -formatPrenAux a == format "_(" and format a and format "_)" - -formatPren1(f,a) == - $pilesAreOkHere: local - formatSpill2("formatPren1Aux",f,a) - -formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" - -formatLeft(fn,x,op,key) == - lbp:= formatOpBindingPower(op,key,"left") - formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) - FUNCALL(fn,x) - -formatRight(fn,x,op,key) == - --are there exceptional cases where piles are ok? - x is ['LET,:.] => FUNCALL(fn,x) - --decide on basis of binding power whether prens are needed - rbp := formatOpBindingPower(op,key,"right") - lbp := formatOpBindingPower(opOf x,key,"left") - lbp < rbp => formatPren1(fn,x) - FUNCALL(fn,x) - -formatCut a == formatSpill("format",a) - ---====================================================================== --- Prefix/Infix Operators ---====================================================================== -formatPrefix(op,arg,lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - formatPrefixOp(op,qualification) and - (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) - -formatPrefixOp(op,:options) == - qualification := IFCAR options - op=char '" " => format " =" - qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => - formatQual(op,qualification) and format " " - format op - -formatQual(op,D) == - null D => format op - format op and format "$$" and format D - -formatInfix(op,[a,b],lbp,rbp,:options) == - qualification := IFCAR options - $pilesAreOkHere: local - (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) - then formatPren b else format b) - -formatGetBindingPowerOf(leftOrRight,x) == --- this function is nearly identical with getBindingPowerOf --- leftOrRight = "left" => 0 --- 1 - pspadBindingPowerOf(leftOrRight,x) - -pspadBindingPowerOf(key,x) == - --binding powers can be found in file NEWAUX LISP - x is ['REDUCE,:.] => (key='left => 130; key='right => 0) - x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) - x is ["COND",:.] => (key="left" => 130; key="right" => 0) - x is [op,:argl] => - if op is [a,:.] then op:= a - op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 - op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) - (n:= #argl)=1 => - key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m - 1000 - n>1 => - key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m - key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m - op="ELT" => 1002 - 1000 - 1000 - 1002 - -pspadOpBindingPower(op,LedOrNud,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - MEMQ(op,'(_:)) and LedOrNud = 'Led => - leftOrRight = 'left => 195 - 196 - exception:= - leftOrRight="left" => 0 - 105 - bp:= - leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) - rightBindingPowerOf(op,LedOrNud) - bp^=exception => bp - 1000 - -formatOpBindingPower(op,key,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - op = '_$ => 1002 - MEMQ(op,'(_:)) and key = 'Led => - leftOrRight = 'left => 195 - 196 - MEMQ(op,'(_^_= _>_=)) => 400 - op = "not" and key = "Nud" => - leftOrRight = 'left => 1000 - 1001 - GETL(op,key) is [.,.,:r] => - leftOrRight = 'left => KAR r or 0 - KAR KDR r or 1 - 1000 - -formatInfixOp(op,:options) == - qualification := IFCAR options - qualification or - (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " - format op - ---====================================================================== --- Special Handlers: DEF forms ---====================================================================== - -formatDEF def == formatDEF0(def,$DEFdepth + 1) - -formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == - if not MEMQ(KAR form,'(Exports Implementation)) then - $form := - form is [":",a,:.] => a - form - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $abb :local := constructor? opOf $form - if $DEFdepth < 2 then - condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] - $numberOfSpills := -1 - consComments(condoc,'"+++ ") - form := formatDeftranForm(form,tlist) - u := ["DEF",form,tlist,sclist,body] - v := formatDEF1 u => v - $insideDEF: local := $DEFdepth > 1 - $DEFdepth = 1 => - exname := 'Exports - impname := 'Implementation - form is [":",.,=exname] or body = impname => nil - exports := - form is [":",a,b] => - form := a - [["MDEF",exname,'(NIL),'(NIL),b]] - nil - [op,:argl] := form --- decls := [x for x in argl | x is [":",:.]] --- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] --- $DEFdepth := $DEFdepth - 1 - formatWHERE(["where", - ["DEF",[":",form,exname],[nil for x in form],sclist,impname], - ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) - $insideTypeExpression: local := true - body := formatDeftran(body,false) - body is ["add",a,:b] => formatAddDef(form,a,b) ---body is ["with",a,:b] => formatWithDef(form,a,b) - tryBreakNB(format form and format " == ",body,"==","Led") - -formatDEF1 ["DEF",form,tlist,b,body] == - $insideDEF: local := $DEFdepth > 1 - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - form := formatDeftran(form,false) - body := formatDeftran(body,false) - ---------> terrible, hideous, but temporary, hack - if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] - prefix := (opOf tlist = 'Category => "define "; nil) - body is ["add",a,b] => formatAddDef(form,a,b) - body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) - prefix => - tryBreak(format prefix and format form and format " == ",body,"==","Led") - tryBreak(format form and format " == ",body,"==","Led") - -formatDefForm(form,:options) == - prefix := IFCAR options - $insideTypeExpression : local := true - form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) - prefix => format prefix and format form - format form - -formatAddDef(form,a,b) == - $insideCAPSULE : local := true - $insideDEF : local := false - formatDefForm form or return nil - $marginStack := [0] - $m := $c := 0 - $insideTypeExpression : local := false - cap := (b => b; "") - tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") - and format " add ", cap,"add","Led") - -formatWithDef(form,a,b,separator,:options) == - prefix := IFCAR options - $insideEXPORTS : local := true - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - a1 := formatWithKillSEQ a - b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") - and format " with ",first b,"with","Led") - tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") - -formatWithKillSEQ x == - x is ['SEQ,['exit,.,y]] => ['BRACE, y] - x - -formatBrace ['BRACE, x] == format "{" and format x and format "}" - -formatWith ["with",a,:b] == - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatWithDefault ["withDefault",a,b] == - if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then - part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] - if IFCAR init then - a:= IFCAR init - b:= [part2] - else - a := part2 - b := nil - $pilesAreOkHere: local := true - b => - tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") - tryBreak(format "with ",a,"with","Nud") - -formatDefaultDefs ["default",a, :b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreak(formatLeft("format",a,"default","Led") and - format " default ", first b,"default","Led") - tryBreak(format "default ",a,"default","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatAdd ["add",a,:b] == - $insideCAPSULE : local := true - $insideDEF : local := false - $insideTypeExpression : local := false - b => - tryBreakNB(formatLeft("format",a,"and","Led") and - format " and ", first b,"and","Led") - tryBreakNB(format "add ",a,"and","Nud") ---format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace - -formatMDEF ["MDEF",form,.,.,body] == - form is '(Rep) => formatDEF ["DEF",form,.,.,body] - $insideEXPORTS: local := form = 'Exports - $insideTypeExpression: local := true - body := formatDeftran(body,false) - name := opOf form - tryBreakNB(format name and format " ==> ",body,"==","Led") - and ($insideCAPSULE and $c or format(";")) - -insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue - or $noColonDeclaration - -formatImport ["import",a] == - addFieldNames a - addFieldNames macroExpand(a,$e) - format "import from " and formatLocal1 a - -addFieldNames a == - a is [op,:r] and MEMQ(op,'(Record Union)) => - $fieldNames := union(getFieldNames r,$fieldNames) - a is ['List,:b] => addFieldNames b - nil - -getFieldNames r == - r is [[":",a,b],:r] => [a,:getFieldNames r] - nil - -formatLocal ["local",a] == format "local " and formatLocal1 a - -formatLocal1 a == - $insideTypeExpression: local := true - format a - diff --git a/src/interp/pspad1.boot.pamphlet b/src/interp/pspad1.boot.pamphlet new file mode 100644 index 00000000..408ff6f5 --- /dev/null +++ b/src/interp/pspad1.boot.pamphlet @@ -0,0 +1,767 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/pspad1.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +$escapeWords := ["always", "assert", "but", "define", + "delay", "do", "except", "export", "extend", "fix", "fluid", + "from", "generate", "goto", "import", "inline", "never", "select", + "try", "yield"] +$pileStyle := false +$commentIndentation := 8 +$braceIndentation := 8 +$doNotResetMarginIfTrue := true +$marginStack := nil +$numberOfSpills := 0 +$lineFragmentBuffer:= nil +$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) +$lineBuffer := nil +$formatForcePren := nil +$underScore := char ('__) +$rightBraceFlag := nil +$semicolonFlag := nil +$newLineWritten := nil +$comments := nil +$noColonDeclaration := false +$renameAlist := '( + (SmallInteger . SingleInteger) + (SmallFloat . DoubleFloat) + (Void . _(_)) + (xquo . exquo) + (setelt . set_!) + (_$ . _%) + (_$_$ . _$) + (_*_* . _^) + (_^_= . _~_=) + (_^ . _~)) + +--$opRenameAlist := '( +-- (and . AND) +-- (or . OR) +-- (not . NOT)) + + +--====================================================================== +-- Main Translator Function +--====================================================================== +--% lisp-fragment to boot-fragment functions +lisp2Boot x == + --entry function + $fieldNames := nil + $pilesAreOkHere: local:= true + $commentsToPrint: local:= nil + $lineBuffer: local + $braceStack: local := nil + $marginStack: local:= [0] + --$autoLine is true except when inside a try---if true, lines are allowed to break + $autoLine:= true + $lineFragmentBuffer:= nil + $bc:=0 --brace count + $m:= 0 + $c:= $m + $numberOfSpills:= 0 + $lineLength:= 80 + format x + formatOutput REVERSE $lineFragmentBuffer + [fragmentsToLine y for y in REVERSE $lineBuffer] + +fragmentsToLine fragments == + string:= lispStringList2String fragments + line:= GETSTR 240 + for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) + line + +lispStringList2String x == + null x => '"" + atom x => STRINGIMAGE x + CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) + lispStringList2String CAR x + +--% routines for buffer and margin adjustment + +formatOutput x == + for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat + startY:= rest start + for [loc,comment] in stack repeat + commentY:= rest loc + gap:= startY-commentY + gap>0 => before:= [[commentY,first loc,gap,comment],:before] + gap=0 => same:= [[startY,1,gap,comment],:same] + true => after:= [[startY,first loc,-gap,comment],:after] + if before then putOut before + if same then + [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] + line:= fragmentsToLine x + x:= + #line+#y>$lineLength => + (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) + [line,y] + consLineBuffer x + for y in extraLines repeat consLineBuffer LIST y + if after then putOut after + $commentsToPrint:= nil + +consLineBuffer x == $lineBuffer := [x,:$lineBuffer] + +putOut x == + eject ("min"/[gap for [.,.,gap,:.] in x]) + for u in orderList x repeat addComment u + +eject n == for i in 2..n repeat consLineBuffer nil + +addComment u == + for x in mkCommentLines u repeat consLineBuffer LIST x + +mkCommentLines [.,n,.,s] == + lines:= breakComments s + lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] + [:l,last]:= lines1 + [:l,fragmentsToLine [last,"_}"]] + +breakComments s == + n:= containsString(s,PNAME "ENDOFLINECHR") => + #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] + LIST SUBSTRING(s,0,n) + LIST s + +containsString(x,y) == + --if string x contains string y, return start index + for i in 0..MAXINDEX x-MAXINDEX y repeat + and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i + +--====================================================================== +-- Character/String Buffer Functions +--====================================================================== +consBuffer item == + if item = '"failed" then item := 'failed + n:= + STRINGP item => 2+#item + IDENTP item => #PNAME item + #STRINGIMAGE item + columnsLeft:= $lineLength-$c + if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 + columnsLeft:= $lineLength-$c + --cheat for semicolons, strings, and delimiters: they are NEVER too long + not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => + $autoLine => + --is true except within try + formatOutput REVERSE $lineFragmentBuffer + $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) + $lineFragmentBuffer:= LIST nBlanks $c + consBuffer item + nil + $lineFragmentBuffer:= + ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] + NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] + STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] + sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] + $lineFragmentBuffer + $rightBraceFlag := item = "}" + $semicolonFlag := item = "; " --prevents consecutive semicolons + $c:= $c+n + +isSpecialBufferItem item == + item = "; " or STRINGP item => true + false + +isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") + +--====================================================================== +-- Formatting/Line Control Functions +--====================================================================== +newLine() == + null $autoLine => nil + $newLineWritten := true + formatOutput REVERSE $lineFragmentBuffer + $lineFragmentBuffer:= LIST nBlanks $m + $c:= $m + +optNewLine() == + $newLineWritten => newLine() + $c + +spillLine() == + null $autoLine => nil + formatOutput REVERSE $lineFragmentBuffer + $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) + $lineFragmentBuffer:= LIST nBlanks $c + $c + +indent() == + $m:= $m+2*($numberOfSpills+1) + $marginStack:= [$m,:$marginStack] + $numberOfSpills:= 0 + $m + +undent() == +-- $doNotResetMarginIfTrue=true => +-- pp '"hoho" +-- $c + $marginStack is [m,:r] => + $marginStack := r + $m := m + 0 + +spill(fn,a) == + u := try FUNCALL(fn,a) => u + (nearMargin() or spillLine()) and FUNCALL(fn,a) + +formatSpill(fn,a) == + u := try FUNCALL(fn,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) + w := stay or undent() + v and w + +formatSpill2(fn,f,a) == + u := try FUNCALL(fn,f,a) => u + v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) + w := stay or undent() + v and w + +nearMargin() == + $c=$m or $c=$m+1 => $c + +--====================================================================== +-- Main Formatting Functions +--====================================================================== +format(x,:options) == + oldC:= $c + qualification := IFCAR options + newCOrNil:= + x is [op,:argl] => + if op = 'return then argl := rest argl + n := #argl + op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) + op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => + formatDollar(name,p,argl) + op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => + formatDollar1(CAR argl,CADR argl) + fn:= GETL(op,"PSPAD") => formatFn(fn,x,$m,$c) + if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op + n=1 and GETL(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => + formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) + n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => + formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) + formatForm x + formatAtom x + null newCOrNil => ($c:= oldC; nil) + null FIXP newCOrNil => error() + $c:= newCOrNil + + +getOp(op,kind) == + kind = 'Led => + MEMQ(op,'(_div _exquo)) => nil + GET(op,'Led) + GET(op,'Nud) + +formatDollar(name,p,argl) == + name := markMacroTran name + n := #argl + kind := (n=1 => "Nud"; "Led") + IDENTP name and GETL(p,kind) => format([p,:argl],name) + formatForcePren [p,:argl] and + (try (format "$$" and formatForcePren name) + or (indent() and format "$__" and formatForcePren name and undent())) + +formatMacroCheck name == + ATOM name => name + u := or/[x for [x,:y] in $globalMacroStack | y = name] => u + u := or/[x for [x,:y] in $localMacroStack | y = name] => u + [op,:argl] := name + MEMQ(op,'(Record Union)) => + pp ['"Cannot find: ",name] + name + [op,:[formatMacroCheck x for x in argl]] + +formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) + +formatDollar1(name,arg) == + id := + IDENTP name => name + name is [p] and GETL(p,'NILADIC) => p + name + format arg and format "$$" and formatForcePren id + + +formatForcePren x == + $formatForcePren: local := true + format x + +formatAtom(x,:options) == + if u := LASSOC(x,$renameAlist) then x := u + null x or isIdentifier x => + if MEMQ(x,$escapeWords) then + consBuffer $underScore + consBuffer ident2PrintImage PNAME x + consBuffer x + +formatFn(fn,x,$m,$c) == FUNCALL(fn,x) + +formatFree(['free,:u]) == + format 'free and format " " and formatComma u + +formatUnion(['Union,:r]) == + $count : local := 0 + formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == + x is [":",y,'Branch] => fn STRINGIMAGE y + STRINGP x => [":", INTERN x, ['Enumeration,x]] + x is [":",:.] => x + tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) + [":", tag, x] + +formatTestForPartial u == + u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => + ['Partial, S] + u + +formatEnumeration(y is ['Enumeration,:r]) == + r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" + formatForm y + +formatRecord(u) == formatFormNoColonDecl u + +formatFormNoColonDecl u == + $noColonDeclaration: local := true + formatForm u + +formatElt(u) == + u is ["elt",a,b] => formatApplication rest u + formatForm u + +formatForm (u) == + [op,:argl] := u + if MEMQ(op, '(Record Union)) then + $fieldNames := union(getFieldNames argl,$fieldNames) + MEMQ(op,'((QUOTE T) true)) => format "true" + MEMQ(op,'(false nil)) => format op + u='(Zero) => format 0 + u='(One) => format 1 + 1=#argl => formatApplication u + formatFunctionCall u + +formatFunctionCall u == + $pilesAreOkHere: local + spill("formatFunctionCall1",u) + +formatFunctionCall1 [op,:argl] == +--null argl and getConstructorProperty(op,'niladic) => formatOp op + null argl => + GETL(op,'NILADIC) => formatOp op + formatOp op and format "()" + formatOp op and formatFunctionCallTail argl + +formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" + +formatComma argl == + format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c + +formatOp op == + atom op => formatAtom op + formatPren op + +formatApplication u == + [op,a] := u + MEMQ(a, $fieldNames) => formatSelection u + atom op => + formatHasDotLeadOp a => formatOpPren(op,a) + formatApplication0 u + formatSelection u + +formatHasDotLeadOp u == + u is [op,:.] and (op = "." or not atom op) + +formatApplication0 u == +--format as f(x) as f x if possible + $pilesAreOkHere: local + formatSpill("formatApplication1",u) + +formatApplication1 u == + [op,x] := u + formatHasDollarOp x or $formatForcePren or + pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) + try (formatOp op and format " ") and + (try formatApplication2 x or + format "(" and formatApplication2 x and format ")") + +formatHasDollarOp x == + x is ["elt",a,b] and isTypeProbably? a + +isTypeProbably? x == + IDENTP x and UPPER_-CASE_-P (PNAME x).0 + +formatOpPren(op,x) == formatOp op and formatPren x + +formatApplication2 x == + leadOp := + x is [['elt,.,y],:.] => y + opOf x + MEMQ(leadOp,'(COLLECT LIST construct)) or + pspadBindingPowerOf("left",x)<1000 => formatPren x + format x + +formatDot ["dot",a,x] == + try (formatOp a and format ".") and + ATOM x => format x + formatPren x + +formatSelection u == + $pilesAreOkHere: local + formatSpill("formatSelection1",u) + +formatSelection1 [f,x] == formatSelectionOp f and format "." and + ATOM x => format x + formatPren x + +formatSelectionOp op == + op is [f,.] and not GET(f,'Nud) or + 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op + formatPren1("formatSelectionOp1",op) + +formatSelectionOp1 f == + f is [op,:argl] => + argl is [a] => + not ATOM op and ATOM a => formatSelection1 [op,a] + formatPren f + format f + formatOp f + +formatPren a == + $pilesAreOkHere: local + formatSpill("formatPrenAux",a) + +formatPrenAux a == format "_(" and format a and format "_)" + +formatPren1(f,a) == + $pilesAreOkHere: local + formatSpill2("formatPren1Aux",f,a) + +formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" + +formatLeft(fn,x,op,key) == + lbp:= formatOpBindingPower(op,key,"left") + formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) + FUNCALL(fn,x) + +formatRight(fn,x,op,key) == + --are there exceptional cases where piles are ok? + x is ['LET,:.] => FUNCALL(fn,x) + --decide on basis of binding power whether prens are needed + rbp := formatOpBindingPower(op,key,"right") + lbp := formatOpBindingPower(opOf x,key,"left") + lbp < rbp => formatPren1(fn,x) + FUNCALL(fn,x) + +formatCut a == formatSpill("format",a) + +--====================================================================== +-- Prefix/Infix Operators +--====================================================================== +formatPrefix(op,arg,lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + formatPrefixOp(op,qualification) and + (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) + +formatPrefixOp(op,:options) == + qualification := IFCAR options + op=char '" " => format " =" + qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => + formatQual(op,qualification) and format " " + format op + +formatQual(op,D) == + null D => format op + format op and format "$$" and format D + +formatInfix(op,[a,b],lbp,rbp,:options) == + qualification := IFCAR options + $pilesAreOkHere: local + (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) + then formatPren b else format b) + +formatGetBindingPowerOf(leftOrRight,x) == +-- this function is nearly identical with getBindingPowerOf +-- leftOrRight = "left" => 0 +-- 1 + pspadBindingPowerOf(leftOrRight,x) + +pspadBindingPowerOf(key,x) == + --binding powers can be found in file NEWAUX LISP + x is ['REDUCE,:.] => (key='left => 130; key='right => 0) + x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) + x is ["COND",:.] => (key="left" => 130; key="right" => 0) + x is [op,:argl] => + if op is [a,:.] then op:= a + op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 + op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) + (n:= #argl)=1 => + key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m + 1000 + n>1 => + key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m + key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m + op="ELT" => 1002 + 1000 + 1000 + 1002 + +pspadOpBindingPower(op,LedOrNud,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + MEMQ(op,'(_:)) and LedOrNud = 'Led => + leftOrRight = 'left => 195 + 196 + exception:= + leftOrRight="left" => 0 + 105 + bp:= + leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) + rightBindingPowerOf(op,LedOrNud) + bp^=exception => bp + 1000 + +formatOpBindingPower(op,key,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + op = '_$ => 1002 + MEMQ(op,'(_:)) and key = 'Led => + leftOrRight = 'left => 195 + 196 + MEMQ(op,'(_^_= _>_=)) => 400 + op = "not" and key = "Nud" => + leftOrRight = 'left => 1000 + 1001 + GETL(op,key) is [.,.,:r] => + leftOrRight = 'left => KAR r or 0 + KAR KDR r or 1 + 1000 + +formatInfixOp(op,:options) == + qualification := IFCAR options + qualification or + (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " + format op + +--====================================================================== +-- Special Handlers: DEF forms +--====================================================================== + +formatDEF def == formatDEF0(def,$DEFdepth + 1) + +formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == + if not MEMQ(KAR form,'(Exports Implementation)) then + $form := + form is [":",a,:.] => a + form + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $abb :local := constructor? opOf $form + if $DEFdepth < 2 then + condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] + $numberOfSpills := -1 + consComments(condoc,'"+++ ") + form := formatDeftranForm(form,tlist) + u := ["DEF",form,tlist,sclist,body] + v := formatDEF1 u => v + $insideDEF: local := $DEFdepth > 1 + $DEFdepth = 1 => + exname := 'Exports + impname := 'Implementation + form is [":",.,=exname] or body = impname => nil + exports := + form is [":",a,b] => + form := a + [["MDEF",exname,'(NIL),'(NIL),b]] + nil + [op,:argl] := form +-- decls := [x for x in argl | x is [":",:.]] +-- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] +-- $DEFdepth := $DEFdepth - 1 + formatWHERE(["where", + ["DEF",[":",form,exname],[nil for x in form],sclist,impname], + ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) + $insideTypeExpression: local := true + body := formatDeftran(body,false) + body is ["add",a,:b] => formatAddDef(form,a,b) +--body is ["with",a,:b] => formatWithDef(form,a,b) + tryBreakNB(format form and format " == ",body,"==","Led") + +formatDEF1 ["DEF",form,tlist,b,body] == + $insideDEF: local := $DEFdepth > 1 + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + form := formatDeftran(form,false) + body := formatDeftran(body,false) + ---------> terrible, hideous, but temporary, hack + if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] + prefix := (opOf tlist = 'Category => "define "; nil) + body is ["add",a,b] => formatAddDef(form,a,b) + body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) + prefix => + tryBreak(format prefix and format form and format " == ",body,"==","Led") + tryBreak(format form and format " == ",body,"==","Led") + +formatDefForm(form,:options) == + prefix := IFCAR options + $insideTypeExpression : local := true + form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) + prefix => format prefix and format form + format form + +formatAddDef(form,a,b) == + $insideCAPSULE : local := true + $insideDEF : local := false + formatDefForm form or return nil + $marginStack := [0] + $m := $c := 0 + $insideTypeExpression : local := false + cap := (b => b; "") + tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") + and format " add ", cap,"add","Led") + +formatWithDef(form,a,b,separator,:options) == + prefix := IFCAR options + $insideEXPORTS : local := true + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + a1 := formatWithKillSEQ a + b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") + and format " with ",first b,"with","Led") + tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") + +formatWithKillSEQ x == + x is ['SEQ,['exit,.,y]] => ['BRACE, y] + x + +formatBrace ['BRACE, x] == format "{" and format x and format "}" + +formatWith ["with",a,:b] == + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatWithDefault ["withDefault",a,b] == + if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then + part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] + if IFCAR init then + a:= IFCAR init + b:= [part2] + else + a := part2 + b := nil + $pilesAreOkHere: local := true + b => + tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") + tryBreak(format "with ",a,"with","Nud") + +formatDefaultDefs ["default",a, :b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreak(formatLeft("format",a,"default","Led") and + format " default ", first b,"default","Led") + tryBreak(format "default ",a,"default","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatAdd ["add",a,:b] == + $insideCAPSULE : local := true + $insideDEF : local := false + $insideTypeExpression : local := false + b => + tryBreakNB(formatLeft("format",a,"and","Led") and + format " and ", first b,"and","Led") + tryBreakNB(format "add ",a,"and","Nud") +--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace + +formatMDEF ["MDEF",form,.,.,body] == + form is '(Rep) => formatDEF ["DEF",form,.,.,body] + $insideEXPORTS: local := form = 'Exports + $insideTypeExpression: local := true + body := formatDeftran(body,false) + name := opOf form + tryBreakNB(format name and format " ==> ",body,"==","Led") + and ($insideCAPSULE and $c or format(";")) + +insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue + or $noColonDeclaration + +formatImport ["import",a] == + addFieldNames a + addFieldNames macroExpand(a,$e) + format "import from " and formatLocal1 a + +addFieldNames a == + a is [op,:r] and MEMQ(op,'(Record Union)) => + $fieldNames := union(getFieldNames r,$fieldNames) + a is ['List,:b] => addFieldNames b + nil + +getFieldNames r == + r is [[":",a,b],:r] => [a,:getFieldNames r] + nil + +formatLocal ["local",a] == format "local " and formatLocal1 a + +formatLocal1 a == + $insideTypeExpression: local := true + format a + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/pspad2.boot b/src/interp/pspad2.boot deleted file mode 100644 index d97d4cea..00000000 --- a/src/interp/pspad2.boot +++ /dev/null @@ -1,661 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - ---====================================================================== --- Constructor Transformation Functions ---====================================================================== -formatDeftranForm(form,tlist) == - [ttype,:atypeList] := tlist - if form is [":",f,t] then - form := f - ttype := t - if form is ['elt,a,b] then ----> a.b ====> apply(b,a) - form := - isTypeProbably? a => - atypeList := REVERSE atypeList - ["$$", b, a] - ["apply",a, b] - op := KAR form - argl := KDR form - if or/[t for t in atypeList] then - form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] - if ttype then form := [":",form,ttype] - form - -formatDeftran(u,SEQflag) == - u is ['Join,:x] => formatDeftranJoin(u,SEQflag) - u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) - u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) - u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) - u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => - formatDeftranColon(u,SEQflag) - u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - u is ['SEQ,:l,[.,n,x]] => - v := [:l,x] - a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] - b := formatDeftranSEQ(x,false) - if b is [:.,c] and c = '(void) then b := DROP(-1, b) - [:m,y] := [:a,:b] - ['SEQ,:m,['exit,n,y]] --- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => --- formatDeftran([op,:CDR arg],nil) - u is ["^",a] => formatDeftran(['not,a],SEQflag) - u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) - u is ['IF,a,b,c] => - a := formatDeftran(a,nil) - b := formatDeftran(b,nil) - c := formatDeftran(c,nil) - null SEQflag and $insideDEF => - [:y,last] := formatDeftranIf(a,b,c) - ['SEQ,:y,['exit,1,last]] - ['IF,a,b,c] - u is ['Union,:argl] => - ['Union,:[x for a in argl - | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] - u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and - ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => - formatDeftran([op,:nitl,nbody],SEQflag) - u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] - u is ["DEF",:.] => formatCapsuleFunction(u) - u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] - u = 'nil => 'empty - u - -formatCapsuleFunction ["DEF",form,tlist,b,body] == - $insideDEF : local := true - ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] - -formatDeftranCapsule(l,x,SEQflag) == - $insideCAPSULE: local := true - formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - -formatDeftranRepper([op,a],SEQflag) == - a is [op1,b] and MEMQ(op1,'(rep per)) => - op = op1 => formatDeftran(a,SEQflag) - formatDeftran(b,SEQflag) - a is ["::",b,t] => - b := formatDeftran(b,SEQflag) - t := formatDeftran(t,SEQflag) - a := ["::",b,t] - op = 'per and t = "$" or op = 'rep and t = 'Rep => a - [op,a] - a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] - a is ['IF,p,b,c] => - formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) - a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) - a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => - formatDeftran [op1,a,b] - a is ['return,n,r] => - MEMQ(opOf r,'(true false)) => a - ['return,n,[op,formatDeftran(r,SEQflag)]] - a is ['error,:.] => a - [op,formatDeftran(a,SEQflag)] - -formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ - a := formatDeftran(a,SEQflag) - t := formatDeftran(t,SEQflag) - a is ["UNCOERCE",b] => b - a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => - op1 = "pretend" or op = "pretend" => ["pretend",b,t] - null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] - a - a is [=op,b,t1] => - t1 = t => a - [op,b,t] - t = "$" => - a is ['rep,b] => b - a is ['per,b] => a - [op,a,t] - t = "Rep" => - a is ['per,b] => b - a is ['rep,b] => a - [op,a,t] - [op,a,t] - -formatSeqRepper(op,x) == - x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] - x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] - atom x => x - [formatSeqRepper(op,y) for y in x] - -formatDeftranJoin(u,SEQflag) == - ['Join,:cats,lastcat] := u - lastcat is ['CATEGORY,kind,:l,x] => - cat := - CDR cats => ['Join,:cats] - first cats - formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) - u - -formatENUM ['MyENUM, x] == format "'" and format x and format "'" - -formatDeftranREPEAT(itl,body) == ---do nothing unless "itl" contains UNTIL statements - u := [x for x in itl | x is ["UNTIL",p]] or return nil - nitl := SETDIFFERENCE(itl,u) - pred := MKPF([p for ['UNTIL,p] in u],'or) - cond := ['IF,pred,['leave,n,nil],'noBranch] - nbody := - body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] - ['SEQ,body,['exit,n,cond]] - [nitl,:nbody] - -formatDeftranSEQ(x,flag) == - u := formatDeftran(x,flag) - u is ['SEQ,:.] => rest u - [u] - -formatDeftranIf(a,b,c) == - b = 'noBranch => - a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); - iop := LASSOC(op, al) or rassoc(op, al)) => - [["=>",[iop, :r],c]] - a is [op,r] and MEMQ(op,'(NOT not NULL null)) => - [["=>", r, c]] - [["=>", ['not, a], c]] - post := - c = 'noBranch => nil - c is ['SEQ,:.] => CDR c - [c] - [["=>",a,b],:post] - -formatWHERE ["where",a,b] == - $insideTypeExpression: local := nil - $insideCAPSULE: local := false - tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") - ---====================================================================== --- Special Handlers: Categories ---====================================================================== -formatATTRIBUTE ['ATTRIBUTE,att] == format att - -formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] - -formatCategory ['Category] == format " " and format "Category" - -formatCATEGORY cat == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - format ["with",formatDeftranCategory cat] - -formatSIGNATURE ['SIGNATURE,op,types,:r] == - MEMQ('constant,r) => format op and format ": " and (u := format first types) and - formatSC() and formatComments(u,op,types) - format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and - formatComments(u,op,types) - -formatDefault ["default",a] == - $insideCategoryIfTrue : local := false - $insideCAPSULE: local := true - $insideTypeExpression: local := false - tryBreak(format "default ",a,"with","Nud") ---====================================================================== --- Special Handlers: Control Structures ---====================================================================== -formatUNCOERCE ['UNCOERCE,x] == format x - -formatIF ['IF,a,b,c] == - c = 'noBranch => formatIF2(a,b,"if ") - b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] - formatIF2(a,b,"if ") and newLine() and formatIF3 c - -formatIF2(a,b,prefix) == - tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") - -formatIF3 x == - x is ['IF,a,b,c] => - c = 'noBranch => tryBreak(format "else if " - and format a and format " then ",b,"then","Nud") - formatIF2(a,b,"else if ") and newLine() and formatIF3 c - tryBreak(format "else ",x,"else","Nud") - -formatBlock(l,x) == - null l => format x - $pilesAreOkHere: local - format "{ " and format first l and - (and/[formatSC() and format y for y in rest l]) - and formatSC() and format x and format " }" - -formatExit ["exit",.,u] == format u - -formatvoid ["void"] == format "()" - -formatLeave ["leave",.,u] == format "break" - -formatCOLLECT u == formatSpill("formatCOLLECT1",u) - -formatCOLLECT1 ["COLLECT",:iteratorList,body] == - $pilesAreOkHere: local - format "[" and format body and format " " and - formatSpill("formatIteratorTail",iteratorList) - -formatIteratorTail iteratorList == - formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" - ---====================================================================== --- Special Handlers: Keywords ---====================================================================== - -formatColon [":",a,b] == - b is ['with,c,:d] => formatColonWith(a,c,d) - if not $insideTypeExpression then - insideCat() => nil - format - $insideDEF => "local " - "default " - op := - $insideCAPSULE and not $insideDEF => ": " - insideCat() => ": " - ":" - b := (atom b => b; markMacroTran b) - a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b - formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), - formatOpBindingPower(":","Led","right")) - -formatColonWith(form,a,b) == - con := opOf $form - $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) - $insideEXPORTS : local := true - $pilesAreOkHere: local := true - $insideTypeExpression : local := false - b => tryBreak(formatDefForm form and format ": " - and format a and format " with ",first b,"with","Led") - tryBreak(formatDefForm form and format ": with ",a,"with","Nud") - -formatCOND ["COND",:l] == - originalC:= $c - and/[x is [a,[.,.,b]] for x in l] => - (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and - formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC - formatIfThenElse l - -formatPROGN ["PROGN",:l] == - l is [:u,x] => formatPiles(u,x) - error '"formatPROGN" - -formatELT ["ELT",a,b] == formatApplication [a,b] - -formatCONS ["CONS",a,b] == - $pilesAreOkHere: local - format "[" and formatConstructItem a and formatTail b - -formatTail x == - null x => format "]" - format "," and formatTail1 x - -formatTail1 x == - x is ["CONS",a,b] => formatConstructItem a and formatTail b - x is ["APPEND",a,b] => - null b => formatConstructItem a and format "]" - format ":" and formatConstructItem a and formatTail b - format ":" and formatConstructItem x and format "]" - --- x = "." => format " " -formatConstructItem x == format x - -formatLET ["LET",a,b] == - $insideTypeExpression: local := true - a = "Rep" or atom a and constructor? opOf b => - tryBreakNB(formatAtom a and format " == ",b,":=","Led") - tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") - -formatIfExit(a,b) == - --called from SCOND or COND only - $numberOfSpills: local:= 0 - curMargin:= $m - curMarginStack:= $currentMarginStack - $doNotResetMarginIfTrue:= true - format a and format " => " and formatRight("formatCut",b,"=>","Led") => - ($currentMarginStack:= curMarginStack; $m:= curMargin) - -formatIfThenElse x == formatSpill("formatIf1",x) - -formatIf1 x == - x is [[a,:r],:c] and null c => - b:= - r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] - first r - isTrue a => format b - format "if " and format a and format " then " and format b - format "if " and format a and - (try - (format " then " and format b and format " else " - and formatIfThenElse c) or spillLine() - and format " then " and format b and --- ($c:= $m:= $m+6) and - ($numberOfSpills:= $numberOfSpills-1) - and spillLine() and format " else " and formatIfThenElse c) - -formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" - -formatMI ["MI",a,b] == format a - -formatMapping ['Mapping,target,:sources] == - $noColonDeclaration: local := true - formatTuple ['Tuple,:sources] and format " -> " and format target - -formatTuple ['Tuple,:types] == - null types => format "()" - null rest types => format first types - formatFunctionCallTail types - -formatConstruct(['construct,:u]) == - format "[" and (null u or format first u and - "and"/[format "," and formatCut x for x in rest u]) and format "]" - -formatNextConstructItem x == - try format x or ($m := $m + 2) and newLine() and format x - -formatREPEAT ["REPEAT",:iteratorList,body] == - tryBreakNB(null iteratorList or (formatIterator first iteratorList and - (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") - and format "repeat ",body,"repeat","Led") - -formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") - -formatMap ["+->",a,b] == - $noColonDeclaration: local := true - tryBreak(format a and format " +-> ", b, "+->","Led") - -formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) - -formatreduce ["reduce",op,u] == formatReduce1(op,u) - -formatReduce1(op,u) == - if STRINGP op then op := INTERN op - id := LASSOC(op, - '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) - formatFunctionCall - id => ['reduce,op,u,id] - ['reduce,op,u] - -formatIterator u == - $noColonDeclaration : local := true - u is ["IN",x,y] => - format "for " and formatLeft("format",x,"in","Led") and format " in " and - formatRight("format",y,"in","Led") - u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") - u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") - u is ["|",x] => format "| " and formatRight("format",x,"|","Led") - u is ["STEP",i,init,step,:v] => - final := IFCAR v - format "for " and formatLeft("format",i,"in","Led") and format " in " and - (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) - error "formatIterator" - -formatStepOne? step == - step = 1 or step = '(One) => true - step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) - false - -formatBy ['by,seg,step] == format seg and format " by " and format step - -formatSCOND ["SCOND",:l] == - $pilesAreOkHere => - --called from formatPileLine or formatBlock - --if from formatPileLine - initialC:= $c - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC - formatIfThenElse l and initialC - and/[x is [a,["exit",.,b]] for x in l] => - first l is [a,["exit",.,b]] and formatIfExit(a,b) and - (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c - --warning: and/(...) returns T if there are no entries - formatIfThenElse l - -formatSEGMENT ["SEGMENT",a,b] == - $pilesAreOkHere: local - (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and - formatInfixOp ".." and - (null b and $c or - (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) - -formatSexpr x == - atom x => - null x or IDENTP x => consBuffer ident2PrintImage PNAME x - consBuffer x - spill("formatNonAtom",x) - -formatNonAtom x == - format "_(" and formatSexpr first x and - (and/[format " " and formatSexpr y for y in rest x]) - and (y:= LASTATOM x => format " . " - and formatSexpr y; true) and format "_)" - -formatCAPSULE ['CAPSULE,:l,x] == - $insideCAPSULE: local := true - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - -formatPAREN [.,:argl] == formatFunctionCallTail argl - -formatSEQ ["SEQ",:l,[.,.,x]] == - try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - ---====================================================================== --- Comment Handlers ---====================================================================== -formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == - $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] - format x - -formatComments(u,op,types) == - $numberOfSpills :local := $commentIndentation/2 - 1 - not $insideEXPORTS => u - alist := LASSOC(op,$comments) or - sayBrightly ['"No documentation for ",op] - return u - ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) - consComments(LASSOC(ftypes,alist),'"++ ") - u - -consComments(s,plusPlus) == - s is [word,:r] and null atom r => consComments(r, plusPlus) - s := first s - null s => nil - s := consCommentsTran s - indent() and newLine() or return nil - columnsLeft := $lineLength - $m - 2 - while (m := MAXINDEX s) >= columnsLeft repeat - k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] - k := (k => k + 1; columnsLeft) - piece := SUBSTRING(s,0,k) - formatDoCommentLine [plusPlus,piece] - s := SUBSTRING(s,k,nil) - formatDoCommentLine [plusPlus,s] - undent() - $m - -consCommentsTran s == - m := MAXINDEX s - k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => - r := charPosition(char '_},s,k + 6) - r = m + 1 => s - STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) - s - -formatDoCommentLine line == - $lineBuffer := consLineBuffer [nBlanks $c,:line] - $c := $m+2*$numberOfSpills - ---====================================================================== --- Pile Handlers ---====================================================================== -formatPreferPile y == - y is ["SEQ",:l,[.,.,x]] => - (u:= formatPiles(l,x)) => u - formatSpill("format",y) - formatSpill("format",y) - -formatPiles(l,x) == - $insideTypeExpression : local := false - not $pilesAreOkHere => nil - originalC:= $c - lines:= [:l,x] - --piles must begin at margin - originalC=$m or indent() and newLine() or return nil - null (formatPileLine($m,first lines,false)) => nil - not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil - (originalC=$m or undent()) and originalC --==> brace - -formatPileLine($m,x,newLineIfTrue) == - if newLineIfTrue then newLine() or return nil - $numberOfSpills: local:= 0 - $newLineWritten := nil - format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) - and (x is ['DEF,:.] and optNewLine() or $c) - ---====================================================================== --- Utility Functions ---====================================================================== -nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] - -isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") - -isTrue x == x="true" or x is '(QUOTE T) - -nary2Binary(u,op) == - u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) - errhuh() - -string2PrintImage s == - u:= GETSTR (2*SIZE s) - for i in 0..MAXINDEX s repeat - (if MEMQ(s.i,'(_( _{ _) _} _! _")) then - SUFFIX('__,u); u:= SUFFIX(s.i,u)) - u - -ident2PrintImage s == - m := MAXINDEX s - if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) - u:= GETSTR (2*SIZE s) - if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) - u:= SUFFIX(s.(0),u) - for i in 1..MAXINDEX s repeat - if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) - or (c = char '_!)) then SUFFIX('__,u) - u:= SUFFIX(s.i,u) - INTERN u - -isIdentifier x == - IDENTP x => - s:= PNAME x - #s = 0 => nil - ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] - #s>1 => - or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => - and/[s.i^=char '" " for i in 1..m] => true - -isGensym x == - s := STRINGIMAGE x - n := MAXINDEX s - s.0 = char '_G and and/[DIGITP s.i for i in 1..n] - ---====================================================================== --- Macro Helpers ---====================================================================== -tryToFit(s,x) == ---% try to format on current line; see macro try in file PSPADAUX LISP - --returns nil if unable to format stuff in x on a single line - x => ($back:= rest $back; $c) - restoreState() - nil - -restoreState(:options) == - back := IFCAR options or $back - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] - := back - if null options then $back := back - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - := flags - nil - -saveState(:options) == - flags := - [$newLineWritten, $autoLine, $rightBraceFlag, - $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, - $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, - $doNotResetMarginIfTrue,$noColonDeclaration] - newState := - [ - [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, - $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] - if not KAR options then $back := newState - newState - -formatSC() == - $pileStyle or $semicolonFlag => $c - format "; " - -wrapBraces(x,y,z) == y - -formatLB() == - $pileStyle => $c - $numberOfSpills := - $c > $lineLength / 2 => $braceIndentation/3 - 1 - $braceIndentation/2 - 1 - format "{" - -restoreC() == --used by macro "embrace" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - formatRB originalC - -saveC() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -saveD() == --used by macro "embrace" - $braceStack := [$c,:$braceStack] - -restoreD() == --used by macro "indentNB" - originalC := CAR $braceStack - $braceStack := CDR $braceStack - originalC - -formatRB(originalC) == --called only by restoreC - while $marginStack and $m > originalC repeat undent() - if $m < originalC then $marginStack := [originalC,:$marginStack] - $m := originalC - $pileStyle => $m - newLine() and format "}" and $m --==> brace - diff --git a/src/interp/pspad2.boot.pamphlet b/src/interp/pspad2.boot.pamphlet new file mode 100644 index 00000000..54e9a584 --- /dev/null +++ b/src/interp/pspad2.boot.pamphlet @@ -0,0 +1,683 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp pspad2.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +--====================================================================== +-- Constructor Transformation Functions +--====================================================================== +formatDeftranForm(form,tlist) == + [ttype,:atypeList] := tlist + if form is [":",f,t] then + form := f + ttype := t + if form is ['elt,a,b] then ----> a.b ====> apply(b,a) + form := + isTypeProbably? a => + atypeList := REVERSE atypeList + ["$$", b, a] + ["apply",a, b] + op := KAR form + argl := KDR form + if or/[t for t in atypeList] then + form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] + if ttype then form := [":",form,ttype] + form + +formatDeftran(u,SEQflag) == + u is ['Join,:x] => formatDeftranJoin(u,SEQflag) + u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) + u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) + u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) + u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => + formatDeftranColon(u,SEQflag) + u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + u is ['SEQ,:l,[.,n,x]] => + v := [:l,x] + a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] + b := formatDeftranSEQ(x,false) + if b is [:.,c] and c = '(void) then b := DROP(-1, b) + [:m,y] := [:a,:b] + ['SEQ,:m,['exit,n,y]] +-- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => +-- formatDeftran([op,:CDR arg],nil) + u is ["^",a] => formatDeftran(['not,a],SEQflag) + u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) + u is ['IF,a,b,c] => + a := formatDeftran(a,nil) + b := formatDeftran(b,nil) + c := formatDeftran(c,nil) + null SEQflag and $insideDEF => + [:y,last] := formatDeftranIf(a,b,c) + ['SEQ,:y,['exit,1,last]] + ['IF,a,b,c] + u is ['Union,:argl] => + ['Union,:[x for a in argl + | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] + u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and + ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => + formatDeftran([op,:nitl,nbody],SEQflag) + u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] + u is ["DEF",:.] => formatCapsuleFunction(u) + u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] + u = 'nil => 'empty + u + +formatCapsuleFunction ["DEF",form,tlist,b,body] == + $insideDEF : local := true + ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] + +formatDeftranCapsule(l,x,SEQflag) == + $insideCAPSULE: local := true + formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) + +formatDeftranRepper([op,a],SEQflag) == + a is [op1,b] and MEMQ(op1,'(rep per)) => + op = op1 => formatDeftran(a,SEQflag) + formatDeftran(b,SEQflag) + a is ["::",b,t] => + b := formatDeftran(b,SEQflag) + t := formatDeftran(t,SEQflag) + a := ["::",b,t] + op = 'per and t = "$" or op = 'rep and t = 'Rep => a + [op,a] + a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] + a is ['IF,p,b,c] => + formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) + a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) + a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => + formatDeftran [op1,a,b] + a is ['return,n,r] => + MEMQ(opOf r,'(true false)) => a + ['return,n,[op,formatDeftran(r,SEQflag)]] + a is ['error,:.] => a + [op,formatDeftran(a,SEQflag)] + +formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ + a := formatDeftran(a,SEQflag) + t := formatDeftran(t,SEQflag) + a is ["UNCOERCE",b] => b + a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => + op1 = "pretend" or op = "pretend" => ["pretend",b,t] + null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] + a + a is [=op,b,t1] => + t1 = t => a + [op,b,t] + t = "$" => + a is ['rep,b] => b + a is ['per,b] => a + [op,a,t] + t = "Rep" => + a is ['per,b] => b + a is ['rep,b] => a + [op,a,t] + [op,a,t] + +formatSeqRepper(op,x) == + x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] + x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] + atom x => x + [formatSeqRepper(op,y) for y in x] + +formatDeftranJoin(u,SEQflag) == + ['Join,:cats,lastcat] := u + lastcat is ['CATEGORY,kind,:l,x] => + cat := + CDR cats => ['Join,:cats] + first cats + formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) + u + +formatENUM ['MyENUM, x] == format "'" and format x and format "'" + +formatDeftranREPEAT(itl,body) == +--do nothing unless "itl" contains UNTIL statements + u := [x for x in itl | x is ["UNTIL",p]] or return nil + nitl := SETDIFFERENCE(itl,u) + pred := MKPF([p for ['UNTIL,p] in u],'or) + cond := ['IF,pred,['leave,n,nil],'noBranch] + nbody := + body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] + ['SEQ,body,['exit,n,cond]] + [nitl,:nbody] + +formatDeftranSEQ(x,flag) == + u := formatDeftran(x,flag) + u is ['SEQ,:.] => rest u + [u] + +formatDeftranIf(a,b,c) == + b = 'noBranch => + a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); + iop := LASSOC(op, al) or rassoc(op, al)) => + [["=>",[iop, :r],c]] + a is [op,r] and MEMQ(op,'(NOT not NULL null)) => + [["=>", r, c]] + [["=>", ['not, a], c]] + post := + c = 'noBranch => nil + c is ['SEQ,:.] => CDR c + [c] + [["=>",a,b],:post] + +formatWHERE ["where",a,b] == + $insideTypeExpression: local := nil + $insideCAPSULE: local := false + tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") + +--====================================================================== +-- Special Handlers: Categories +--====================================================================== +formatATTRIBUTE ['ATTRIBUTE,att] == format att + +formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] + +formatCategory ['Category] == format " " and format "Category" + +formatCATEGORY cat == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + format ["with",formatDeftranCategory cat] + +formatSIGNATURE ['SIGNATURE,op,types,:r] == + MEMQ('constant,r) => format op and format ": " and (u := format first types) and + formatSC() and formatComments(u,op,types) + format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and + formatComments(u,op,types) + +formatDefault ["default",a] == + $insideCategoryIfTrue : local := false + $insideCAPSULE: local := true + $insideTypeExpression: local := false + tryBreak(format "default ",a,"with","Nud") +--====================================================================== +-- Special Handlers: Control Structures +--====================================================================== +formatUNCOERCE ['UNCOERCE,x] == format x + +formatIF ['IF,a,b,c] == + c = 'noBranch => formatIF2(a,b,"if ") + b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] + formatIF2(a,b,"if ") and newLine() and formatIF3 c + +formatIF2(a,b,prefix) == + tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") + +formatIF3 x == + x is ['IF,a,b,c] => + c = 'noBranch => tryBreak(format "else if " + and format a and format " then ",b,"then","Nud") + formatIF2(a,b,"else if ") and newLine() and formatIF3 c + tryBreak(format "else ",x,"else","Nud") + +formatBlock(l,x) == + null l => format x + $pilesAreOkHere: local + format "{ " and format first l and + (and/[formatSC() and format y for y in rest l]) + and formatSC() and format x and format " }" + +formatExit ["exit",.,u] == format u + +formatvoid ["void"] == format "()" + +formatLeave ["leave",.,u] == format "break" + +formatCOLLECT u == formatSpill("formatCOLLECT1",u) + +formatCOLLECT1 ["COLLECT",:iteratorList,body] == + $pilesAreOkHere: local + format "[" and format body and format " " and + formatSpill("formatIteratorTail",iteratorList) + +formatIteratorTail iteratorList == + formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" + +--====================================================================== +-- Special Handlers: Keywords +--====================================================================== + +formatColon [":",a,b] == + b is ['with,c,:d] => formatColonWith(a,c,d) + if not $insideTypeExpression then + insideCat() => nil + format + $insideDEF => "local " + "default " + op := + $insideCAPSULE and not $insideDEF => ": " + insideCat() => ": " + ":" + b := (atom b => b; markMacroTran b) + a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b + formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), + formatOpBindingPower(":","Led","right")) + +formatColonWith(form,a,b) == + con := opOf $form + $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) + $insideEXPORTS : local := true + $pilesAreOkHere: local := true + $insideTypeExpression : local := false + b => tryBreak(formatDefForm form and format ": " + and format a and format " with ",first b,"with","Led") + tryBreak(formatDefForm form and format ": with ",a,"with","Nud") + +formatCOND ["COND",:l] == + originalC:= $c + and/[x is [a,[.,.,b]] for x in l] => + (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and + formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC + formatIfThenElse l + +formatPROGN ["PROGN",:l] == + l is [:u,x] => formatPiles(u,x) + error '"formatPROGN" + +formatELT ["ELT",a,b] == formatApplication [a,b] + +formatCONS ["CONS",a,b] == + $pilesAreOkHere: local + format "[" and formatConstructItem a and formatTail b + +formatTail x == + null x => format "]" + format "," and formatTail1 x + +formatTail1 x == + x is ["CONS",a,b] => formatConstructItem a and formatTail b + x is ["APPEND",a,b] => + null b => formatConstructItem a and format "]" + format ":" and formatConstructItem a and formatTail b + format ":" and formatConstructItem x and format "]" + +-- x = "." => format " " +formatConstructItem x == format x + +formatLET ["LET",a,b] == + $insideTypeExpression: local := true + a = "Rep" or atom a and constructor? opOf b => + tryBreakNB(formatAtom a and format " == ",b,":=","Led") + tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") + +formatIfExit(a,b) == + --called from SCOND or COND only + $numberOfSpills: local:= 0 + curMargin:= $m + curMarginStack:= $currentMarginStack + $doNotResetMarginIfTrue:= true + format a and format " => " and formatRight("formatCut",b,"=>","Led") => + ($currentMarginStack:= curMarginStack; $m:= curMargin) + +formatIfThenElse x == formatSpill("formatIf1",x) + +formatIf1 x == + x is [[a,:r],:c] and null c => + b:= + r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] + first r + isTrue a => format b + format "if " and format a and format " then " and format b + format "if " and format a and + (try + (format " then " and format b and format " else " + and formatIfThenElse c) or spillLine() + and format " then " and format b and +-- ($c:= $m:= $m+6) and + ($numberOfSpills:= $numberOfSpills-1) + and spillLine() and format " else " and formatIfThenElse c) + +formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" + +formatMI ["MI",a,b] == format a + +formatMapping ['Mapping,target,:sources] == + $noColonDeclaration: local := true + formatTuple ['Tuple,:sources] and format " -> " and format target + +formatTuple ['Tuple,:types] == + null types => format "()" + null rest types => format first types + formatFunctionCallTail types + +formatConstruct(['construct,:u]) == + format "[" and (null u or format first u and + "and"/[format "," and formatCut x for x in rest u]) and format "]" + +formatNextConstructItem x == + try format x or ($m := $m + 2) and newLine() and format x + +formatREPEAT ["REPEAT",:iteratorList,body] == + tryBreakNB(null iteratorList or (formatIterator first iteratorList and + (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") + and format "repeat ",body,"repeat","Led") + +formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") + +formatMap ["+->",a,b] == + $noColonDeclaration: local := true + tryBreak(format a and format " +-> ", b, "+->","Led") + +formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) + +formatreduce ["reduce",op,u] == formatReduce1(op,u) + +formatReduce1(op,u) == + if STRINGP op then op := INTERN op + id := LASSOC(op, + '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) + formatFunctionCall + id => ['reduce,op,u,id] + ['reduce,op,u] + +formatIterator u == + $noColonDeclaration : local := true + u is ["IN",x,y] => + format "for " and formatLeft("format",x,"in","Led") and format " in " and + formatRight("format",y,"in","Led") + u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") + u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") + u is ["|",x] => format "| " and formatRight("format",x,"|","Led") + u is ["STEP",i,init,step,:v] => + final := IFCAR v + format "for " and formatLeft("format",i,"in","Led") and format " in " and + (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) + error "formatIterator" + +formatStepOne? step == + step = 1 or step = '(One) => true + step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) + false + +formatBy ['by,seg,step] == format seg and format " by " and format step + +formatSCOND ["SCOND",:l] == + $pilesAreOkHere => + --called from formatPileLine or formatBlock + --if from formatPileLine + initialC:= $c + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC + formatIfThenElse l and initialC + and/[x is [a,["exit",.,b]] for x in l] => + first l is [a,["exit",.,b]] and formatIfExit(a,b) and + (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c + --warning: and/(...) returns T if there are no entries + formatIfThenElse l + +formatSEGMENT ["SEGMENT",a,b] == + $pilesAreOkHere: local + (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and + formatInfixOp ".." and + (null b and $c or + (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) + +formatSexpr x == + atom x => + null x or IDENTP x => consBuffer ident2PrintImage PNAME x + consBuffer x + spill("formatNonAtom",x) + +formatNonAtom x == + format "_(" and formatSexpr first x and + (and/[format " " and formatSexpr y for y in rest x]) + and (y:= LASTATOM x => format " . " + and formatSexpr y; true) and format "_)" + +formatCAPSULE ['CAPSULE,:l,x] == + $insideCAPSULE: local := true + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +formatPAREN [.,:argl] == formatFunctionCallTail argl + +formatSEQ ["SEQ",:l,[.,.,x]] == + try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) + +--====================================================================== +-- Comment Handlers +--====================================================================== +formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == + $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] + format x + +formatComments(u,op,types) == + $numberOfSpills :local := $commentIndentation/2 - 1 + not $insideEXPORTS => u + alist := LASSOC(op,$comments) or + sayBrightly ['"No documentation for ",op] + return u + ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) + consComments(LASSOC(ftypes,alist),'"++ ") + u + +consComments(s,plusPlus) == + s is [word,:r] and null atom r => consComments(r, plusPlus) + s := first s + null s => nil + s := consCommentsTran s + indent() and newLine() or return nil + columnsLeft := $lineLength - $m - 2 + while (m := MAXINDEX s) >= columnsLeft repeat + k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] + k := (k => k + 1; columnsLeft) + piece := SUBSTRING(s,0,k) + formatDoCommentLine [plusPlus,piece] + s := SUBSTRING(s,k,nil) + formatDoCommentLine [plusPlus,s] + undent() + $m + +consCommentsTran s == + m := MAXINDEX s + k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => + r := charPosition(char '_},s,k + 6) + r = m + 1 => s + STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) + s + +formatDoCommentLine line == + $lineBuffer := consLineBuffer [nBlanks $c,:line] + $c := $m+2*$numberOfSpills + +--====================================================================== +-- Pile Handlers +--====================================================================== +formatPreferPile y == + y is ["SEQ",:l,[.,.,x]] => + (u:= formatPiles(l,x)) => u + formatSpill("format",y) + formatSpill("format",y) + +formatPiles(l,x) == + $insideTypeExpression : local := false + not $pilesAreOkHere => nil + originalC:= $c + lines:= [:l,x] + --piles must begin at margin + originalC=$m or indent() and newLine() or return nil + null (formatPileLine($m,first lines,false)) => nil + not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil + (originalC=$m or undent()) and originalC --==> brace + +formatPileLine($m,x,newLineIfTrue) == + if newLineIfTrue then newLine() or return nil + $numberOfSpills: local:= 0 + $newLineWritten := nil + format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) + and (x is ['DEF,:.] and optNewLine() or $c) + +--====================================================================== +-- Utility Functions +--====================================================================== +nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] + +isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") + +isTrue x == x="true" or x is '(QUOTE T) + +nary2Binary(u,op) == + u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) + errhuh() + +string2PrintImage s == + u:= GETSTR (2*SIZE s) + for i in 0..MAXINDEX s repeat + (if MEMQ(s.i,'(_( _{ _) _} _! _")) then + SUFFIX('__,u); u:= SUFFIX(s.i,u)) + u + +ident2PrintImage s == + m := MAXINDEX s + if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) + u:= GETSTR (2*SIZE s) + if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) + u:= SUFFIX(s.(0),u) + for i in 1..MAXINDEX s repeat + if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) + or (c = char '_!)) then SUFFIX('__,u) + u:= SUFFIX(s.i,u) + INTERN u + +isIdentifier x == + IDENTP x => + s:= PNAME x + #s = 0 => nil + ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] + #s>1 => + or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => + and/[s.i^=char '" " for i in 1..m] => true + +isGensym x == + s := STRINGIMAGE x + n := MAXINDEX s + s.0 = char '_G and and/[DIGITP s.i for i in 1..n] + +--====================================================================== +-- Macro Helpers +--====================================================================== +tryToFit(s,x) == +--% try to format on current line; see macro try in file PSPADAUX LISP + --returns nil if unable to format stuff in x on a single line + x => ($back:= rest $back; $c) + restoreState() + nil + +restoreState(:options) == + back := IFCAR options or $back + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] + := back + if null options then $back := back + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + := flags + nil + +saveState(:options) == + flags := + [$newLineWritten, $autoLine, $rightBraceFlag, + $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, + $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, + $doNotResetMarginIfTrue,$noColonDeclaration] + newState := + [ + [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, + $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] + if not KAR options then $back := newState + newState + +formatSC() == + $pileStyle or $semicolonFlag => $c + format "; " + +wrapBraces(x,y,z) == y + +formatLB() == + $pileStyle => $c + $numberOfSpills := + $c > $lineLength / 2 => $braceIndentation/3 - 1 + $braceIndentation/2 - 1 + format "{" + +restoreC() == --used by macro "embrace" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + formatRB originalC + +saveC() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +saveD() == --used by macro "embrace" + $braceStack := [$c,:$braceStack] + +restoreD() == --used by macro "indentNB" + originalC := CAR $braceStack + $braceStack := CDR $braceStack + originalC + +formatRB(originalC) == --called only by restoreC + while $marginStack and $m > originalC repeat undent() + if $m < originalC then $marginStack := [originalC,:$marginStack] + $m := originalC + $pileStyle => $m + newLine() and format "}" and $m --==> brace + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/redefs.boot.pamphlet b/src/interp/redefs.boot.pamphlet new file mode 100644 index 00000000..519c3fbb --- /dev/null +++ b/src/interp/redefs.boot.pamphlet @@ -0,0 +1,92 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp redefs.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +BLANKS n== MAKE_-FULL_-CVEC (n) + +object2String x== + STRINGP x=>x + IDENTP x=> PNAME x + STRINGIMAGE x + +sayMSG x== shoeConsole x +sayBrightly x== + brightPrint x + TERPRI() +;;char x==CHAR(PNAME x,0) +pathname x==CONCAT(PNAME(x.0),'".",PNAME(x.1)) +CVECP x== STRINGP x +concat(:l) == concatList l + +concatList [x,:y] == + null y => x + null x => concatList y + concat1(x,concatList y) + +concat1(x,y) == + null x => y + atom x => (null y => x; atom y => [x,y]; [x,:y]) + null y => x + atom y => [:x,y] + [:x,:y] + +--$FILESIZE x== +-- a:=OPEN MAKE_-INPUT_-FILENAME x +-- b:=FILE_-LENGTH a +-- CLOSE a +-- b +SPADCATCH(x,y)==CATCH(x,y) +SPADTHROW(x,y)==THROW(x,y) +listSort(f,l)== SORT(l,f) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/rulesets.boot b/src/interp/rulesets.boot deleted file mode 100644 index 66f79f7b..00000000 --- a/src/interp/rulesets.boot +++ /dev/null @@ -1,303 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---% Mode and Type Resolution Rule Data and Ruleset Creation - ---% resolveTT Rules - --- These rules are applied only once at the outermost position of a term --- some things can't be done by term rewriting conveniently (e.g. set --- difference), so a form is created which is interpreted by --- resolveTTRed later. The meanings of these forms are: --- Incl(x,y): y if x is a member of y, failed otherwise --- SetEqual(x,y): x if y is a permutation of x, failed otherwise --- SetComp(x,y): x-y, if y is a subset of x, failed otherwise --- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise --- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... - --- These first rules will be expanded for each of MP, DMP and NDMP - -SETANDFILEQ($mpolyTTRules,'( _ - ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (mpoly1 x t1) (G t2)) . _ - (mpoly1 x (G (VarEqual t1 t2)))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) t2)) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ - (mpoly1 (SetInter x y) (Resolve _ - (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ - )) - --- These are the general rules, excluding those above. - -SETANDFILEQ($generalTTRules, '( _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (EQ t1) (B)) . (B)) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ - ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ - ((Resolve (SM x t1) (RM y y t2)) . _ - (SM (VarEqual x y) (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (F) (RN)) . (F) ) _ - _ - ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ - ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ - _ - ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ - ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ - ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ - ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ - _ - ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ - ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ - ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ - _ - ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ - ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ - ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ - ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ - _ - ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ - ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ - ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ - _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (DMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ - _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP y (Resolve (MP (SetComp x y) t1) t2))) _ - ((Resolve (MP x t1) (NDMP y t2)) . _ - (MP (SetInter x y) (Resolve _ - (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetEqual x y) (Resolve t1 t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ - ((Resolve (DMP x t1) (NDMP y t2)) . _ - (DMP (SetInter x y) (Resolve _ - (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ - )) - --- The following creates the ruleset - -createResolveTTRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] - $Res := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) - true - ---% resolveTM Rules - --- Same rules as for resolveTT, with two exceptions: --- Diff(x,y): removes y from x, if possible, failed otherwise --- SetIncl(x,y): y if x is a subset of y, failed otherwise - --- These first rules will be expanded for each of MP, DMP and NDMP - -SETANDFILEQ($mpolyTMRules,'( _ - ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ - ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ - ((Resolve (mpoly1 x t1) (UP y t2)) . _ - (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ - ((Resolve (UP x t1) (mpoly1 y t2)) . _ - (Resolve t1 (mpoly1 (Incl x y) t2))) _ - ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ - (mpoly1 (Incl x y) (Resolve (I) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ - ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ - (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ - )) - --- These are the general rules, excluding those above. - -SETANDFILEQ($generalTMRules,'( _ - ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UP y t1)) . _ - (UP (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (UPS y t1)) . _ - (UPS (VarEqual x y) (Resolve (I) t1))) _ - ((Resolve (VARIABLE x) (CFPS y t1)) . _ - (CFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (ELFPS y t1)) . _ - (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ - ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ - ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ - ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ - ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ - ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ - ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ - ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ - ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ - _ - ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ - ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ - ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ - _ - ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ - ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ - ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ - _ - ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ - ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ - ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ - ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ - )) - --- Private abbreviation table for resolve rules -SETANDFILEQ($resolveAbbreviations, '( _ - (P . Polynomial) _ - (G . Gaussian) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . FactoredForm) _ - (FR . FactoredRing) _ - (RN . RationalNumber) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePoly) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . QuotientField) _ - (RF . RationalFunction) _ - (RE . RadicalExtension) _ - (RR . RationalRadicals) _ - (UPS . UnivariatePowerSeries) _ - (CFPS . ContinuedFractionPowerSeries) _ - (ELFPS . EllipticFunctionPowerSeries) _ - (EF . ElementaryFunction) _ - (VARIABLE . Variable) _ - )) - -SETANDFILEQ($newResolveAbbreviations, '( _ - (P . Polynomial) _ - (G . Complex) _ - (L . List) _ - (M . Matrix) _ - (EQ . Equation) _ - (B . Boolean) _ - (SY . Symbol) _ - (I . Integer) _ - (SM . SquareMatrix) _ - (RM . RectangularMatrix) _ - (V . Vector) _ - (FF . Factored) _ - (FR . Factored) _ - (F . Float) _ - (OV . OrderedVariableList) _ - (UP . UnivariatePolynomial) _ - (DMP . DistributedMultivariatePolynomial) _ - (MP . MultivariatePolynomial) _ - (HDMP . HomogeneousDistributedMultivariatePolynomial) _ - (QF . Fraction) _ - (UPS . UnivariatePowerSeries) _ - (VARIABLE . Variable) _ - )) - --- The following creates the ruleset - -createResolveTMRules() == - -- expand multivariate polynomial rules - mps := '(MP DMP NDMP) - mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] - mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] - $ResMode := CONS('(t1 t2 x y), - EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) - true - -createTypeEquivRules() == - -- used by eqType, for example - $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( - ((QF (P t1)) . (RF t1)) - ((QF (I)) . (RN)) - ((RE (RN)) . (RR)) ))) - $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) - true - -initializeRuleSets() == - $abList: local := - ASSOCLEFT $newResolveAbbreviations - $nameList: local := - ASSOCRIGHT $newResolveAbbreviations - createResolveTTRules() - createResolveTMRules() - createTypeEquivRules() - $ruleSetsInitialized := true - true diff --git a/src/interp/rulesets.boot.pamphlet b/src/interp/rulesets.boot.pamphlet new file mode 100644 index 00000000..b2ceefa6 --- /dev/null +++ b/src/interp/rulesets.boot.pamphlet @@ -0,0 +1,325 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp rulesets.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--% Mode and Type Resolution Rule Data and Ruleset Creation + +--% resolveTT Rules + +-- These rules are applied only once at the outermost position of a term +-- some things can't be done by term rewriting conveniently (e.g. set +-- difference), so a form is created which is interpreted by +-- resolveTTRed later. The meanings of these forms are: +-- Incl(x,y): y if x is a member of y, failed otherwise +-- SetEqual(x,y): x if y is a permutation of x, failed otherwise +-- SetComp(x,y): x-y, if y is a subset of x, failed otherwise +-- SetInter(x,y): intersection of x and y, if nonempty, failed otherwise +-- SetDiff(x,y): x-y, if x and y have a nonempty intersection, failed ... + +-- These first rules will be expanded for each of MP, DMP and NDMP + +SETANDFILEQ($mpolyTTRules,'( _ + ((Resolve (RN) (mpoly1 x t1)) . (mpoly1 x (Resolve (RN) t1))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (mpoly1 x t1) (G t2)) . _ + (mpoly1 x (G (VarEqual t1 t2)))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) t2)) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 x (Resolve t1 (mpoly1 (SetComp y x) t2)))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly1 y t2)) . _ + (mpoly1 (SetInter x y) (Resolve _ + (mpoly1 (SetDiff x y) t1) (mpoly1 (SetDiff y x) t2)))) _ + )) + +-- These are the general rules, excluding those above. + +SETANDFILEQ($generalTTRules, '( _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (EQ t1) (B)) . (B)) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (M t1) (SM x t2)) . (M (Resolve t1 t2))) _ + ((Resolve (M t1) (RM x y t2)) . (M (Resolve t1 t2))) _ + ((Resolve (SM x t1) (RM y y t2)) . _ + (SM (VarEqual x y) (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (V (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (F) (RN)) . (F) ) _ + _ + ((Resolve (OV x) (OV y)) . (OV (SetUnion x y))) _ + ((Resolve (P t1) (UP y t2)) . (Resolve (P t1) t2)) _ + _ + ((Resolve (UP y t1) (G t2)) . (UP y (G (VarEqual t1 t2)))) _ + ((Resolve (P t1) (P t2)) . (P (Resolve t1 t2))) _ + ((Resolve (G t1) (G t2)) . (G (Resolve t1 t2))) _ + ((Resolve (G t1) (P t2)) . (P (G (VarEqual t1 t2)))) _ + _ + ((Resolve (AF t1) (EF t2)) . (EF (Resolve t1 t2))) _ + ((Resolve (AF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (AF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (EF t1) (LF t2)) . (LF (Resolve t1 t2))) _ + ((Resolve (EF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + ((Resolve (LF t1) (FE t2)) . (FE (Resolve t1 t2))) _ + _ + ((Resolve (RN) (P t1)) . (P (Resolve (RN) t1))) _ + ((Resolve (RN) (UP x t1)) . (UP x (Resolve (RN) t1))) _ + ((Resolve (RN) (UPS x t1)) . (UPS x (Resolve (RN) t1))) _ + ((Resolve (RN) (CFPS x t1)) . (CFPS x (Resolve (RN) t1))) _ + _ + ((Resolve (RR) (EF t1)) . (EF (Resolve (RR) t1))) _ + ((Resolve (P t1) (AF t2)) . (AF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (EF t2)) . (EF (Resolve t1 t2 ))) _ + ((Resolve (P t1) (LF t2)) . (LF (Resolve t1 t2 ))) _ + _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP x (Resolve t1 (DMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (DMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (DMP (SetDiff y x) t2)))) _ + _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP y (Resolve (MP (SetComp x y) t1) t2))) _ + ((Resolve (MP x t1) (NDMP y t2)) . _ + (MP (SetInter x y) (Resolve _ + (MP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetEqual x y) (Resolve t1 t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP x (Resolve t1 (NDMP (SetComp y x) t2)))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP y (Resolve (DMP (SetComp x y) t1) t2))) _ + ((Resolve (DMP x t1) (NDMP y t2)) . _ + (DMP (SetInter x y) (Resolve _ + (DMP (SetDiff x y) t1) (NDMP (SetDiff y x) t2)))) _ + )) + +-- The following creates the ruleset + +createResolveTTRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules := "append"/[SUBST(mp,'mpoly1,$mpolyTTRules) for mp in mps] + $Res := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append($generalTTRules,mpRules))) + true + +--% resolveTM Rules + +-- Same rules as for resolveTT, with two exceptions: +-- Diff(x,y): removes y from x, if possible, failed otherwise +-- SetIncl(x,y): y if x is a subset of y, failed otherwise + +-- These first rules will be expanded for each of MP, DMP and NDMP + +SETANDFILEQ($mpolyTMRules,'( _ + ((Resolve (mpoly1 x t1) (P t2)) . (Resolve t1 (P t2))) _ + ((Resolve (mpoly1 (x) t1) (UP x t2)) . (UP x (Resolve t1 t2))) _ + ((Resolve (mpoly1 x t1) (UP y t2)) . _ + (UP y (Resolve (mpoly1 (Diff x y) t1) t2))) _ + ((Resolve (UP x t1) (mpoly1 y t2)) . _ + (Resolve t1 (mpoly1 (Incl x y) t2))) _ + ((Resolve (VARIABLE x) (mpoly1 y t2)) . _ + (mpoly1 (Incl x y) (Resolve (I) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve t1 (mpoly2 (SetIncl x y) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (mpoly2 y (Resolve (mpoly1 (SetComp x y) t1) t2))) _ + ((Resolve (mpoly1 x t1) (mpoly2 y t2)) . _ + (Resolve (mpoly1 (SetDiff x y) t1) (mpoly2 y t2))) _ + )) + +-- These are the general rules, excluding those above. + +SETANDFILEQ($generalTMRules,'( _ + ((Resolve (VARIABLE x) (P t1)) . (P (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UP y t1)) . _ + (UP (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (UPS y t1)) . _ + (UPS (VarEqual x y) (Resolve (I) t1))) _ + ((Resolve (VARIABLE x) (CFPS y t1)) . _ + (CFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (ELFPS y t1)) . _ + (ELFPS (VarEqual x y) (Resolve (RN) t1))) _ + ((Resolve (VARIABLE x) (EF t1)) . (EF t1)) _ + ((Resolve (L (L (SY))) (M _*_*)) . (M (P (I)))) _ + ((Resolve (L (L (SY))) (SM x _*_*)) . (SM x (P (I)))) _ + ((Resolve (L (L t1)) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (SM x t2)) . (SM x (Resolve t1 t2))) _ + ((Resolve (L (L t1)) (RM x y t2)) . (RM x y (Resolve t1 t2))) _ + ((Resolve (SY) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (VARIABLE x) t1) . (Resolve (P (I)) t1)) _ + ((Resolve (SM x t1) (M t2)) . (M (Resolve t1 t2))) _ + ((Resolve (RM x y t1) (M t2)) . (M (Resolve t1 t2))) _ + _ + ((Resolve (M t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (SM x t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (RM x y t1) (L _*_*)) . (L (L t1))) _ + ((Resolve (M t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (SM x t1) (L t2)) . (L (Resolve (L t1) t2))) _ + ((Resolve (RM x y t1) (L t2)) . (L (Resolve (L t1) t2))) _ + _ + ((Resolve (M t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (SM x t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (RM x y t1) (V _*_*)) . (V (V t1))) _ + ((Resolve (M t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (SM x t1) (V t2)) . (V (Resolve (V t1) t2))) _ + ((Resolve (RM x y t1) (V t2)) . (V (Resolve (V t1) t2))) _ + _ + ((Resolve (L t1) (V t2)) . (V (Resolve t1 t2))) _ + ((Resolve (V t1) (L t2)) . (L (Resolve t1 t2))) _ + ((Resolve (FF t1) (FR t2)) . (FR (Resolve t1 t2))) _ + ((Resolve (UP x t1) (P t2)) . (Resolve t1 (P t2))) _ + )) + +-- Private abbreviation table for resolve rules +SETANDFILEQ($resolveAbbreviations, '( _ + (P . Polynomial) _ + (G . Gaussian) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . FactoredForm) _ + (FR . FactoredRing) _ + (RN . RationalNumber) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePoly) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . QuotientField) _ + (RF . RationalFunction) _ + (RE . RadicalExtension) _ + (RR . RationalRadicals) _ + (UPS . UnivariatePowerSeries) _ + (CFPS . ContinuedFractionPowerSeries) _ + (ELFPS . EllipticFunctionPowerSeries) _ + (EF . ElementaryFunction) _ + (VARIABLE . Variable) _ + )) + +SETANDFILEQ($newResolveAbbreviations, '( _ + (P . Polynomial) _ + (G . Complex) _ + (L . List) _ + (M . Matrix) _ + (EQ . Equation) _ + (B . Boolean) _ + (SY . Symbol) _ + (I . Integer) _ + (SM . SquareMatrix) _ + (RM . RectangularMatrix) _ + (V . Vector) _ + (FF . Factored) _ + (FR . Factored) _ + (F . Float) _ + (OV . OrderedVariableList) _ + (UP . UnivariatePolynomial) _ + (DMP . DistributedMultivariatePolynomial) _ + (MP . MultivariatePolynomial) _ + (HDMP . HomogeneousDistributedMultivariatePolynomial) _ + (QF . Fraction) _ + (UPS . UnivariatePowerSeries) _ + (VARIABLE . Variable) _ + )) + +-- The following creates the ruleset + +createResolveTMRules() == + -- expand multivariate polynomial rules + mps := '(MP DMP NDMP) + mpRules0 := "append"/[SUBST(mp,'mpoly1,$mpolyTMRules) for mp in mps] + mpRules := "append"/[SUBST(mp,'mpoly2,mpRules0) for mp in mps] + $ResMode := CONS('(t1 t2 x y), + EQSUBSTLIST($nameList,$abList,append(mpRules,$generalTMRules))) + true + +createTypeEquivRules() == + -- used by eqType, for example + $TypeEQ := CONS('(t1), EQSUBSTLIST($nameList,$abList,'( + ((QF (P t1)) . (RF t1)) + ((QF (I)) . (RN)) + ((RE (RN)) . (RR)) ))) + $TypeEqui := CONS(CAR $TypeEQ, [[b,:a] for [a,:b] in CDR $TypeEQ]) + true + +initializeRuleSets() == + $abList: local := + ASSOCLEFT $newResolveAbbreviations + $nameList: local := + ASSOCRIGHT $newResolveAbbreviations + createResolveTTRules() + createResolveTMRules() + createTypeEquivRules() + $ruleSetsInitialized := true + true +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/server.boot b/src/interp/server.boot deleted file mode 100644 index 01a4a073..00000000 --- a/src/interp/server.boot +++ /dev/null @@ -1,218 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - --- Scratchpad-II server - --- Assoc list of interpreter frame names and unique integer identifiers - -SETANDFILEQ($frameAlist, nil) -SETANDFILEQ($frameNumber, 0) -SETANDFILEQ($currentFrameNum, 0) -SETANDFILEQ($EndServerSession, false) -SETANDFILEQ($NeedToSignalSessionManager, false) -SETANDFILEQ($sockBufferLength, 9217) - -serverReadLine(stream) == --- used in place of READ-LINE in a scratchpad server system. - FORCE_-OUTPUT() - not $SpadServer or not IS_-CONSOLE stream => - READ_-LINE(stream) - IN_-STREAM: fluid := stream - _*EOF_*: fluid := NIL - line := - while not $EndServerSession and not _*EOF_* repeat - if $NeedToSignalSessionManager then - sockSendInt($SessionManager, $EndOfOutput) - $NeedToSignalSessionManager := false - action := serverSwitch() - action = $CallInterp => - l := READ_-LINE(stream) - $NeedToSignalSessionManager := true - return l - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING $sockBufferLength - sockGetString($MenuServer, stringBuf, $sockBufferLength) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - protectedEVAL form - action = $QuietSpadCommand => - $NeedToSignalSessionManager := true - executeQuietCommand() - action = $SpadCommand => - $NeedToSignalSessionManager := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - action = $NonSmanSession => - $SpadServer := nil - action = $KillLispSystem => - BYE() - NIL - line => line - "" - -parseAndInterpret str == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - $useNewParser => - ncParseAndInterpretString str - oldParseAndInterpret str - -oldParseAndInterpret str == - tree := string2SpadTree str - tree => processInteractive(parseTransform postTransform tree, NIL) - NIL - -executeQuietCommand() == - $QuietCommand: fluid := true - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - --- Includued for compatability with old-parser systems -serverLoop() == - IN_-STREAM: fluid := CURINSTREAM - _*EOF_*: fluid := NIL - while not $EndServerSession and not _*EOF_* repeat - if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) - $Prompt := NIL - action := serverSwitch() - action = $CallInterp => - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret READ_-LINE(CURINSTREAM) ))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - action = $CreateFrame => - frameName := GENTEMP('"frame") - addNewInterpreterFrame(frameName) - $frameAlist := [[$frameNumber,:frameName], :$frameAlist] - $currentFrameNum := $frameNumber - sockSendInt($SessionManager, $frameNumber) - $frameNumber := $frameNumber + 1 - sockSendString($SessionManager, MKPROMPT()) - action = $SwitchFrames => - $currentFrameNum := sockGetInt($SessionManager) - currentFrame := LASSOC($currentFrameNum, $frameAlist) - changeToNamedInterpreterFrame currentFrame - action = $EndSession => - $EndServerSession := true - action = $LispCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - form := unescapeStringsInForm READ_-FROM_-STRING stringBuf - EVAL form - action = $QuietSpadCommand => - executeQuietCommand() - action = $SpadCommand => - stringBuf := MAKE_-STRING 512 - sockGetString($MenuServer, stringBuf, 512) - CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, - parseAndInterpret stringBuf))) - PRINC MKPROMPT() - FINISH_-OUTPUT() - sockSendInt($SessionManager, $EndOfOutput) - NIL - if _*EOF_* then $Prompt := true - NIL - -parseAndEvalToHypertex str == - lines := parseAndEvalToStringForHypertex str - len := LENGTH lines - sockSendInt($MenuServer, len) - for s in lines repeat - sockSendString($MenuServer, s) - -parseAndEvalToString str == - $collectOutput:local := true - $outputLines: local := nil - $IOindex: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringForHypertex str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndEvalToStringEqNum str == - $collectOutput:local := true - $outputLines: local := nil - v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) - v = 'restart => ['"error"] - NREVERSE $outputLines - -parseAndInterpToString str == - v := applyWithOutputToString('parseAndEvalStr, [str]) - breakIntoLines CDR v - -parseAndEvalStr string == - $InteractiveMode :fluid := true - $BOOT: fluid := NIL - $SPAD: fluid := true - $e:fluid := $InteractiveFrame - parseAndEvalStr1 string - -parseAndEvalStr1 string == - string.0 = char '")" => - doSystemCommand SUBSEQ(string, 1) - processInteractive(ncParseFromString string, NIL) - -protectedEVAL x == - error := true - val := NIL - UNWIND_-PROTECT((val := EVAL x; error := NIL), - error => (resetStackLimits(); sendHTErrorSignal())) - val diff --git a/src/interp/server.boot.pamphlet b/src/interp/server.boot.pamphlet new file mode 100644 index 00000000..3af5ccdb --- /dev/null +++ b/src/interp/server.boot.pamphlet @@ -0,0 +1,240 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp server.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +-- Scratchpad-II server + +-- Assoc list of interpreter frame names and unique integer identifiers + +SETANDFILEQ($frameAlist, nil) +SETANDFILEQ($frameNumber, 0) +SETANDFILEQ($currentFrameNum, 0) +SETANDFILEQ($EndServerSession, false) +SETANDFILEQ($NeedToSignalSessionManager, false) +SETANDFILEQ($sockBufferLength, 9217) + +serverReadLine(stream) == +-- used in place of READ-LINE in a scratchpad server system. + FORCE_-OUTPUT() + not $SpadServer or not IS_-CONSOLE stream => + READ_-LINE(stream) + IN_-STREAM: fluid := stream + _*EOF_*: fluid := NIL + line := + while not $EndServerSession and not _*EOF_* repeat + if $NeedToSignalSessionManager then + sockSendInt($SessionManager, $EndOfOutput) + $NeedToSignalSessionManager := false + action := serverSwitch() + action = $CallInterp => + l := READ_-LINE(stream) + $NeedToSignalSessionManager := true + return l + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING $sockBufferLength + sockGetString($MenuServer, stringBuf, $sockBufferLength) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + protectedEVAL form + action = $QuietSpadCommand => + $NeedToSignalSessionManager := true + executeQuietCommand() + action = $SpadCommand => + $NeedToSignalSessionManager := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + action = $NonSmanSession => + $SpadServer := nil + action = $KillLispSystem => + BYE() + NIL + line => line + "" + +parseAndInterpret str == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + $useNewParser => + ncParseAndInterpretString str + oldParseAndInterpret str + +oldParseAndInterpret str == + tree := string2SpadTree str + tree => processInteractive(parseTransform postTransform tree, NIL) + NIL + +executeQuietCommand() == + $QuietCommand: fluid := true + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + +-- Includued for compatability with old-parser systems +serverLoop() == + IN_-STREAM: fluid := CURINSTREAM + _*EOF_*: fluid := NIL + while not $EndServerSession and not _*EOF_* repeat + if $Prompt then (PRINC MKPROMPT(); FINISH_-OUTPUT()) + $Prompt := NIL + action := serverSwitch() + action = $CallInterp => + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret READ_-LINE(CURINSTREAM) ))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + action = $CreateFrame => + frameName := GENTEMP('"frame") + addNewInterpreterFrame(frameName) + $frameAlist := [[$frameNumber,:frameName], :$frameAlist] + $currentFrameNum := $frameNumber + sockSendInt($SessionManager, $frameNumber) + $frameNumber := $frameNumber + 1 + sockSendString($SessionManager, MKPROMPT()) + action = $SwitchFrames => + $currentFrameNum := sockGetInt($SessionManager) + currentFrame := LASSOC($currentFrameNum, $frameAlist) + changeToNamedInterpreterFrame currentFrame + action = $EndSession => + $EndServerSession := true + action = $LispCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + form := unescapeStringsInForm READ_-FROM_-STRING stringBuf + EVAL form + action = $QuietSpadCommand => + executeQuietCommand() + action = $SpadCommand => + stringBuf := MAKE_-STRING 512 + sockGetString($MenuServer, stringBuf, 512) + CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER, + parseAndInterpret stringBuf))) + PRINC MKPROMPT() + FINISH_-OUTPUT() + sockSendInt($SessionManager, $EndOfOutput) + NIL + if _*EOF_* then $Prompt := true + NIL + +parseAndEvalToHypertex str == + lines := parseAndEvalToStringForHypertex str + len := LENGTH lines + sockSendInt($MenuServer, len) + for s in lines repeat + sockSendString($MenuServer, s) + +parseAndEvalToString str == + $collectOutput:local := true + $outputLines: local := nil + $IOindex: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringForHypertex str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndEvalToStringEqNum str == + $collectOutput:local := true + $outputLines: local := nil + v := CATCH('SPAD__READER, CATCH('top__level, parseAndEvalStr str)) + v = 'restart => ['"error"] + NREVERSE $outputLines + +parseAndInterpToString str == + v := applyWithOutputToString('parseAndEvalStr, [str]) + breakIntoLines CDR v + +parseAndEvalStr string == + $InteractiveMode :fluid := true + $BOOT: fluid := NIL + $SPAD: fluid := true + $e:fluid := $InteractiveFrame + parseAndEvalStr1 string + +parseAndEvalStr1 string == + string.0 = char '")" => + doSystemCommand SUBSEQ(string, 1) + processInteractive(ncParseFromString string, NIL) + +protectedEVAL x == + error := true + val := NIL + UNWIND_-PROTECT((val := EVAL x; error := NIL), + error => (resetStackLimits(); sendHTErrorSignal())) + val +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/setq.lisp b/src/interp/setq.lisp deleted file mode 100644 index 6d80b7c4..00000000 --- a/src/interp/setq.lisp +++ /dev/null @@ -1,468 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(setq copyrights '( - "Copyright The Numerical Algorithms Group Limited 1991-94." - "All rights reserved" - "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." - "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." - "All rights reserved")) - -(in-package "BOOT") - -(SETQ |/MAJOR-VERSION| 7) -(SETQ /VERSION 0) -(SETQ /RELEASE 0) - -(defconstant |$cclSystem| -#+:CCL 't -#-:CCL nil -) - -;; These two variables are referred to in setvars.boot. -#+:kcl (setq input-libraries nil) -#+:kcl (setq output-library nil) - -;; For the browser, used for building local databases when a user compiles -;; their own code. -(SETQ |$newConstructorList| nil) -(SETQ |$newConlist| nil) -(SETQ |$createLocalLibDb| 't) - - -;; These were originally in SPAD LISP - -(SETQ $BOOT NIL) -(setq |$interpOnly| nil) -(SETQ |$testingSystem| NIL) -(SETQ |$publicSystem| NIL) -(SETQ |$newcompMode| NIL) -(SETQ |$newComp| NIL) -(SETQ |$newCompCompare| NIL) -(SETQ |$permitWhere| NIL) -(SETQ |$newSystem| T) -(SETQ |$compileDontDefineFunctions| 'T) -(SETQ |$compileOnlyCertainItems| NIL) -(SETQ |$devaluateList| NIL) -(SETQ |$doNotCompressHashTableIfTrue| NIL) -(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT -(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT -(SETQ |$functionLocations| NIL) -(SETQ |$functorLocalParameters| NIL) ; used in compSymbol -(SETQ /RELEASE '"UNKNOWN") -(SETQ |$insideCategoryPackageIfTrue| NIL) -(SETQ |$insideCompileBodyIfTrue| NIL) -(SETQ |$globalExposureGroupAlist| NIL) -(SETQ |$localExposureDataDefault| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$localExposureData| - (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) -(SETQ |$compilingInputFile| NIL) -(SETQ |$minivectorNames| NIL) -(setq |$ReadingFile| NIL) -(setq |$NonNullStream| "NonNullStream") -(setq |$NullStream| "NullStream") -(setq |$domPvar| nil) -(defvar $dalymode nil "if true then leading paren implies lisp cmd") -(setq |$Newline| #\Newline) - - -(SETQ STAKCOLUMN -1) -(SETQ ECHOMETA NIL) -(SETQ |$checkParseIfTrue| 'NIL) -(SETQ |$oldParserExpandAbbrs| NIL) -(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" -(SETQ |/EDIT,FT| 'SPAD) -(SETQ |/EDIT,FM| 'A) -(SETQ /EDITFILE NIL) -(SETQ INITCOLUMN 0) -(SETQ |$functionTable| NIL) -(SETQ |$spaddefs| NIL) -(SETQ |$xeditIsConsole| NIL) -(SETQ |$echoInputLines| NIL) ;; This is in SETVART also -(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT -(SETQ |$pfKeysForBrowse| NIL) -(SETQ MARG 0) - ;" Margin for testing by ?OP" -(SETQ LCTRUE '|true|) -(SETQ |$displayParserOutput| 'T) - -(SETQ |$insideReadRulesIfTrue| NIL) -(SETQ |$consistencyCheck| 'T) -(SETQ |$useUndo| NIL) -(SETQ |$ruleSetsInitialized| NIL) - -;; tell the system not to use the new parser -(SETQ |$useNewParser| NIL) - -(SETQ |$htPrecedenceTable| NIL) - -(SETQ |$NRTmakeCompactDirect| NIL) -(SETQ |$NRTquick| NIL) -(SETQ |$NRTmakeShortDirect| NIL) -(SETQ |$newWorld| NIL) -(SETQ |$returnNowhereFromGoGet| NIL) - -(SETQ |$insideCanCoerceFrom| NIL) - -(SETQ |$useCoerceOrCroak| T) - -(SETQ |$abbreviateJoin| NIL) - -(SETQ |$InterpreterMacroAlist| - '((|%i| . (|complex| 0 1)) - (|%e| . (|exp| 1)) - (|%pi| . (|pi|)) - (|SF| . (|DoubleFloat|)) - (|%infinity| . (|infinity|)) - (|%plusInfinity| . (|plusInfinity|)) - (|%minusInfinity| . (|minusInfinity|)))) - -;; variables controlling companion pages (see copage.boot) -(SETQ |$HTCompanionWindowID| nil) -(SETQ |$HTPreviousDomain| nil) -(SETQ |$HTOperationError| nil) - -;; Common lisp control variables -;;(setq *load-verbose* nil) -(setq *print-array* nil) -(setq *print-pretty* nil) -(setq *print-circle* nil) - -(SETQ |S:SPADTOK| 'SPADSYSTOK) -(SETQ APLMODE NIL) -(SETQ RLGENSYMFG NIL) -(SETQ RLGENSYMLST NIL) -(SETQ XTOKENREADER 'SPADTOK) -(SETQ |$delimiterTokenList| - '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) -(SETQ |$generalTokenIfTrue| NIL) -(SETQ OPASSOC NIL) -(SETQ SPADSYSKEY '(EOI EOL)) - -;; These are for the output routines in OUT BOOT - -(SETQ $LINELENGTH 77) -(SETQ $MARGIN 3) -(SETQ *TALLPAR NIL) -(SETQ ALLSTAR NIL) -(SETQ BLANK " ") -(SETQ COLON ":") -(SETQ COMMA ",") -(SETQ DASH "-") -(SETQ DOLLAR "$") -(SETQ EQSIGN "=") -(SETQ LPAR "(") -(SETQ MATBORCH "*") -(SETQ PERIOD ".") -(SETQ PLUSS "+") -(SETQ RPAR ")") -(SETQ SLASH "/") -(SETQ STAR "*") -(SETQ UNDERBAR "_") -(SETQ |$fortranArrayStartingIndex| 0) - -;; These were originally in INIT LISP - -(SETQ |$dependeeClosureAlist| NIL) -(SETQ |$userModemaps| NIL) -(SETQ |$functorForm| NIL) - -(SETQ |$InitialCommandSynonymAlist| '( - (|?| . "what commands") - (|ap| . "what things") - (|apr| . "what things") - (|apropos| . "what things") - (|cache| . "set functions cache") - (|cl| . "clear") - (|cls| . "zsystemdevelopment )cls") - (|cms| . "system") - (|co| . "compiler") - (|d| . "display") - (|dep| . "display dependents") - (|dependents| . "display dependents") - (|e| . "edit") - (|expose| . "set expose add constructor") - (|fc| . "zsystemdevelopment )c") - (|fd| . "zsystemdevelopment )d") - (|fdt| . "zsystemdevelopment )dt") - (|fct| . "zsystemdevelopment )ct") - (|fctl| . "zsystemdevelopment )ctl") - (|fe| . "zsystemdevelopment )e") - (|fec| . "zsystemdevelopment )ec") - (|fect| . "zsystemdevelopment )ect") - (|fns| . "exec spadfn") - (|fortran| . "set output fortran") - (|h| . "help") - (|hd| . "system hypertex &") - (|kclam| . "boot clearClams ( )") - (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") - (|patch| . "zsystemdevelopment )patch") - (|pause| . "zsystemdevelopment )pause") - (|prompt| . "set message prompt") - (|recurrence| . "set functions recurrence") - (|restore| . "history )restore") - (|save| . "history )save") - (|startGraphics| . "system $AXIOM/lib/viewman &") - (|startNAGLink| . "system $AXIOM/lib/nagman &") - (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") - (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") - (|time| . "set message time") - (|type| . "set message type") - (|unexpose| . "set expose drop constructor") - (|up| . "zsystemdevelopment )update") - (|version| . "lisp *yearweek*") - (|w| . "what") - (|wc| . "what categories") - (|wd| . "what domains") - (|who| . "lisp (pprint credits)") - (|wp| . "what packages") - (|ws| . "what synonyms") -)) - -(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) - -(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) - -(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) -(SETQ |$immediateDataSymbol| '|--immediateData--|) - -(SETQ |$useIntegerSubdomain| 'T) -(SETQ |$useNewFloat| 'T) - -;; the following symbol holds the canonical "failed" value -(SETQ |$failed| "failed") - -(SETQ |$constructorDataTable| NIL) - -(SETQ |$univariateDomains| '( - |UnivariatePolynomial| - |UnivariateTaylorSeries| - |UnivariateLaurentSeries| - |UnivariatePuiseuxSeries| - )) -(SETQ |$multivariateDomains| '( - |MultivariatePolynomial| - |DistributedMultivariatePolynomial| - |HomogeneousDistributedMultivariatePolynomial| - |GeneralDistributedMultivariatePolynomial| - )) - -(SETQ |$DomainsWithoutLisplibs| '( - CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) - -(SETQ |$tracedMapSignatures| ()) -(SETQ |$highlightAllowed| 'T) - ;" used in BRIGHTPRINT and is a )set variable" - -(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp - -(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) -(SETQ |$Any| '(|Any|)) - -(SETQ |$OutputForm| '(|OutputForm|)) - -(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) -(SETQ |$QuotientField| '|Fraction|) -(SETQ |$FunctionalExpression| '|Expression|) -(SETQ |$defaultFunctionTargets| '(())) - -;; New Names -(SETQ |$SingleInteger| '(|SingleInteger|)) - -(SETQ $NE (LIST (LIST NIL))) -(SETQ |$suffix| NIL) -(SETQ |$coerceIntByMapCounter| 0) -(SETQ |$prefix| NIL) -(SETQ |$formalArgList| ()) -(SETQ |$TriangleVariableList| - '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| - |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| - |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| - |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| - |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) - -(SETQ NRTPARSE NIL) -(SETQ |$NRTflag| T) -(SETQ |$NRTaddForm| NIL) -(SETQ |$NRTdeltaList| NIL) -(SETQ |$NRTbase| 0) -(SETQ |$NRTdeltaLength| 0) -(SETQ |$NRTopt| NIL) ;; turns off buggy code -(SETQ |$Slot1DataBase| NIL) -(SETQ |$NRTmonitorIfTrue| NIL) - -(SETQ |$useConvertForCoercions| NIL) - -(MAKEPROP '|One| '|defaultType| |$Integer|) -(MAKEPROP '|Zero| '|defaultType| |$Integer|) - -;; Following were originally in EXPLORE BOOT - -(SETQ |$xdatabase| NIL) -(SETQ |$CatOfCatDatabase| NIL) -(SETQ |$DomOfCatDatabase| NIL) -(SETQ |$JoinOfDomDatabase| NIL) -(SETQ |$JoinOfCatDatabase| NIL) -(SETQ |$attributeDb| NIL) - -(SETQ |$abbreviateIfTrue| NIL) -(SETQ |$deltax| 0) -(SETQ |$deltay| 0) -(SETQ |$displayDomains| 'T) -(SETQ |$displayTowardAncestors| NIL) -(SETQ |$focus| NIL) -(SETQ |$focusAccessPath| NIL) -(SETQ |$minimumSeparation| 3) -(SETQ |$origMaxColumn| 80) -(SETQ |$origMaxRow| 20) -(SETQ |$origMinColumn| 1) -(SETQ |$origMinRow| 1) - -;; ---- start of initial settings for variables used in test.boot - -(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd - ;; to stash lines -(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed - ;; (needed to convert lines for use - ;; in hypertex) -(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash - ;; output by recordAndPrint to not - ;; print type/time -(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input - ;; by maPrin to stash output - ;; by recordAndPrint to write i/o - ;; onto $testStream -(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream - ;; (see READLN) -(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream - ;; (see maPrin) - -;; ---- end of initial settings for variables used in test.boot - - -;; Next are initial values for fluid variables in G-BOOT BOOT - -(SETQ |$inDefLET| NIL) -(SETQ |$inDefIS| NIL) -(SETQ |$letGenVarCounter| 1) -(SETQ |$isGenVarCounter| 1) - -;; Next 2 lines originally from CLAM BOOT - -;; this node is used in looking up values -(SETQ |$hashNode| (LIST NIL)) - -(SETQ ERRORINSTREAM (DEFIOSTREAM - '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) - -(SETQ ERROROUTSTREAM - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) - -(SETQ |$algebraOutputStream| - (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) - -;; By default, don't generate info files with old compiler. -(setq |$profileCompiler| nil) - -(setq credits '( -"An alphabetical listing of contributors to AXIOM (to October, 2006):" -"Cyril Alberga Roy Adler Christian Aistleitner" -"Richard Anderson George Andrews" -"Henry Baker Stephen Balzac Yurij Baransky" -"David R. Barton Gerald Baumgartner Gilbert Baumslag" -"Fred Blair Vladimir Bondarenko Mark Botch" -"Alexandre Bouyer Peter A. Broadbery Martin Brock" -"Manuel Bronstein Florian Bundschuh Luanne Burns" -"William Burge" -"Quentin Carpent Robert Caviness Bruce Char" -"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" -"Josh Cohen Christophe Conil Don Coppersmith" -"George Corliss Robert Corless Gary Cornell" -"Meino Cramer Claire Di Crescenzo" -"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" -"Jean Della Dora Gabriel Dos Reis Michael Dewar" -"Claire DiCrescendo Sam Dooley Lionel Ducos" -"Martin Dunstan Brian Dupee Dominique Duval" -"Robert Edwards Heow Eide-Goodman Lars Erickson" -"Richard Fateman Bertfried Fauser Stuart Feldman" -"Brian Ford Albrecht Fortenbacher George Frances" -"Constantine Frangos Timothy Freeman Korrinn Fu" -"Marc Gaetano Rudiger Gebauer Kathy Gerber" -"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" -"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" -"Matt Grayson James Griesmer Vladimir Grinberg" -"Oswald Gschnitzer Jocelyn Guidry" -"Steve Hague Vilya Harvey Satoshi Hamaguchi" -"Martin Hassner Waldek Hebisch Ralf Hemmecke" -"Henderson Antoine Hersen" -"Pietro Iglio" -"Richard Jenks" -"Kai Kaminski Grant Keady Tony Kennedy" -"Paul Kosinski Klaus Kusche Bernhard Kutzler" -"Larry Lambe Frederic Lehobey Michel Levaud" -"Howard Levy Rudiger Loos Michael Lucks" -"Richard Luczak" -"Camm Maguire Bob McElrath Michael McGettrick" -"Ian Meikle David Mentre Victor S. Miller" -"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" -"Michael Monagan Marc Moreno-Maza Scott Morrison" -"Mark Murray" -"William Naylor C. Andrew Neff John Nelder" -"Godfrey Nolan Arthur Norman Jinzhong Niu" -"Michael O'Connor Kostas Oikonomou" -"Julian A. Padget Bill Page Susan Pelzel" -"Michel Petitot Didier Pinchon Jose Alfredo Portes" -"Claude Quitte" -"Norman Ramsey Michael Richardson Renaud Rioboo" -"Jean Rivlin Nicolas Robidoux Simon Robinson" -"Michael Rothstein Martin Rubey" -"Philip Santas Alfred Scheerhorn William Schelter" -"Gerhard Schneider Martin Schoenert Marshall Schor" -"Frithjof Schulze Fritz Schwarz Nick Simicich" -"William Sit Elena Smirnova Jonathan Steinbach" -"Christine Sundaresan Robert Sutor Moss E. Sweedler" -"Eugene Surowitz" -"James Thatcher Balbir Thomas Mike Thomas" -"Dylan Thurston Barry Trager Themos T. Tsikas" -"Gregory Vanuxem" -"Bernhard Wall Stephen Watt Jaap Weel" -"Juergen Weiss M. Weller Mark Wegman" -"James Wen Thorsten Werther Michael Wester" -"John M. Wiley Berhard Will Clifton J. Williamson" -"Stephen Wilson Shmuel Winograd Robert Wisbauer" -"Sandra Wityak Waldemar Wiwianka Knut Wolf" -"Clifford Yapp David Yun" -"Richard Zippel Evelyn Zoernack Bruno Zuercher" -"Dan Zwillinger" -)) - diff --git a/src/interp/setq.lisp.pamphlet b/src/interp/setq.lisp.pamphlet new file mode 100644 index 00000000..ae3011b7 --- /dev/null +++ b/src/interp/setq.lisp.pamphlet @@ -0,0 +1,496 @@ +%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/setq.lisp} Pamphlet} +\author{Timothy Daly} + +\begin{document} + +\maketitle +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(setq copyrights '( + "Copyright The Numerical Algorithms Group Limited 1991-94." + "All rights reserved" + "Certain derivative-work portions Copyright (C) 1998 by Leslie Lamport." + "Portions (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984." + "All rights reserved")) + +(in-package "BOOT") + +(SETQ |/MAJOR-VERSION| 7) +(SETQ /VERSION 0) +(SETQ /RELEASE 0) + +(defconstant |$cclSystem| +#+:CCL 't +#-:CCL nil +) + +;; These two variables are referred to in setvars.boot. +#+:kcl (setq input-libraries nil) +#+:kcl (setq output-library nil) + +;; For the browser, used for building local databases when a user compiles +;; their own code. +(SETQ |$newConstructorList| nil) +(SETQ |$newConlist| nil) +(SETQ |$createLocalLibDb| 't) + + +;; These were originally in SPAD LISP + +(SETQ $BOOT NIL) +(setq |$interpOnly| nil) +(SETQ |$testingSystem| NIL) +(SETQ |$publicSystem| NIL) +(SETQ |$newcompMode| NIL) +(SETQ |$newComp| NIL) +(SETQ |$newCompCompare| NIL) +(SETQ |$permitWhere| NIL) +(SETQ |$newSystem| T) +(SETQ |$compileDontDefineFunctions| 'T) +(SETQ |$compileOnlyCertainItems| NIL) +(SETQ |$devaluateList| NIL) +(SETQ |$doNotCompressHashTableIfTrue| NIL) +(SETQ |$mutableChecking| NIL) ; used in DEFINE BOOT +(SETQ |$mutableDomains| NIL) ; checked in DEFINE BOOT +(SETQ |$functionLocations| NIL) +(SETQ |$functorLocalParameters| NIL) ; used in compSymbol +(SETQ /RELEASE '"UNKNOWN") +(SETQ |$insideCategoryPackageIfTrue| NIL) +(SETQ |$insideCompileBodyIfTrue| NIL) +(SETQ |$globalExposureGroupAlist| NIL) +(SETQ |$localExposureDataDefault| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$localExposureData| + (VECTOR (LIST '|basic| '|categories| '|naglink| '|anna| ) NIL NIL)) +(SETQ |$compilingInputFile| NIL) +(SETQ |$minivectorNames| NIL) +(setq |$ReadingFile| NIL) +(setq |$NonNullStream| "NonNullStream") +(setq |$NullStream| "NullStream") +(setq |$domPvar| nil) +(defvar $dalymode nil "if true then leading paren implies lisp cmd") +(setq |$Newline| #\Newline) + + +(SETQ STAKCOLUMN -1) +(SETQ ECHOMETA NIL) +(SETQ |$checkParseIfTrue| 'NIL) +(SETQ |$oldParserExpandAbbrs| NIL) +(SETQ |S:SPADKEY| NIL) ;" this is augmented by MAKESPADOP" +(SETQ |/EDIT,FT| 'SPAD) +(SETQ |/EDIT,FM| 'A) +(SETQ /EDITFILE NIL) +(SETQ INITCOLUMN 0) +(SETQ |$functionTable| NIL) +(SETQ |$spaddefs| NIL) +(SETQ |$xeditIsConsole| NIL) +(SETQ |$echoInputLines| NIL) ;; This is in SETVART also +(SETQ |$Slot1DataBase| (MAKE-HASHTABLE 'ID)) ;; See NRUNTIME BOOT +(SETQ |$pfKeysForBrowse| NIL) +(SETQ MARG 0) + ;" Margin for testing by ?OP" +(SETQ LCTRUE '|true|) +(SETQ |$displayParserOutput| 'T) + +(SETQ |$insideReadRulesIfTrue| NIL) +(SETQ |$consistencyCheck| 'T) +(SETQ |$useUndo| NIL) +(SETQ |$ruleSetsInitialized| NIL) + +;; tell the system not to use the new parser +(SETQ |$useNewParser| NIL) + +(SETQ |$htPrecedenceTable| NIL) + +(SETQ |$NRTmakeCompactDirect| NIL) +(SETQ |$NRTquick| NIL) +(SETQ |$NRTmakeShortDirect| NIL) +(SETQ |$newWorld| NIL) +(SETQ |$returnNowhereFromGoGet| NIL) + +(SETQ |$insideCanCoerceFrom| NIL) + +(SETQ |$useCoerceOrCroak| T) + +(SETQ |$abbreviateJoin| NIL) + +(SETQ |$InterpreterMacroAlist| + '((|%i| . (|complex| 0 1)) + (|%e| . (|exp| 1)) + (|%pi| . (|pi|)) + (|SF| . (|DoubleFloat|)) + (|%infinity| . (|infinity|)) + (|%plusInfinity| . (|plusInfinity|)) + (|%minusInfinity| . (|minusInfinity|)))) + +;; variables controlling companion pages (see copage.boot) +(SETQ |$HTCompanionWindowID| nil) +(SETQ |$HTPreviousDomain| nil) +(SETQ |$HTOperationError| nil) + +;; Common lisp control variables +;;(setq *load-verbose* nil) +(setq *print-array* nil) +(setq *print-pretty* nil) +(setq *print-circle* nil) + +(SETQ |S:SPADTOK| 'SPADSYSTOK) +(SETQ APLMODE NIL) +(SETQ RLGENSYMFG NIL) +(SETQ RLGENSYMLST NIL) +(SETQ XTOKENREADER 'SPADTOK) +(SETQ |$delimiterTokenList| + '(| | |)| |(| |{| |}| |[| |]| ENDOFLINECHR EOI EOL |END_LINE|)) +(SETQ |$generalTokenIfTrue| NIL) +(SETQ OPASSOC NIL) +(SETQ SPADSYSKEY '(EOI EOL)) + +;; These are for the output routines in OUT BOOT + +(SETQ $LINELENGTH 77) +(SETQ $MARGIN 3) +(SETQ *TALLPAR NIL) +(SETQ ALLSTAR NIL) +(SETQ BLANK " ") +(SETQ COLON ":") +(SETQ COMMA ",") +(SETQ DASH "-") +(SETQ DOLLAR "$") +(SETQ EQSIGN "=") +(SETQ LPAR "(") +(SETQ MATBORCH "*") +(SETQ PERIOD ".") +(SETQ PLUSS "+") +(SETQ RPAR ")") +(SETQ SLASH "/") +(SETQ STAR "*") +(SETQ UNDERBAR "_") +(SETQ |$fortranArrayStartingIndex| 0) + +;; These were originally in INIT LISP + +(SETQ |$dependeeClosureAlist| NIL) +(SETQ |$userModemaps| NIL) +(SETQ |$functorForm| NIL) + +(SETQ |$InitialCommandSynonymAlist| '( + (|?| . "what commands") + (|ap| . "what things") + (|apr| . "what things") + (|apropos| . "what things") + (|cache| . "set functions cache") + (|cl| . "clear") + (|cls| . "zsystemdevelopment )cls") + (|cms| . "system") + (|co| . "compiler") + (|d| . "display") + (|dep| . "display dependents") + (|dependents| . "display dependents") + (|e| . "edit") + (|expose| . "set expose add constructor") + (|fc| . "zsystemdevelopment )c") + (|fd| . "zsystemdevelopment )d") + (|fdt| . "zsystemdevelopment )dt") + (|fct| . "zsystemdevelopment )ct") + (|fctl| . "zsystemdevelopment )ctl") + (|fe| . "zsystemdevelopment )e") + (|fec| . "zsystemdevelopment )ec") + (|fect| . "zsystemdevelopment )ect") + (|fns| . "exec spadfn") + (|fortran| . "set output fortran") + (|h| . "help") + (|hd| . "system hypertex &") + (|kclam| . "boot clearClams ( )") + (|killcaches| . "boot clearConstructorAndLisplibCaches ( )") + (|patch| . "zsystemdevelopment )patch") + (|pause| . "zsystemdevelopment )pause") + (|prompt| . "set message prompt") + (|recurrence| . "set functions recurrence") + (|restore| . "history )restore") + (|save| . "history )save") + (|startGraphics| . "system $AXIOM/lib/viewman &") + (|startNAGLink| . "system $AXIOM/lib/nagman &") + (|stopGraphics| . "lisp (|sockSendSignal| 2 15)") + (|stopNAGLink| . "lisp (|sockSendSignal| 8 15)") + (|time| . "set message time") + (|type| . "set message type") + (|unexpose| . "set expose drop constructor") + (|up| . "zsystemdevelopment )update") + (|version| . "lisp *yearweek*") + (|w| . "what") + (|wc| . "what categories") + (|wd| . "what domains") + (|who| . "lisp (pprint credits)") + (|wp| . "what packages") + (|ws| . "what synonyms") +)) + +(SETQ |$CommandSynonymAlist| (COPY |$InitialCommandSynonymAlist|)) + +(SETQ |$existingFiles| (MAKE-HASHTABLE 'UEQUAL)) + +(SETQ |$instantRecord| (MAKE-HASHTABLE 'ID)) +(SETQ |$immediateDataSymbol| '|--immediateData--|) + +(SETQ |$useIntegerSubdomain| 'T) +(SETQ |$useNewFloat| 'T) + +;; the following symbol holds the canonical "failed" value +(SETQ |$failed| "failed") + +(SETQ |$constructorDataTable| NIL) + +(SETQ |$univariateDomains| '( + |UnivariatePolynomial| + |UnivariateTaylorSeries| + |UnivariateLaurentSeries| + |UnivariatePuiseuxSeries| + )) +(SETQ |$multivariateDomains| '( + |MultivariatePolynomial| + |DistributedMultivariatePolynomial| + |HomogeneousDistributedMultivariatePolynomial| + |GeneralDistributedMultivariatePolynomial| + )) + +(SETQ |$DomainsWithoutLisplibs| '( + CAPSULE |Union| |Record| |SubDomain| |Mapping| |Enumeration| |Domain| |Mode|)) + +(SETQ |$tracedMapSignatures| ()) +(SETQ |$highlightAllowed| 'T) + ;" used in BRIGHTPRINT and is a )set variable" + +(SETQ |$printStorageIfTrue| NIL) ;; storage info disabled in common lisp + +(SETQ |$AnonymousFunction| '(|AnonymousFunction|)) +(SETQ |$Any| '(|Any|)) + +(SETQ |$OutputForm| '(|OutputForm|)) + +(SETQ |$ComplexInteger| (LIST '|Complex| |$Integer|)) +(SETQ |$QuotientField| '|Fraction|) +(SETQ |$FunctionalExpression| '|Expression|) +(SETQ |$defaultFunctionTargets| '(())) + +;; New Names +(SETQ |$SingleInteger| '(|SingleInteger|)) + +(SETQ $NE (LIST (LIST NIL))) +(SETQ |$suffix| NIL) +(SETQ |$coerceIntByMapCounter| 0) +(SETQ |$prefix| NIL) +(SETQ |$formalArgList| ()) +(SETQ |$TriangleVariableList| + '(|t#1| |t#2| |t#3| |t#4| |t#5| |t#6| |t#7| |t#8| |t#9| |t#10| + |t#11| |t#12| |t#13| |t#14| |t#15| |t#16| |t#17| |t#18| |t#19| |t#20| + |t#21| |t#22| |t#23| |t#24| |t#25| |t#26| |t#27| |t#28| |t#29| |t#30| + |t#31| |t#32| |t#33| |t#34| |t#35| |t#36| |t#37| |t#38| |t#39| |t#40| + |t#41| |t#42| |t#43| |t#44| |t#45| |t#46| |t#47| |t#48| |t#49| |t#50|)) + +(SETQ NRTPARSE NIL) +(SETQ |$NRTflag| T) +(SETQ |$NRTaddForm| NIL) +(SETQ |$NRTdeltaList| NIL) +(SETQ |$NRTbase| 0) +(SETQ |$NRTdeltaLength| 0) +(SETQ |$NRTopt| NIL) ;; turns off buggy code +(SETQ |$Slot1DataBase| NIL) +(SETQ |$NRTmonitorIfTrue| NIL) + +(SETQ |$useConvertForCoercions| NIL) + +(MAKEPROP '|One| '|defaultType| |$Integer|) +(MAKEPROP '|Zero| '|defaultType| |$Integer|) + +;; Following were originally in EXPLORE BOOT + +(SETQ |$xdatabase| NIL) +(SETQ |$CatOfCatDatabase| NIL) +(SETQ |$DomOfCatDatabase| NIL) +(SETQ |$JoinOfDomDatabase| NIL) +(SETQ |$JoinOfCatDatabase| NIL) +(SETQ |$attributeDb| NIL) + +(SETQ |$abbreviateIfTrue| NIL) +(SETQ |$deltax| 0) +(SETQ |$deltay| 0) +(SETQ |$displayDomains| 'T) +(SETQ |$displayTowardAncestors| NIL) +(SETQ |$focus| NIL) +(SETQ |$focusAccessPath| NIL) +(SETQ |$minimumSeparation| 3) +(SETQ |$origMaxColumn| 80) +(SETQ |$origMaxRow| 20) +(SETQ |$origMinColumn| 1) +(SETQ |$origMinRow| 1) + +;; ---- start of initial settings for variables used in test.boot + +(SETQ |$testOutputLineFlag| NIL) ;; referenced by charyTop, prnd + ;; to stash lines +(SETQ |$testOutputLineStack| NIL) ;; saves lines to be printed + ;; (needed to convert lines for use + ;; in hypertex) +(SETQ |$runTestFlag| NIL) ;; referenced by maPrin to stash + ;; output by recordAndPrint to not + ;; print type/time +(SETQ |$mkTestFlag| NIL) ;; referenced by READLN to stash input + ;; by maPrin to stash output + ;; by recordAndPrint to write i/o + ;; onto $testStream +(SETQ |$mkTestInputStack| NIL) ;; saves input for $testStream + ;; (see READLN) +(SETQ |$mkTestOutputStack| NIL) ;; saves output for $testStream + ;; (see maPrin) + +;; ---- end of initial settings for variables used in test.boot + + +;; Next are initial values for fluid variables in G-BOOT BOOT + +(SETQ |$inDefLET| NIL) +(SETQ |$inDefIS| NIL) +(SETQ |$letGenVarCounter| 1) +(SETQ |$isGenVarCounter| 1) + +;; Next 2 lines originally from CLAM BOOT + +;; this node is used in looking up values +(SETQ |$hashNode| (LIST NIL)) + +(SETQ ERRORINSTREAM (DEFIOSTREAM + '((DEVICE . CONSOLE) (MODE . INPUT) (QUAL . T)) 133 1)) + +(SETQ ERROROUTSTREAM + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 80 0) ) + +(SETQ |$algebraOutputStream| + (DEFIOSTREAM '((DEVICE . CONSOLE)(MODE . OUTPUT)) 255 0) ) + +;; By default, don't generate info files with old compiler. +(setq |$profileCompiler| nil) + +(setq credits '( +"An alphabetical listing of contributors to AXIOM (to October, 2006):" +"Cyril Alberga Roy Adler Christian Aistleitner" +"Richard Anderson George Andrews" +"Henry Baker Stephen Balzac Yurij Baransky" +"David R. Barton Gerald Baumgartner Gilbert Baumslag" +"Fred Blair Vladimir Bondarenko Mark Botch" +"Alexandre Bouyer Peter A. Broadbery Martin Brock" +"Manuel Bronstein Florian Bundschuh Luanne Burns" +"William Burge" +"Quentin Carpent Robert Caviness Bruce Char" +"Cheekai Chin David V. Chudnovsky Gregory V. Chudnovsky" +"Josh Cohen Christophe Conil Don Coppersmith" +"George Corliss Robert Corless Gary Cornell" +"Meino Cramer Claire Di Crescenzo" +"Timothy Daly Sr. Timothy Daly Jr. James H. Davenport" +"Jean Della Dora Gabriel Dos Reis Michael Dewar" +"Claire DiCrescendo Sam Dooley Lionel Ducos" +"Martin Dunstan Brian Dupee Dominique Duval" +"Robert Edwards Heow Eide-Goodman Lars Erickson" +"Richard Fateman Bertfried Fauser Stuart Feldman" +"Brian Ford Albrecht Fortenbacher George Frances" +"Constantine Frangos Timothy Freeman Korrinn Fu" +"Marc Gaetano Rudiger Gebauer Kathy Gerber" +"Patricia Gianni Holger Gollan Teresa Gomez-Diaz" +"Laureano Gonzalez-Vega Stephen Gortler Johannes Grabmeier" +"Matt Grayson James Griesmer Vladimir Grinberg" +"Oswald Gschnitzer Jocelyn Guidry" +"Steve Hague Vilya Harvey Satoshi Hamaguchi" +"Martin Hassner Waldek Hebisch Ralf Hemmecke" +"Henderson Antoine Hersen" +"Pietro Iglio" +"Richard Jenks" +"Kai Kaminski Grant Keady Tony Kennedy" +"Paul Kosinski Klaus Kusche Bernhard Kutzler" +"Larry Lambe Frederic Lehobey Michel Levaud" +"Howard Levy Rudiger Loos Michael Lucks" +"Richard Luczak" +"Camm Maguire Bob McElrath Michael McGettrick" +"Ian Meikle David Mentre Victor S. Miller" +"Gerard Milmeister Mohammed Mobarak H. Michael Moeller" +"Michael Monagan Marc Moreno-Maza Scott Morrison" +"Mark Murray" +"William Naylor C. Andrew Neff John Nelder" +"Godfrey Nolan Arthur Norman Jinzhong Niu" +"Michael O'Connor Kostas Oikonomou" +"Julian A. Padget Bill Page Susan Pelzel" +"Michel Petitot Didier Pinchon Jose Alfredo Portes" +"Claude Quitte" +"Norman Ramsey Michael Richardson Renaud Rioboo" +"Jean Rivlin Nicolas Robidoux Simon Robinson" +"Michael Rothstein Martin Rubey" +"Philip Santas Alfred Scheerhorn William Schelter" +"Gerhard Schneider Martin Schoenert Marshall Schor" +"Frithjof Schulze Fritz Schwarz Nick Simicich" +"William Sit Elena Smirnova Jonathan Steinbach" +"Christine Sundaresan Robert Sutor Moss E. Sweedler" +"Eugene Surowitz" +"James Thatcher Balbir Thomas Mike Thomas" +"Dylan Thurston Barry Trager Themos T. Tsikas" +"Gregory Vanuxem" +"Bernhard Wall Stephen Watt Jaap Weel" +"Juergen Weiss M. Weller Mark Wegman" +"James Wen Thorsten Werther Michael Wester" +"John M. Wiley Berhard Will Clifton J. Williamson" +"Stephen Wilson Shmuel Winograd Robert Wisbauer" +"Sandra Wityak Waldemar Wiwianka Knut Wolf" +"Clifford Yapp David Yun" +"Richard Zippel Evelyn Zoernack Bruno Zuercher" +"Dan Zwillinger" +)) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/sfsfun-l.lisp b/src/interp/sfsfun-l.lisp deleted file mode 100644 index 2a15752a..00000000 --- a/src/interp/sfsfun-l.lisp +++ /dev/null @@ -1,69 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -(in-package "BOOT") - -;; -;; Lisp part of the Scratchpad special function interface. -;; SMW Feb 91 -;; - -;; #-:CCL -;; (defun |float| (x) (|float| x)) - -;; Conversion between spad and lisp complex representations -(defun s-to-c (c) (complex (car c) (cdr c))) -(defun c-to-s (c) (cons (realpart c) (imagpart c))) -(defun c-to-r (c) - (let ((r (realpart c)) (i (imagpart c))) - (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) - r - (|error| "Result is not real.")) )) - -;; Wrappers for functions in the special function package -(defun rlngamma (x) (|lnrgamma| x) ) -(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) - -;; #-:CCL -(defun rgamma (x) (|rgamma| x)) -(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) - -(defun rpsi (n x) (|rPsi| n x) ) -(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) - -(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) -(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) - -(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) -(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) - -(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) diff --git a/src/interp/sfsfun-l.lisp.pamphlet b/src/interp/sfsfun-l.lisp.pamphlet new file mode 100644 index 00000000..c7c992e0 --- /dev/null +++ b/src/interp/sfsfun-l.lisp.pamphlet @@ -0,0 +1,91 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp sfsfun-l.lisp} +\author{Timothy Daly} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +(in-package "BOOT") + +;; +;; Lisp part of the Scratchpad special function interface. +;; SMW Feb 91 +;; + +;; #-:CCL +;; (defun |float| (x) (|float| x)) + +;; Conversion between spad and lisp complex representations +(defun s-to-c (c) (complex (car c) (cdr c))) +(defun c-to-s (c) (cons (realpart c) (imagpart c))) +(defun c-to-r (c) + (let ((r (realpart c)) (i (imagpart c))) + (if (or (zerop i) (< (abs i) (* 1.0E-10 (abs r)))) + r + (|error| "Result is not real.")) )) + +;; Wrappers for functions in the special function package +(defun rlngamma (x) (|lnrgamma| x) ) +(defun clngamma (z) (c-to-s (|lncgamma| (s-to-c z)) )) + +;; #-:CCL +(defun rgamma (x) (|rgamma| x)) +(defun cgamma (z) (c-to-s (|cgamma| (s-to-c z)) )) + +(defun rpsi (n x) (|rPsi| n x) ) +(defun cpsi (n z) (c-to-s (|cPsi| n (s-to-c z)) )) + +(defun rbesselj (n x) (c-to-r (|BesselJ| n x)) )) +(defun cbesselj (v z) (c-to-s (|BesselJ| (s-to-c v) (s-to-c z)) )) + +(defun rbesseli (n x) (c-to-r (|BesselI| n x)) )) +(defun cbesseli (v z) (c-to-s (|BesselI| (s-to-c v) (s-to-c z)) )) + +(defun chyper0f1 (a z) (c-to-s (|chebf01| (s-to-c a) (s-to-c z)) )) +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot deleted file mode 100644 index 94daf168..00000000 --- a/src/interp/showimp.boot +++ /dev/null @@ -1,252 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -$returnNowhereFromGoGet := false - -showSummary dom == - showPredicates dom - showAttributes dom - showFrom dom - showImp dom - ---======================================================================= --- Show Where Functions in Domain are Implemented ---======================================================================= -showImp(dom,:options) == - sayBrightly '"-------------Operation summary-----------------" - missingOnlyFlag := KAR options - domainForm := devaluate dom - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true) - --sort into 4 groups: domain exports, unexports, default exports, others - for (x := [.,.,:key]) in u repeat - key = domainForm => domexports := [x,:domexports] - FIXP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant => constants := [x,:constants] - others := [x,:others] --add chain domains go here - sayBrightly - nowheres => ['"Functions exported but not implemented by", - :bright form2String domainForm,'":"] - [:bright form2String domainForm,'"implements all exported operations"] - showDomainsOp1(nowheres,'nowhere) - missingOnlyFlag => 'done - - --first display those exported by the domain, then add chain guys - u := [:domexports,:constants,:SORTBY('CDDR,others)] - while u repeat - [.,.,:key] := CAR u - sayBrightly - key = 'constant => - ["Constants implemented by",:bright form2String key,'":"] - ["Functions implemented by",:bright form2String key,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,defexports) - while u repeat - [.,.,:key] := CAR u - defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) - domainForm := [defop,:CDDR key] - sayBrightly ["Default functions from",:bright form2String domainForm,'":"] - u := showDomainsOp1(u,key) - u := SORTBY('CDDR,unexports) - while u repeat - [.,.,:key] := CAR u - sayBrightly ["Not exported: "] - u := showDomainsOp1(u,key) - ---======================================================================= --- Show Information Directly From Domains ---======================================================================= -showFrom(D,:option) == - ops := KAR option - alist := nil - domainForm := devaluate D - [nam,:.] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat - u := from?(D,op,sig) - x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) - alist := [[u,opSig],:alist] - for [conform,:l] in alist repeat - sayBrightly concat('"From ",form2String conform,'":") - for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] - ---======================================================================= --- Functions implementing showFrom ---======================================================================= -getDomainOps D == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) - -getDomainSigs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - getDomainSigs1(D,first option) - -getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where - u() == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] - -getDomainDocs(D,:option) == - domname := D.0 - conname := CAR domname - $predicateList: local := GETDATABASE(conname,'PREDICATES) - ops := KAR option - [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] - ---======================================================================= --- Getting Inheritance Info from Documentation in Lisplib ---======================================================================= -from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) - -getExtensionsOfDomain domain == - u := getDomainExtensionsOfDomain domain - cats := getCategoriesOfDomain domain - for x in u repeat - cats := union(cats,getCategoriesOfDomain EVAL x) - [:u,:cats] - -getDomainExtensionsOfDomain domain == - acc := nil - d := domain - while (u := devaluateSlotDomain(5,d)) repeat - acc := [u,:acc] - d := EVAL u - acc - -devaluateSlotDomain(u,dollar) == - u = '$ => devaluate dollar - FIXP u and VECP (y := dollar.u) => devaluate y - u is ['NRTEVAL,y] => MKQ eval y - u is ['QUOTE,y] => u - u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] - devaluate evalSlotDomain(u,dollar) - -getCategoriesOfDomain domain == - predkeyVec := domain.4.0 - catforms := CADR domain.4 - [fn for i in 0..MAXINDEX predkeyVec | test] where - test() == predkeyVec.i and - (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] - fn == - VECP x => devaluate x - devaluateSlotDomain(x,domain) - -getInheritanceByDoc(D,op,sig,:options) == ---gets inheritance and documentation information by looking in the LISPLIB ---for each ancestor of the domain - catList := KAR options or getExtensionsOfDomain D - getDocDomainForOpSig(op,sig,devaluate D,D) or - or/[fn for x in catList] or '(NIL NIL) - where fn() == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) - -getDocDomainForOpSig(op,sig,dollar,D) == - (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) - and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) - ---======================================================================= --- Functions implementing showImp ---======================================================================= -showDomainsOp1(u,key) == - while u and CAR u is [op,sig,: =key] repeat - sayBrightly ['" ",:formatOpSignature(op,sig)] - u := rest u - u - -getDomainRefName(dom,nam) == - PAIRP nam => [getDomainRefName(dom,x) for x in nam] - not FIXP nam => nam - slot := dom.nam - VECP slot => slot.0 - slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) - slot - -getDomainSeteltForm ['SETELT,.,.,form] == - form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) - VECP form => systemError() - form - -showPredicates dom == - sayBrightly '"--------------------Predicate summary-------------------" - conname := CAR dom.0 - predvector := dom.3 - predicateList := GETDATABASE(conname,'PREDICATES) - for i in 1.. for p in predicateList repeat - prefix := - testBitVector(predvector,i) => '"true : " - '"false: " - sayBrightly [prefix,:pred2English p] - -showAttributes dom == - sayBrightly '"--------------------Attribute summary-------------------" - conname := CAR dom.0 - abb := getConstructorAbbreviation conname - predvector := dom.3 - for [a,:p] in dom.2 repeat - prefix := - testBitVector(predvector,p) => '"true : " - '"false: " - sayBrightly concat(prefix,form2String a) - -showGoGet dom == - numvec := CDDR dom.4 - for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := - [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] - index := index + numOfArgs + 1 - namePart := - concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) - sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] - -formatLazyDomain(dom,x) == - VECP x => devaluate x - x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) - systemError nil - -formatLazyDomainForm(dom,x) == - x = 0 => ["$"] - FIXP x => formatLazyDomain(dom,dom.x) - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] - - - diff --git a/src/interp/showimp.boot.pamphlet b/src/interp/showimp.boot.pamphlet new file mode 100644 index 00000000..49b72338 --- /dev/null +++ b/src/interp/showimp.boot.pamphlet @@ -0,0 +1,278 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/showimp.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +$returnNowhereFromGoGet := false + +showSummary dom == + showPredicates dom + showAttributes dom + showFrom dom + showImp dom + +--======================================================================= +-- Show Where Functions in Domain are Implemented +--======================================================================= +showImp(dom,:options) == + sayBrightly '"-------------Operation summary-----------------" + missingOnlyFlag := KAR options + domainForm := devaluate dom + [nam,:$domainArgs] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + predVector := dom.3 + u := getDomainOpTable(dom,true) + --sort into 4 groups: domain exports, unexports, default exports, others + for (x := [.,.,:key]) in u repeat + key = domainForm => domexports := [x,:domexports] + FIXP key => unexports := [x,:unexports] + isDefaultPackageForm? key => defexports := [x,:defexports] + key = 'nowhere => nowheres := [x,:nowheres] + key = 'constant => constants := [x,:constants] + others := [x,:others] --add chain domains go here + sayBrightly + nowheres => ['"Functions exported but not implemented by", + :bright form2String domainForm,'":"] + [:bright form2String domainForm,'"implements all exported operations"] + showDomainsOp1(nowheres,'nowhere) + missingOnlyFlag => 'done + + --first display those exported by the domain, then add chain guys + u := [:domexports,:constants,:SORTBY('CDDR,others)] + while u repeat + [.,.,:key] := CAR u + sayBrightly + key = 'constant => + ["Constants implemented by",:bright form2String key,'":"] + ["Functions implemented by",:bright form2String key,'":"] + u := showDomainsOp1(u,key) + u := SORTBY('CDDR,defexports) + while u repeat + [.,.,:key] := CAR u + defop := INTERN(SUBSTRING((s := PNAME CAR key),0,MAXINDEX s)) + domainForm := [defop,:CDDR key] + sayBrightly ["Default functions from",:bright form2String domainForm,'":"] + u := showDomainsOp1(u,key) + u := SORTBY('CDDR,unexports) + while u repeat + [.,.,:key] := CAR u + sayBrightly ["Not exported: "] + u := showDomainsOp1(u,key) + +--======================================================================= +-- Show Information Directly From Domains +--======================================================================= +showFrom(D,:option) == + ops := KAR option + alist := nil + domainForm := devaluate D + [nam,:.] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + for (opSig := [op,sig]) in getDomainSigs1(D,ops) repeat + u := from?(D,op,sig) + x := ASSOC(u,alist) => RPLACD(x,[opSig,:rest x]) + alist := [[u,opSig],:alist] + for [conform,:l] in alist repeat + sayBrightly concat('"From ",form2String conform,'":") + for [op,sig] in l repeat sayBrightly ['" ",:formatOpSignature(op,sig)] + +--======================================================================= +-- Functions implementing showFrom +--======================================================================= +getDomainOps D == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + REMDUP listSort(function GLESSEQP,ASSOCLEFT getDomainOpTable(D,nil)) + +getDomainSigs(D,:option) == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + getDomainSigs1(D,first option) + +getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where + u() == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] + +getDomainDocs(D,:option) == + domname := D.0 + conname := CAR domname + $predicateList: local := GETDATABASE(conname,'PREDICATES) + ops := KAR option + [[op,sig,:getInheritanceByDoc(D,op,sig)] for [op,sig] in getDomainSigs1(D,ops)] + +--======================================================================= +-- Getting Inheritance Info from Documentation in Lisplib +--======================================================================= +from?(D,op,sig) == KAR KDR getInheritanceByDoc(D,op,sig) + +getExtensionsOfDomain domain == + u := getDomainExtensionsOfDomain domain + cats := getCategoriesOfDomain domain + for x in u repeat + cats := union(cats,getCategoriesOfDomain EVAL x) + [:u,:cats] + +getDomainExtensionsOfDomain domain == + acc := nil + d := domain + while (u := devaluateSlotDomain(5,d)) repeat + acc := [u,:acc] + d := EVAL u + acc + +devaluateSlotDomain(u,dollar) == + u = '$ => devaluate dollar + FIXP u and VECP (y := dollar.u) => devaluate y + u is ['NRTEVAL,y] => MKQ eval y + u is ['QUOTE,y] => u + u is [op,:argl] => [op,:[devaluateSlotDomain(x,dollar) for x in argl]] + devaluate evalSlotDomain(u,dollar) + +getCategoriesOfDomain domain == + predkeyVec := domain.4.0 + catforms := CADR domain.4 + [fn for i in 0..MAXINDEX predkeyVec | test] where + test() == predkeyVec.i and + (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] + fn == + VECP x => devaluate x + devaluateSlotDomain(x,domain) + +getInheritanceByDoc(D,op,sig,:options) == +--gets inheritance and documentation information by looking in the LISPLIB +--for each ancestor of the domain + catList := KAR options or getExtensionsOfDomain D + getDocDomainForOpSig(op,sig,devaluate D,D) or + or/[fn for x in catList] or '(NIL NIL) + where fn() == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) + +getDocDomainForOpSig(op,sig,dollar,D) == + (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) + and (doc := or/[[d,dollar] for [s,:d] in u | compareSig(sig,s,D,dollar)]) + +--======================================================================= +-- Functions implementing showImp +--======================================================================= +showDomainsOp1(u,key) == + while u and CAR u is [op,sig,: =key] repeat + sayBrightly ['" ",:formatOpSignature(op,sig)] + u := rest u + u + +getDomainRefName(dom,nam) == + PAIRP nam => [getDomainRefName(dom,x) for x in nam] + not FIXP nam => nam + slot := dom.nam + VECP slot => slot.0 + slot is ['SETELT,:.] => getDomainRefName(dom,getDomainSeteltForm slot) + slot + +getDomainSeteltForm ['SETELT,.,.,form] == + form is ['evalSlotDomain,u,d] => devaluateSlotDomain(u,d) + VECP form => systemError() + form + +showPredicates dom == + sayBrightly '"--------------------Predicate summary-------------------" + conname := CAR dom.0 + predvector := dom.3 + predicateList := GETDATABASE(conname,'PREDICATES) + for i in 1.. for p in predicateList repeat + prefix := + testBitVector(predvector,i) => '"true : " + '"false: " + sayBrightly [prefix,:pred2English p] + +showAttributes dom == + sayBrightly '"--------------------Attribute summary-------------------" + conname := CAR dom.0 + abb := getConstructorAbbreviation conname + predvector := dom.3 + for [a,:p] in dom.2 repeat + prefix := + testBitVector(predvector,p) => '"true : " + '"false: " + sayBrightly concat(prefix,form2String a) + +showGoGet dom == + numvec := CDDR dom.4 + for i in 6..MAXINDEX dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := + [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] + index := index + numOfArgs + 1 + namePart := + concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) + sayBrightly [i,'": ",:formatOpSignature(op,signumList),:namePart] + +formatLazyDomain(dom,x) == + VECP x => devaluate x + x is [dollar,slotNumber,:form] => formatLazyDomainForm(dom,form) + systemError nil + +formatLazyDomainForm(dom,x) == + x = 0 => ["$"] + FIXP x => formatLazyDomain(dom,dom.x) + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/simpbool.boot b/src/interp/simpbool.boot deleted file mode 100644 index 12455d20..00000000 --- a/src/interp/simpbool.boot +++ /dev/null @@ -1,203 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -simpBool x == dnf2pf reduceDnf be x - -reduceDnf u == --- (OR (AND ..b..) b) ==> (OR b ) - atom u => u - for x in u repeat - ok := true - for y in u repeat - x = y => 'skip - dnfContains(x,y) => return (ok := false) - ok = true => acc := [x,:acc] - nreverse acc - -dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where - fn(x,y) == and/[member(u,x) for u in y] - -prove x == - world := [p for y in listOfUserIds x | (p := getPredicate y)] => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = be mkpf([x,:world],'AND) => false - x - 'false = (y := be x) => 'false - y = 'true => true - dnf2pf y - -simpBoolGiven(x,world) == - world => - 'false = be mkpf([['NOT,x],:world],'AND) => true - 'false = (y := be mkpf([x,:world],'AND)) => false - (u := andReduce(dnf2pf y,world)) is ['AND,:v] and - (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] - u - 'false = (y := be x) => false - 'true = y => true - dnf2pf y - -andReduce(x,y) == - x is ['AND,:r] => - y is ['AND,:s] => mkpf(S_-(r,s),'AND) - mkpf(S_-(r,[s]),'AND) - x -dnf2pf(x) == - x = 'true => 'T - x = 'false => nil - atom x => x - mkpf( - [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) -be x == b2dnf x -b2dnf x == - x = 'T => 'true - x = NIL => 'false - atom x => bassert x - [op,:argl] := x - MEMQ(op,'(AND and)) => band argl - MEMQ(op,'(OR or)) => bor argl - MEMQ(op,'(NOT not)) => bnot first argl - bassert x -band x == - x is [h,:t] => andDnf(b2dnf h,band t) - 'true -bor x == - x is [a,:b] => orDnf(b2dnf a,bor b) - 'false -bnot x == notDnf b2dnf x -bassert x == [[nil,[x]]] -bassertNot x == [[[x],nil]] -------------------------Disjunctive Normal Form Code----------------------- --- dnf is true | false | [coaf ... ] --- coaf is true | false | [item ... ] --- item is anything - -orDnf(a,b) == -- or: (dnf, dnf) -> dnf - a = 'false => b - b = 'false => a - a = 'true or b = 'true => 'true - null a => b --null list means false - a is [c] = coafOrDnf(c,b) - coafOrDnf(first a,orDnf(rest a,b)) - -andDnf(a,b) == -- and: (dnf, dnf) -> dnf - a = 'true => b - b = 'true => a - a = 'false or b = 'false => 'false - null a => 'false --null list means false - a is [c] => coafAndDnf(c,b) - x := coafAndDnf(first a,b) - y := andDnf(rest a,b) - x = 'false => y - y = 'false => x - ordUnion(x,y) - -notDnf l == -- not: dnf -> dnf - l = 'true => 'false - l = 'false => 'true - null l => 'true --null list means false - l is [x] => notCoaf x - andDnf(notCoaf first l,notDnf rest l) - -coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf - a = 'true or l = 'true => 'true - a = 'false => l - member(a,l) => l - y := notCoaf a - x := ordIntersection(y,l) - null x => orDel(a,l) - x = l => 'true - x = y => ordSetDiff(l,x) - ordUnion(notDnf ordSetDiff(y,x),l) - -coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf - a = 'true => b - a = 'false => 'false - [c,:r] := b - null r => coafAndCoaf(a,c) - x := coafAndCoaf(a,c) --dnf - y := coafAndDnf(a,r) --dnf - x = 'false => y - y = 'false => x - ordUnion(x,y) - -coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf - ordIntersection(a,q) or ordIntersection(b,p) => 'false - [[ordUnion(a,p),ordUnion(b,q)]] - -notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] - -list1 l == - l isnt [h,:t] => nil - null h => list1 t - [[h,nil,nil],:list1 t] -list2 l == - l isnt [h,:t] => nil - null h => list2 t - [[nil,h,nil],:list2 t] -list3 l == - l isnt [h,:t] => nil - null h => list3 t - [[nil,nil,h],:list3 t] -orDel(a,l) == - l is [h,:t] => - a = h => t - ?ORDER(a,h) => [a,:l] - [h,:orDel(a,t)] - [a] -ordList l == - l is [h,:t] and t => orDel(h,ordList t) - l -ordUnion(a,b) == - a isnt [c,:r] => b - b isnt [d,:s] => a - c=d => [c,:ordUnion(r,s)] - ?ORDER(a,b) => [c,:ordUnion(r,b)] - [d,:ordUnion(s,a)] -ordIntersection(a,b) == - a isnt [h,:t] => nil - member(h,b) => [h,:ordIntersection(t,b)] - ordIntersection(t,b) -ordSetDiff(a,b) == - b isnt [h,:t] => a - member(h,a) => ordSetDiff(delete(h,a),t) - ordSetDiff(a,t) -------------- -testPredList u == - for x in u repeat - y := simpBool x - x = y => nil - pp x - pp '"==========>" - pp y diff --git a/src/interp/simpbool.boot.pamphlet b/src/interp/simpbool.boot.pamphlet new file mode 100644 index 00000000..88021ab9 --- /dev/null +++ b/src/interp/simpbool.boot.pamphlet @@ -0,0 +1,225 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp simpbool.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +simpBool x == dnf2pf reduceDnf be x + +reduceDnf u == +-- (OR (AND ..b..) b) ==> (OR b ) + atom u => u + for x in u repeat + ok := true + for y in u repeat + x = y => 'skip + dnfContains(x,y) => return (ok := false) + ok = true => acc := [x,:acc] + nreverse acc + +dnfContains([a,b],[c,d]) == fn(a,c) and fn(b,d) where + fn(x,y) == and/[member(u,x) for u in y] + +prove x == + world := [p for y in listOfUserIds x | (p := getPredicate y)] => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = be mkpf([x,:world],'AND) => false + x + 'false = (y := be x) => 'false + y = 'true => true + dnf2pf y + +simpBoolGiven(x,world) == + world => + 'false = be mkpf([['NOT,x],:world],'AND) => true + 'false = (y := be mkpf([x,:world],'AND)) => false + (u := andReduce(dnf2pf y,world)) is ['AND,:v] and + (w := SETDIFFERENCE(v,world)) ^= v => simpBool ['AND,:w] + u + 'false = (y := be x) => false + 'true = y => true + dnf2pf y + +andReduce(x,y) == + x is ['AND,:r] => + y is ['AND,:s] => mkpf(S_-(r,s),'AND) + mkpf(S_-(r,[s]),'AND) + x +dnf2pf(x) == + x = 'true => 'T + x = 'false => nil + atom x => x + mkpf( + [mkpf([:[k for k in b],:[['not,k] for k in a]],'AND) for [a,b] in x],'OR) +be x == b2dnf x +b2dnf x == + x = 'T => 'true + x = NIL => 'false + atom x => bassert x + [op,:argl] := x + MEMQ(op,'(AND and)) => band argl + MEMQ(op,'(OR or)) => bor argl + MEMQ(op,'(NOT not)) => bnot first argl + bassert x +band x == + x is [h,:t] => andDnf(b2dnf h,band t) + 'true +bor x == + x is [a,:b] => orDnf(b2dnf a,bor b) + 'false +bnot x == notDnf b2dnf x +bassert x == [[nil,[x]]] +bassertNot x == [[[x],nil]] +------------------------Disjunctive Normal Form Code----------------------- +-- dnf is true | false | [coaf ... ] +-- coaf is true | false | [item ... ] +-- item is anything + +orDnf(a,b) == -- or: (dnf, dnf) -> dnf + a = 'false => b + b = 'false => a + a = 'true or b = 'true => 'true + null a => b --null list means false + a is [c] = coafOrDnf(c,b) + coafOrDnf(first a,orDnf(rest a,b)) + +andDnf(a,b) == -- and: (dnf, dnf) -> dnf + a = 'true => b + b = 'true => a + a = 'false or b = 'false => 'false + null a => 'false --null list means false + a is [c] => coafAndDnf(c,b) + x := coafAndDnf(first a,b) + y := andDnf(rest a,b) + x = 'false => y + y = 'false => x + ordUnion(x,y) + +notDnf l == -- not: dnf -> dnf + l = 'true => 'false + l = 'false => 'true + null l => 'true --null list means false + l is [x] => notCoaf x + andDnf(notCoaf first l,notDnf rest l) + +coafOrDnf(a,l) == -- or: (coaf, dnf) -> dnf + a = 'true or l = 'true => 'true + a = 'false => l + member(a,l) => l + y := notCoaf a + x := ordIntersection(y,l) + null x => orDel(a,l) + x = l => 'true + x = y => ordSetDiff(l,x) + ordUnion(notDnf ordSetDiff(y,x),l) + +coafAndDnf(a,b) == --and: (coaf, dnf) -> dnf + a = 'true => b + a = 'false => 'false + [c,:r] := b + null r => coafAndCoaf(a,c) + x := coafAndCoaf(a,c) --dnf + y := coafAndDnf(a,r) --dnf + x = 'false => y + y = 'false => x + ordUnion(x,y) + +coafAndCoaf([a,b],[p,q]) == --and: (coaf,coaf) -> dnf + ordIntersection(a,q) or ordIntersection(b,p) => 'false + [[ordUnion(a,p),ordUnion(b,q)]] + +notCoaf [a,b] == [:[[nil,[x]] for x in a],:[[[x],nil] for x in b]] + +list1 l == + l isnt [h,:t] => nil + null h => list1 t + [[h,nil,nil],:list1 t] +list2 l == + l isnt [h,:t] => nil + null h => list2 t + [[nil,h,nil],:list2 t] +list3 l == + l isnt [h,:t] => nil + null h => list3 t + [[nil,nil,h],:list3 t] +orDel(a,l) == + l is [h,:t] => + a = h => t + ?ORDER(a,h) => [a,:l] + [h,:orDel(a,t)] + [a] +ordList l == + l is [h,:t] and t => orDel(h,ordList t) + l +ordUnion(a,b) == + a isnt [c,:r] => b + b isnt [d,:s] => a + c=d => [c,:ordUnion(r,s)] + ?ORDER(a,b) => [c,:ordUnion(r,b)] + [d,:ordUnion(s,a)] +ordIntersection(a,b) == + a isnt [h,:t] => nil + member(h,b) => [h,:ordIntersection(t,b)] + ordIntersection(t,b) +ordSetDiff(a,b) == + b isnt [h,:t] => a + member(h,a) => ordSetDiff(delete(h,a),t) + ordSetDiff(a,t) +------------- +testPredList u == + for x in u repeat + y := simpBool x + x = y => nil + pp x + pp '"==========>" + pp y +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/slam.boot b/src/interp/slam.boot deleted file mode 100644 index 8427e698..00000000 --- a/src/interp/slam.boot +++ /dev/null @@ -1,335 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -reportFunctionCompilation(op,nam,argl,body,isRecursive) == - -- for an alternate definition of this function which does not allow - -- dynamic caching, see SLAMOLD BOOT ---+ - $compiledOpNameList := [nam] - minivectorName := makeInternalMapMinivectorName(nam) - $minivectorNames := [[op,:minivectorName],:$minivectorNames] - body := SUBST(minivectorName,"$$$",body) - if $compilingInputFile then - $minivectorCode := [:$minivectorCode,minivectorName] - SET(minivectorName,LIST2REFVEC $minivector) - argl := COPY argl -- play it safe for optimization - init := - not(isRecursive and $compileRecurrence and #argl = 1) => nil - NRTisRecurrenceRelation(nam,body,minivectorName) - init => compileRecurrenceRelation(op,nam,argl,body,init) - cacheCount:= getCacheCount op - cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) - cacheCount = 0 or null argl => - function:= [nam,['LAMBDA,[:argl,'envArg],body]] - compileInteractive function - nam - num := - FIXP cacheCount => - cacheCount < 1 => - keyedSystemError("S2IM0019",[cacheCount,op]) - cacheCount - keyedSystemError("S2IM0019",[cacheCount,op]) - sayKeyedMsg("S2IX0003",[op,num]) - auxfn := mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [nil,[auxfn]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - cacheName := mkCacheName nam - g2:= GENSYM() --length of cache or arg-value pair - g3:= GENSYM() --value computed by calling function - secondPredPair:= - null argl => [cacheName] - [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] - thirdPredPair:= - null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] - ['(QUOTE T), - ['SETQ,g2,computeValue], - ['SETQ,g3, - ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], - ['RPLACA,g3,g1], - ['RPLACD,g3,g2], - g2] - codeBody:= - ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] - -- cannot use envArg in next statement without redoing much - -- of above. - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'function - cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] - cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - SETANDFILE(cacheName,mkCircularAlist cacheCount) - nam - -getCacheCount fn == - n:= LASSOC(fn,$cacheAlist) => n - $cacheCount - -reportFunctionCacheAll(op,nam,argl,body) == - sayKeyedMsg("S2IX0004",[op]) - auxfn:= mkAuxiliaryName nam - g1:= GENSYM() --argument or argument list - [arg,computeValue] := - null argl => [['envArg],[auxfn, 'envArg]] - argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter - [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list - if null argl then g1:=nil - cacheName:= mkCacheName nam - g2:= GENSYM() --value computed by calling function - secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] - thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] - codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] - lamex:= ['LAM,arg,codeBody] - mainFunction:= [nam,lamex] - computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] - compileInteractive mainFunction - compileInteractive computeFunction - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - eval cacheResetCode - nam - -hashCount table == - +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] - -mkCircularAlist n == - l:= [[$failed,:$failed] for i in 1..n] - RPLACD(LASTNODE l,l) - -countCircularAlist(cal,n) == - +/[nodeCount x for x in cal for i in 1..n] - -predCircular(al,n) == - for i in 1..QSSUB1 n repeat al:= QCDR al - al - -assocCircular(x,al) == --like ASSOC except that al is circular - forwardPointer:= al - val:= nil - until EQ(forwardPointer,al) repeat - EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) - forwardPointer:= CDR forwardPointer - val - -compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == - k:= #initCode - extraArgumentCode := - extraArguments := [x for x in argl | x ^= sharpArg] => - extraArguments is [x] => x - ['LIST,:extraArguments] - nil - g:= GENSYM() - gIndex:= GENSYM() - gsList:= [GENSYM() for x in initCode] - auxfn := mkAuxiliaryName(nam) - $compiledOpNameList := [:$compiledOpNameList,auxfn] - stateNam:= GENVAR() - stateVar:= GENSYM() - stateVal:= GENSYM() - lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) - decomposeCode:= - [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] - for g in gsList for i in 1..]] - gsRev:= REVERSE gsList - rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] - advanceCode:= ['LET,gIndex,['ADD1,gIndex]] - - newTripleCode := ['LIST,sharpArg,:gsList] - newStateCode := - null extraArguments => ['SETQ,stateNam,newTripleCode] - ['HPUT,stateNam,extraArgumentCode,newTripleCode] - - computeFunction:= [auxfn,['LAM,cargl,cbody]] where - cargl:= [:argl,lastArg] - returnValue:= ['PROGN,newStateCode,first gsList] - cbody:= - endTest:= - ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] - newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, - EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] - ['PROGN,:decomposeCode, - ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, - newValueCode,:rotateCode]]] - fromScratchInit:= - [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] - continueInit:= - [['LET,gIndex,['ELT,stateVar,0]], - :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] - mainFunction:= [nam,['LAM,margl,mbody]] where - margl:= [:argl,'envArg] - max:= GENSYM() - tripleCode := ['CONS,n,['LIST,:initCode]] - - -- initialSetCode initializes the global variable if necessary and - -- also binds "stateVar" to its current value - initialSetCode := - initialValueCode := - extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] - tripleCode - cacheResetCode := ['SETQ,stateNam,initialValueCode] - ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ - ['PAIRP,stateNam]]], _ - ['LET,stateVar,cacheResetCode]], _ - [''T, ['LET,stateVar,stateNam]]] - - -- when there are extra arguments, initialResetCode resets "stateVar" - -- to the hashtable entry for the extra arguments - initialResetCode := - null extraArguments => nil - [['LET,stateVar,['OR, - ['HGET,stateVar,extraArgumentCode], - ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] - - mbody := - preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] - phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], - [auxfn,:argl,stateVar]] - phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], - ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] - phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] - phrase4:= [['GT,sharpArg,n-k], - ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] - phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] - ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] - sayKeyedMsg("S2IX0001",[op]) - compileInteractive computeFunction - compileInteractive mainFunction - cacheType:= 'recurrence - cacheCountCode:= ['nodeCount,stateNam] - cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) - $e:= put(nam,'cacheInfo, cacheVector,$e) - nam - -nodeCount x == NUMOFNODES x - -recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) - -mkCacheVec(op,nam,kind,resetCode,countCode) == - [op,nam,kind,resetCode,countCode] - --- reportCacheStore vl == --- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") --- sayMSG concat(centerString('"----",22,'" ")," ---- ------") --- for x in vl repeat reportCacheStoreFor x --- --- op2String op == --- u:= linearFormatName op --- atom u => PNAME u --- "STRCONC"/u --- --- reportCacheStorePrint(op,kind,count) == --- ops:= op2String op --- opString:= centerString(ops,22,'" ") --- kindString:= centerString(PNAME kind,10,'" ") --- countString:= centerString(count,19,'" ") --- sayMSG concat(opString,kindString,countString) --- --- reportCacheStoreFor op == --- u:= getI(op,'localModemap) => --- for [['local,target,:.],[.,fn],:.] in u repeat --- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or --- keyedSystemError("S2GE0016",['"reportCacheStoreFor", --- '"missing cache information vector"]) --- reportCacheStorePrint(op,kind,eval countCode) --- true --- u:= getI(op,"cache") => --- reportCacheStorePrint(op,'variable,nodeCount u) --- nil - -clearCache x == - get(x,'localModemap,$e) or get(x,'mapBody,$e) => - for [map,:sub] in $mapSubNameAlist repeat - map=x => _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,'localModemap,nil,$e) - $e:= putHist(x,'mapBody,nil,$e) - $e:= putHist(x,'localVars,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -clearLocalModemaps x == - u:= get(x,"localModemap",$e) => - for sub in ASSOCRIGHT $mapSubNameAlist repeat - _/UNTRACE_,2(sub,NIL) - $e:= putHist(x,"localModemap",nil,$e) - for mm in u repeat - [.,fn,:.] := mm - if def:= get(fn,'definition,$e) then - $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) - if cacheVec:= get(fn,'cacheInfo,$e) then - SET(cacheVec.cacheName,NIL) - -- now clear the property list of the identifier - $e := addIntSymTabBinding(x,nil,$e) - sayKeyedMsg("S2IX0007",[x]) - -compileInteractive fn == - if $InteractiveMode then startTimingProcess 'compilation - --following not used for common lisp - --removeUnnecessaryLastArguments CADR fn - if $reportCompilation then - sayBrightlyI bright '"Generated LISP code for function:" - pp fn - optfn := - $InteractiveMode => [timedOptimization fn] - [fn] - result := compQuietly optfn - if $InteractiveMode then stopTimingProcess 'compilation - result - -clearAllSlams x == - fn(x,nil) where - fn(thoseToClear,thoseCleared) == - for x in thoseToClear | not MEMQ(x,thoseCleared) repeat - slamListName:= mkCacheName x - SET(slamListName,nil) - thoseCleared:= ADJOIN(x,thoseCleared) - someMoreToClear:= - setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: - thoseCleared]) - NCONC(thoseToClear,someMoreToClear) - -clearSlam("functor")== - id:= mkCacheName functor - SET(id,nil) diff --git a/src/interp/slam.boot.pamphlet b/src/interp/slam.boot.pamphlet new file mode 100644 index 00000000..4b080f02 --- /dev/null +++ b/src/interp/slam.boot.pamphlet @@ -0,0 +1,359 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\File{src/interp/slam.boot} Pamphlet} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +reportFunctionCompilation(op,nam,argl,body,isRecursive) == + -- for an alternate definition of this function which does not allow + -- dynamic caching, see SLAMOLD BOOT +--+ + $compiledOpNameList := [nam] + minivectorName := makeInternalMapMinivectorName(nam) + $minivectorNames := [[op,:minivectorName],:$minivectorNames] + body := SUBST(minivectorName,"$$$",body) + if $compilingInputFile then + $minivectorCode := [:$minivectorCode,minivectorName] + SET(minivectorName,LIST2REFVEC $minivector) + argl := COPY argl -- play it safe for optimization + init := + not(isRecursive and $compileRecurrence and #argl = 1) => nil + NRTisRecurrenceRelation(nam,body,minivectorName) + init => compileRecurrenceRelation(op,nam,argl,body,init) + cacheCount:= getCacheCount op + cacheCount = "all" => reportFunctionCacheAll(op,nam,argl,body) + cacheCount = 0 or null argl => + function:= [nam,['LAMBDA,[:argl,'envArg],body]] + compileInteractive function + nam + num := + FIXP cacheCount => + cacheCount < 1 => + keyedSystemError("S2IM0019",[cacheCount,op]) + cacheCount + keyedSystemError("S2IM0019",[cacheCount,op]) + sayKeyedMsg("S2IX0003",[op,num]) + auxfn := mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [nil,[auxfn]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + cacheName := mkCacheName nam + g2:= GENSYM() --length of cache or arg-value pair + g3:= GENSYM() --value computed by calling function + secondPredPair:= + null argl => [cacheName] + [['SETQ,g3,['assocCircular,g1,cacheName]],['CDR,g3]] + thirdPredPair:= + null argl => ['(QUOTE T),['SETQ,cacheName,computeValue]] + ['(QUOTE T), + ['SETQ,g2,computeValue], + ['SETQ,g3, + ['CAR,['SETQ,cacheName,['predCircular,cacheName,cacheCount]]]], + ['RPLACA,g3,g1], + ['RPLACD,g3,g2], + g2] + codeBody:= + ['PROG,[g2,g3],['RETURN,['COND,secondPredPair,thirdPredPair]]] + -- cannot use envArg in next statement without redoing much + -- of above. + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'function + cacheResetCode:= ['SETQ,cacheName,['mkCircularAlist,cacheCount]] + cacheCountCode:= ['countCircularAlist,cacheName,cacheCount] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + SETANDFILE(cacheName,mkCircularAlist cacheCount) + nam + +getCacheCount fn == + n:= LASSOC(fn,$cacheAlist) => n + $cacheCount + +reportFunctionCacheAll(op,nam,argl,body) == + sayKeyedMsg("S2IX0004",[op]) + auxfn:= mkAuxiliaryName nam + g1:= GENSYM() --argument or argument list + [arg,computeValue] := + null argl => [['envArg],[auxfn, 'envArg]] + argl is [.] => [[g1, 'envArg],[auxfn,g1, 'envArg]] --g1 is a parameter + [g1,['APPLX,MKQ auxfn,g1]] --g1 is a parameter list + if null argl then g1:=nil + cacheName:= mkCacheName nam + g2:= GENSYM() --value computed by calling function + secondPredPair:= [['SETQ,g2,['HGET,cacheName,g1]],g2] + thirdPredPair:= ['(QUOTE T),['HPUT,cacheName,g1,computeValue]] + codeBody:= ['PROG,[g2],['RETURN,['COND,secondPredPair,thirdPredPair]]] + lamex:= ['LAM,arg,codeBody] + mainFunction:= [nam,lamex] + computeFunction:= [auxfn,['LAMBDA,[:argl, 'envArg],body]] + compileInteractive mainFunction + compileInteractive computeFunction + cacheType:= 'hash_-table + cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE,''UEQUAL]] + cacheCountCode:= ['hashCount,cacheName] + cacheVector:= + mkCacheVec(op,cacheName,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + eval cacheResetCode + nam + +hashCount table == + +/[ADD1 nodeCount HGET(table,key) for key in HKEYS table] + +mkCircularAlist n == + l:= [[$failed,:$failed] for i in 1..n] + RPLACD(LASTNODE l,l) + +countCircularAlist(cal,n) == + +/[nodeCount x for x in cal for i in 1..n] + +predCircular(al,n) == + for i in 1..QSSUB1 n repeat al:= QCDR al + al + +assocCircular(x,al) == --like ASSOC except that al is circular + forwardPointer:= al + val:= nil + until EQ(forwardPointer,al) repeat + EQUAL(CAAR forwardPointer,x) => return (val:= CAR forwardPointer) + forwardPointer:= CDR forwardPointer + val + +compileRecurrenceRelation(op,nam,argl,junk,[body,sharpArg,n,:initCode]) == + k:= #initCode + extraArgumentCode := + extraArguments := [x for x in argl | x ^= sharpArg] => + extraArguments is [x] => x + ['LIST,:extraArguments] + nil + g:= GENSYM() + gIndex:= GENSYM() + gsList:= [GENSYM() for x in initCode] + auxfn := mkAuxiliaryName(nam) + $compiledOpNameList := [:$compiledOpNameList,auxfn] + stateNam:= GENVAR() + stateVar:= GENSYM() + stateVal:= GENSYM() + lastArg := INTERNL STRCONC('"#",STRINGIMAGE QSADD1 LENGTH argl) + decomposeCode:= + [['LET,gIndex,['ELT,lastArg,0]],:[['LET,g,['ELT,lastArg,i]] + for g in gsList for i in 1..]] + gsRev:= REVERSE gsList + rotateCode:= [['LET,p,q] for p in gsRev for q in [:rest gsRev,g]] + advanceCode:= ['LET,gIndex,['ADD1,gIndex]] + + newTripleCode := ['LIST,sharpArg,:gsList] + newStateCode := + null extraArguments => ['SETQ,stateNam,newTripleCode] + ['HPUT,stateNam,extraArgumentCode,newTripleCode] + + computeFunction:= [auxfn,['LAM,cargl,cbody]] where + cargl:= [:argl,lastArg] + returnValue:= ['PROGN,newStateCode,first gsList] + cbody:= + endTest:= + ['COND, [['EQL,sharpArg,gIndex],['RETURN,returnValue]]] + newValueCode:= ['LET,g,SUBST(gIndex,sharpArg, + EQSUBSTLIST(gsList,rest $TriangleVariableList,body))] + ['PROGN,:decomposeCode, + ['REPEAT,['WHILE,'T],['PROGN,endTest,advanceCode, + newValueCode,:rotateCode]]] + fromScratchInit:= + [['LET,gIndex,n],:[['LET,g,x] for g in gsList for x in initCode]] + continueInit:= + [['LET,gIndex,['ELT,stateVar,0]], + :[['LET,g,['ELT,stateVar,i]] for g in gsList for i in 1..]] + mainFunction:= [nam,['LAM,margl,mbody]] where + margl:= [:argl,'envArg] + max:= GENSYM() + tripleCode := ['CONS,n,['LIST,:initCode]] + + -- initialSetCode initializes the global variable if necessary and + -- also binds "stateVar" to its current value + initialSetCode := + initialValueCode := + extraArguments => ['MAKE_-HASHTABLE,''UEQUAL] + tripleCode + cacheResetCode := ['SETQ,stateNam,initialValueCode] + ['COND,[['NULL,['AND,['BOUNDP,MKQ stateNam], _ + ['PAIRP,stateNam]]], _ + ['LET,stateVar,cacheResetCode]], _ + [''T, ['LET,stateVar,stateNam]]] + + -- when there are extra arguments, initialResetCode resets "stateVar" + -- to the hashtable entry for the extra arguments + initialResetCode := + null extraArguments => nil + [['LET,stateVar,['OR, + ['HGET,stateVar,extraArgumentCode], + ['HPUT,stateVar,extraArgumentCode,tripleCode]]]] + + mbody := + preset := [initialSetCode,:initialResetCode,['LET,max,['ELT,stateVar,0]]] + phrase1:= [['AND,['LET,max,['ELT,stateVar,0]],['GE,sharpArg,max]], + [auxfn,:argl,stateVar]] + phrase2:= [['GT,sharpArg,['SETQ,max,['DIFFERENCE,max,k]]], + ['ELT,stateVar,['QSADD1,['QSDIFFERENCE,k,['DIFFERENCE,sharpArg,max]]]]] + phrase3:= [['GT,sharpArg,n],[auxfn,:argl,['LIST,n,:initCode]]] + phrase4:= [['GT,sharpArg,n-k], + ['ELT,['LIST,:initCode],['QSDIFFERENCE,n,sharpArg]]] + phrase5:= ['(QUOTE T),['recurrenceError,MKQ op,sharpArg]] + ['PROGN,:preset,['COND,phrase1,phrase2,phrase3,phrase4,phrase5]] + sayKeyedMsg("S2IX0001",[op]) + compileInteractive computeFunction + compileInteractive mainFunction + cacheType:= 'recurrence + cacheCountCode:= ['nodeCount,stateNam] + cacheVector:= mkCacheVec(op,stateNam,cacheType,cacheResetCode,cacheCountCode) + $e:= put(nam,'cacheInfo, cacheVector,$e) + nam + +nodeCount x == NUMOFNODES x + +recurrenceError(op,arg) == throwKeyedMsg("S2IX0002",[op,arg]) + +mkCacheVec(op,nam,kind,resetCode,countCode) == + [op,nam,kind,resetCode,countCode] + +-- reportCacheStore vl == +-- sayMSG concat(centerString('"Name",22,'" ")," Kind #Cells") +-- sayMSG concat(centerString('"----",22,'" ")," ---- ------") +-- for x in vl repeat reportCacheStoreFor x +-- +-- op2String op == +-- u:= linearFormatName op +-- atom u => PNAME u +-- "STRCONC"/u +-- +-- reportCacheStorePrint(op,kind,count) == +-- ops:= op2String op +-- opString:= centerString(ops,22,'" ") +-- kindString:= centerString(PNAME kind,10,'" ") +-- countString:= centerString(count,19,'" ") +-- sayMSG concat(opString,kindString,countString) +-- +-- reportCacheStoreFor op == +-- u:= getI(op,'localModemap) => +-- for [['local,target,:.],[.,fn],:.] in u repeat +-- [op1,cacheName,kind,.,countCode]:= getI(fn,'cacheInfo) or +-- keyedSystemError("S2GE0016",['"reportCacheStoreFor", +-- '"missing cache information vector"]) +-- reportCacheStorePrint(op,kind,eval countCode) +-- true +-- u:= getI(op,"cache") => +-- reportCacheStorePrint(op,'variable,nodeCount u) +-- nil + +clearCache x == + get(x,'localModemap,$e) or get(x,'mapBody,$e) => + for [map,:sub] in $mapSubNameAlist repeat + map=x => _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,'localModemap,nil,$e) + $e:= putHist(x,'mapBody,nil,$e) + $e:= putHist(x,'localVars,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +clearLocalModemaps x == + u:= get(x,"localModemap",$e) => + for sub in ASSOCRIGHT $mapSubNameAlist repeat + _/UNTRACE_,2(sub,NIL) + $e:= putHist(x,"localModemap",nil,$e) + for mm in u repeat + [.,fn,:.] := mm + if def:= get(fn,'definition,$e) then + $e:= putHist(x,'value,mkObj(def,$EmptyMode),$e) + if cacheVec:= get(fn,'cacheInfo,$e) then + SET(cacheVec.cacheName,NIL) + -- now clear the property list of the identifier + $e := addIntSymTabBinding(x,nil,$e) + sayKeyedMsg("S2IX0007",[x]) + +compileInteractive fn == + if $InteractiveMode then startTimingProcess 'compilation + --following not used for common lisp + --removeUnnecessaryLastArguments CADR fn + if $reportCompilation then + sayBrightlyI bright '"Generated LISP code for function:" + pp fn + optfn := + $InteractiveMode => [timedOptimization fn] + [fn] + result := compQuietly optfn + if $InteractiveMode then stopTimingProcess 'compilation + result + +clearAllSlams x == + fn(x,nil) where + fn(thoseToClear,thoseCleared) == + for x in thoseToClear | not MEMQ(x,thoseCleared) repeat + slamListName:= mkCacheName x + SET(slamListName,nil) + thoseCleared:= ADJOIN(x,thoseCleared) + someMoreToClear:= + setDifference(LASSOC(x,$functorDependencyAlist),[:thoseToClear,: + thoseCleared]) + NCONC(thoseToClear,someMoreToClear) + +clearSlam("functor")== + id:= mkCacheName functor + SET(id,nil) +@ + +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/sockio.lisp b/src/interp/sockio.lisp deleted file mode 100644 index d20205d1..00000000 --- a/src/interp/sockio.lisp +++ /dev/null @@ -1,241 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -;; load C socket functions - -(in-package "BOOT") - -#+(and :Lucid (not :ibm/370)) -(progn - (system:define-foreign-function :c 'open_server :fixnum) - (system:define-foreign-function :c 'sock_get_int :fixnum) - (system:define-foreign-function :c 'sock_send_int :fixnum) - (system:define-foreign-function :c 'sock_get_string_buf :fixnum) - (system:define-foreign-function :c 'sock_send_string_len :fixnum) - (system:define-foreign-function :c 'sock_get_float :single) - (system:define-foreign-function :c 'sock_send_float :fixnum) - (system:define-foreign-function :c 'sock_send_wakeup :fixnum) - (system:define-foreign-function :c 'server_switch :fixnum) - (system:define-foreign-function :c 'flush_stdout :fixnum) - (system:define-foreign-function :c 'sock_send_signal :fixnum) - (system:define-foreign-function :c 'print_line :fixnum) - (system:define-foreign-function :c 'plus_infininty :single) - (system:define-foreign-function :c 'minus_infinity :single) - (system:define-foreign-function :c 'NANQ :single) -) - -#+KCL -(progn - (clines "extern double plus_infinity(), minus_infinity(), NANQ();") - (clines "extern double sock_get_float();") -;; GCL may pass strings by value. 'sock_get_string_buf' should fill -;; string with data read from connection, therefore needs address of -;; actual string buffer. We use 'sock_get_string_buf_wrapper' to -;; resolve the problem - (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" - "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" - " if (x->st.st_fillpst.st_self, j); }") - (defentry open_server (string) (int "open_server")) - (defentry sock_get_int (int) (int "sock_get_int")) - (defentry sock_send_int (int int) (int "sock_send_int")) - (defentry sock_get_string_buf (int object int) - (int "sock_get_string_buf_wrapper")) - (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) - (defentry sock_get_float (int) (double "sock_get_float")) - (defentry sock_send_float (int double) (int "sock_send_float")) - (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) - (defentry server_switch () (int "server_switch")) - (defentry flush_stdout () (int "flush_stdout")) - (defentry sock_send_signal (int int) (int "sock_send_signal")) - (defentry print_line (string) (int "print_line")) - (defentry plus_infinity () (double "plus_infinity")) - (defentry minus_infinity () (double "minus_infinity")) - (defentry NANQ () (double "NANQ")) - ) - -(defun open-server (name) -#+(and :lucid :ibm/370) -2 -#-(and :lucid :ibm/370) - (open_server name)) -(defun sock-get-int (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_int type)) -(defun sock-send-int (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_int type val)) -(defun sock-get-string (type buf buf-len) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_string_buf type buf buf-len)) -(defun sock-send-string (type str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_string_len type str (length str))) -(defun sock-get-float (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_get_float type)) -(defun sock-send-float (type val) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_float type val)) -(defun sock-send-wakeup (type) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_wakeup type)) -(defun server-switch () -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (server_switch)) -(defun sock-send-signal (type signal) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (sock_send_signal type signal)) -(defun print-line (str) -#+(and :lucid :ibm/370) () -#-(and :lucid :ibm/370) - (print_line str)) -(defun |plusInfinity| () (plus_infinity)) -(defun |minusInfinity| () (minus_infinity)) - -;; Macros for use in Boot - -(defun |openServer| (name) - (open_server name)) -(defun |sockGetInt| (type) - (sock_get_int type)) -(defun |sockSendInt| (type val) - (sock_send_int type val)) -(defun |sockGetString| (type buf buf-len) - (sock_get_string_buf type buf buf-len)) -(defun |sockSendString| (type str) - (sock_send_string_len type str (length str))) -(defun |sockGetFloat| (type) - (sock_get_float type)) -(defun |sockSendFloat| (type val) - (sock_send_float type val)) -(defun |sockSendWakeup| (type) - (sock_send_wakeup type)) -(defun |serverSwitch| () - (server_switch)) -(defun |sockSendSignal| (type signal) - (sock_send_signal type signal)) -(defun |printLine| (str) - (print_line str)) - -;; Socket types. This list must be consistent with the one in com.h - -(defconstant SessionManager 1) -(defconstant ViewportServer 2) -(defconstant MenuServer 3) -(defconstant SessionIO 4) -(defconstant MessageServer 5) -(defconstant InterpWindow 6) -(defconstant KillSpad 7) -(defconstant DebugWindow 8) -(defconstant NAGLinkServer 8) -(defconstant Forker 9) - -;; same constants for use in BOOT -(defconstant |$SessionManager| SessionManager) -(defconstant |$ViewportServer| ViewportServer) -(defconstant |$MenuServer| MenuServer) -(defconstant |$SessionIO| SessionIO) -(defconstant |$MessageServer| MessageServer) -(defconstant |$InterpWindow| InterpWindow) -(defconstant |$KillSpad| KillSpad) -(defconstant |$DebugWindow| DebugWindow) -(defconstant |$NAGLinkServer| NAGLinkServer) -(defconstant |$Forker| Forker) - -;; Session Manager action requests - -(defconstant CreateFrame 1) -(defconstant SwitchFrames 2) -(defconstant EndOfOutput 3) -(defconstant CallInterp 4) -(defconstant EndSession 5) -(defconstant LispCommand 6) -(defconstant SpadCommand 7) -(defconstant SendXEventToHyperTeX 8) -(defconstant QuietSpadCommand 9) -(defconstant CloseClient 10) -(defconstant QueryClients 11) -(defconstant QuerySpad 12) -(defconstant NonSmanSession 13) -(defconstant KillLispSystem 14) - -(defconstant |$CreateFrame| CreateFrame) -(defconstant |$SwitchFrames| SwitchFrames) -(defconstant |$EndOfOutput| EndOfOutput) -(defconstant |$CallInterp| CallInterp) -(defconstant |$EndSession| EndSession) -(defconstant |$LispCommand| LispCommand) -(defconstant |$SpadCommand| SpadCommand) -(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) -(defconstant |$QuietSpadCommand| QuietSpadCommand) -(defconstant |$CloseClient| CloseClient) -(defconstant |$QueryClients| QueryClients) -(defconstant |$QuerySpad| QuerySpad) -(defconstant |$NonSmanSession| NonSmanSession) -(defconstant |$KillLispSystem| KillLispSystem) - -;; signal types (from /usr/include/sys/signal.h) -#+(and :Lucid (not :ibm/370)) -(progn - (defconstant SIGUSR1 16) ;; user defined signal 1 - (defconstant SIGUSR2 17) ;; user defined signal 2 - ) - -#+:RIOS -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -#+:IBMPS2 -(progn - (defconstant SIGUSR1 30) ;; user defined signal 1 - (defconstant SIGUSR2 31) ;; user defined signal 2 - ) - -(setq |$NaNvalue| (NANQ)) -#-:ccl - (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) -#+:ccl - (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) -(setq |$minusInfinity| (- |$plusInfinity|)) - diff --git a/src/interp/sockio.lisp.pamphlet b/src/interp/sockio.lisp.pamphlet new file mode 100644 index 00000000..2a585267 --- /dev/null +++ b/src/interp/sockio.lisp.pamphlet @@ -0,0 +1,263 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp sockio.lisp} +\author{Timothy Daly} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +;; load C socket functions + +(in-package "BOOT") + +#+(and :Lucid (not :ibm/370)) +(progn + (system:define-foreign-function :c 'open_server :fixnum) + (system:define-foreign-function :c 'sock_get_int :fixnum) + (system:define-foreign-function :c 'sock_send_int :fixnum) + (system:define-foreign-function :c 'sock_get_string_buf :fixnum) + (system:define-foreign-function :c 'sock_send_string_len :fixnum) + (system:define-foreign-function :c 'sock_get_float :single) + (system:define-foreign-function :c 'sock_send_float :fixnum) + (system:define-foreign-function :c 'sock_send_wakeup :fixnum) + (system:define-foreign-function :c 'server_switch :fixnum) + (system:define-foreign-function :c 'flush_stdout :fixnum) + (system:define-foreign-function :c 'sock_send_signal :fixnum) + (system:define-foreign-function :c 'print_line :fixnum) + (system:define-foreign-function :c 'plus_infininty :single) + (system:define-foreign-function :c 'minus_infinity :single) + (system:define-foreign-function :c 'NANQ :single) +) + +#+KCL +(progn + (clines "extern double plus_infinity(), minus_infinity(), NANQ();") + (clines "extern double sock_get_float();") +;; GCL may pass strings by value. 'sock_get_string_buf' should fill +;; string with data read from connection, therefore needs address of +;; actual string buffer. We use 'sock_get_string_buf_wrapper' to +;; resolve the problem + (clines "int sock_get_string_buf_wrapper(int i, object x, int j)" + "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);" + " if (x->st.st_fillpst.st_self, j); }") + (defentry open_server (string) (int "open_server")) + (defentry sock_get_int (int) (int "sock_get_int")) + (defentry sock_send_int (int int) (int "sock_send_int")) + (defentry sock_get_string_buf (int object int) + (int "sock_get_string_buf_wrapper")) + (defentry sock_send_string_len (int string int) (int "sock_send_string_len")) + (defentry sock_get_float (int) (double "sock_get_float")) + (defentry sock_send_float (int double) (int "sock_send_float")) + (defentry sock_send_wakeup (int int) (int "sock_send_wakeup")) + (defentry server_switch () (int "server_switch")) + (defentry flush_stdout () (int "flush_stdout")) + (defentry sock_send_signal (int int) (int "sock_send_signal")) + (defentry print_line (string) (int "print_line")) + (defentry plus_infinity () (double "plus_infinity")) + (defentry minus_infinity () (double "minus_infinity")) + (defentry NANQ () (double "NANQ")) + ) + +(defun open-server (name) +#+(and :lucid :ibm/370) -2 +#-(and :lucid :ibm/370) + (open_server name)) +(defun sock-get-int (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_int type)) +(defun sock-send-int (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_int type val)) +(defun sock-get-string (type buf buf-len) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_string_buf type buf buf-len)) +(defun sock-send-string (type str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_string_len type str (length str))) +(defun sock-get-float (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_get_float type)) +(defun sock-send-float (type val) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_float type val)) +(defun sock-send-wakeup (type) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_wakeup type)) +(defun server-switch () +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (server_switch)) +(defun sock-send-signal (type signal) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (sock_send_signal type signal)) +(defun print-line (str) +#+(and :lucid :ibm/370) () +#-(and :lucid :ibm/370) + (print_line str)) +(defun |plusInfinity| () (plus_infinity)) +(defun |minusInfinity| () (minus_infinity)) + +;; Macros for use in Boot + +(defun |openServer| (name) + (open_server name)) +(defun |sockGetInt| (type) + (sock_get_int type)) +(defun |sockSendInt| (type val) + (sock_send_int type val)) +(defun |sockGetString| (type buf buf-len) + (sock_get_string_buf type buf buf-len)) +(defun |sockSendString| (type str) + (sock_send_string_len type str (length str))) +(defun |sockGetFloat| (type) + (sock_get_float type)) +(defun |sockSendFloat| (type val) + (sock_send_float type val)) +(defun |sockSendWakeup| (type) + (sock_send_wakeup type)) +(defun |serverSwitch| () + (server_switch)) +(defun |sockSendSignal| (type signal) + (sock_send_signal type signal)) +(defun |printLine| (str) + (print_line str)) + +;; Socket types. This list must be consistent with the one in com.h + +(defconstant SessionManager 1) +(defconstant ViewportServer 2) +(defconstant MenuServer 3) +(defconstant SessionIO 4) +(defconstant MessageServer 5) +(defconstant InterpWindow 6) +(defconstant KillSpad 7) +(defconstant DebugWindow 8) +(defconstant NAGLinkServer 8) +(defconstant Forker 9) + +;; same constants for use in BOOT +(defconstant |$SessionManager| SessionManager) +(defconstant |$ViewportServer| ViewportServer) +(defconstant |$MenuServer| MenuServer) +(defconstant |$SessionIO| SessionIO) +(defconstant |$MessageServer| MessageServer) +(defconstant |$InterpWindow| InterpWindow) +(defconstant |$KillSpad| KillSpad) +(defconstant |$DebugWindow| DebugWindow) +(defconstant |$NAGLinkServer| NAGLinkServer) +(defconstant |$Forker| Forker) + +;; Session Manager action requests + +(defconstant CreateFrame 1) +(defconstant SwitchFrames 2) +(defconstant EndOfOutput 3) +(defconstant CallInterp 4) +(defconstant EndSession 5) +(defconstant LispCommand 6) +(defconstant SpadCommand 7) +(defconstant SendXEventToHyperTeX 8) +(defconstant QuietSpadCommand 9) +(defconstant CloseClient 10) +(defconstant QueryClients 11) +(defconstant QuerySpad 12) +(defconstant NonSmanSession 13) +(defconstant KillLispSystem 14) + +(defconstant |$CreateFrame| CreateFrame) +(defconstant |$SwitchFrames| SwitchFrames) +(defconstant |$EndOfOutput| EndOfOutput) +(defconstant |$CallInterp| CallInterp) +(defconstant |$EndSession| EndSession) +(defconstant |$LispCommand| LispCommand) +(defconstant |$SpadCommand| SpadCommand) +(defconstant |$SendXEventToHyperTeX| SendXEventToHyperTeX) +(defconstant |$QuietSpadCommand| QuietSpadCommand) +(defconstant |$CloseClient| CloseClient) +(defconstant |$QueryClients| QueryClients) +(defconstant |$QuerySpad| QuerySpad) +(defconstant |$NonSmanSession| NonSmanSession) +(defconstant |$KillLispSystem| KillLispSystem) + +;; signal types (from /usr/include/sys/signal.h) +#+(and :Lucid (not :ibm/370)) +(progn + (defconstant SIGUSR1 16) ;; user defined signal 1 + (defconstant SIGUSR2 17) ;; user defined signal 2 + ) + +#+:RIOS +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +#+:IBMPS2 +(progn + (defconstant SIGUSR1 30) ;; user defined signal 1 + (defconstant SIGUSR2 31) ;; user defined signal 2 + ) + +(setq |$NaNvalue| (NANQ)) +#-:ccl + (setq |$plusInfinity| (* 1.1 MOST-POSITIVE-LONG-FLOAT)) +#+:ccl + (setq |$plusInfinity| MOST-POSITIVE-LONG-FLOAT) +(setq |$minusInfinity| (- |$plusInfinity|)) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp deleted file mode 100644 index dedfa3e0..00000000 --- a/src/interp/spad.lisp +++ /dev/null @@ -1,596 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -; NAME: Scratchpad Package -; PURPOSE: This is an initialization and system-building file for Scratchpad. - -(IMPORT-MODULE "bootlex") -(in-package "BOOT") - -;;; Common Block - -(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") -(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") -(defvar |$reportInstantiations| nil) -(defvar |$reportEachInstantiation| nil) -(defvar |$reportCounts| nil) -(defvar |$CategoryDefaults| nil) -(defvar |$compForModeIfTrue| nil "checked in compSymbol") -(defvar |$functorForm| nil "checked in addModemap0") -(defvar |$formalArgList| nil "checked in compSymbol") -(defvar |$newComp| nil "use new compiler") -(defvar |$newCompCompare| nil "compare new compiler with old") -(defvar |$compileOnlyCertainItems| nil "list of functions to compile") -(defvar |$newCompAtTopLevel| nil "if t uses new compiler") -(defvar |$doNotCompileJustPrint| nil "switch for compile") -(defvar |$PrintCompilerMessageIfTrue| t) -(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") -;; the following initialization of $ must not be a defvar -;; since that make $ special -(setq $ '$) ;; used in def of Ring which is Algebra($) -(defvar |$scanIfTrue| nil "if t continue compiling after errors") -(defvar |$Representation| nil "checked in compNoStacking") -(defvar |$definition| nil "checked in DomainSubstitutionFunction") -(defvar |$Attributes| nil "global attribute list used in JoinInner") -(defvar |$env| nil "checked in isDomainValuedVariable") -(defvar |$e| nil "checked in isDomainValuedVariable") -(defvar |$getPutTrace| nil) -(defvar |$specialCaseKeyList| nil "checked in optCall") -(defvar |$formulaFormat| nil "if true produce script formula output") -(defvar |$texFormat| nil "if true produce tex output") -(defvar |$fortranFormat| nil "if true produce fortran output") -(defvar |$algebraFormat| t "produce 2-d algebra output") -(defvar |$kernelWarn| NIL "") -(defvar |$kernelProtect| NIL "") -(defvar |$HiFiAccess| nil "if true maintain history file") -(defvar |$mapReturnTypes| nil) -(defvar /TRACENAMES NIL) - -(defvar INPUTSTREAM t "bogus initialization for now") - -(defvar |boot-NewKEY| NIL) -(setq /WSNAME 'NOBOOT) -(DEFVAR _ '&) -(defvar /EDIT-FM 'A1) -(defvar /EDIT-FT 'SPAD) -(defvar /RELEASE '"UNKNOWN") -(defvar /rp '/RP) -(defvar APLMODE NIL) -(defvar error-print) -(defvar ind) -(defvar INITCOLUMN 0) -(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) -(defvar LCTRUE '|true|) -(defvar m-chrbuffer) -(defvar m-chrindex) -(defvar MARG 0 "Margin for testing by ?OP") -(defvar NewFlag) -(defvar ParseMode) -(defvar RLGENSYMFG NIL) -(defvar RLGENSYMLST NIL) -(defvar S-SPADTOK 'SPADSYSTOK) -(defvar sortpred) -(defvar SPADSYSKEY '(EOI EOL)) -(defvar STAKCOLUMN -1) -(setq XTOKENREADER 'SPADTOK) -(defvar xtrans '|boot-new|) -(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) -(defvar |InteractiveMode|) -(defvar |NewFLAG| t) -(defvar |uc| 'UC) - -(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) - -(DEFUN /TRANSPAD (X) - (PROG (proplist) - (setq proplist (LIST '(FLUID . |true|) - (CONS '|special| - (COPY-TREE |$InitialDomainsInScope|)))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (COPY-TREE |$InitialModemapFrame|)))) - (RETURN (PROGN (S-PROCESS X) NIL)))) - - ;; NIL needed below since END\_UNIT is not generated by current parser - -(defun |traceComp| () - (SETQ |$compCount| 0) - (EMBED '|comp| - '(LAMBDA (X Y Z) - (PROG (U) - (SETQ |$compCount| (1+ |$compCount|)) - (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) - (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) - ('T '|no|))) - (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") - (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) - (SETQ |$compCount| (1- |$compCount|)) - (RETURN U) ))) - (|comp| $x $m $f) - (UNEMBED '|comp|)) - -(defun READ-SPAD (FN FM TO) - (LET ((proplist - (LIST '(FLUID . |true|) - (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) - (SETQ |$InteractiveFrame| - (|addBinding| '|$DomainsInScope| proplist - (|addBinding| '|$Information| NIL - (|makeInitialModemapFrame|)))) - (READ-SPAD0 FN 'SPAD FM TO))) - -(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) - -(defun READ-SPAD0 (FN FT FM TO) - (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) - -(defun READ-SPAD-1 () (|New,ENTRY,1|)) - -(defun UNCONS (X) - (COND ((ATOM X) X) - ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) - (T (ERROR "UNCONS")))) - -(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) - -(defun SPAD-PRINTTIME (A B) - (let (c msg) - (setq C (+ A B)) - (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) - " = " (STRINGIMAGE C) " MS.)")) - (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) - -(defun SPAD-MODETRAN (X) (D-TRAN X)) - -(defun SPAD-EVAL (X) - (COND ((ATOM X) (EVAL X)) - ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) - -;************************************************************************ -; SYSTEM COMMANDS -;************************************************************************ - -(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) - -(defun erase (FN FT) - (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) - -(defun READLISP (UPPER_CASE_FG) - (let (v expr val ) - (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) - (line-buffer CURRENT-LINE)) - t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) - (VMPRINT EXPR) - (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) - (FORMAT t "~&VALUE = ~S" VAL) - (TERSYSCOMMAND))) - -(defun TERSYSCOMMAND () - (FRESH-LINE) - (SETQ CHR 'ENDOFLINECHR) - (SETQ TOK 'END_UNIT) - (|spadThrow|)) - -(defun /READ (L Q) -; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) -; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) -; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) -; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) - (SETQ /EDITFILE L) - (COND - (Q (/RQ)) - ('T (/RF)) ) - (FLAG |boot-NewKEY| 'KEY) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /EDIT (L) - (SETQ /EDITFILE L) - (/EF) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun /COMPINTERP (L OPTS) - (SETQ /EDITFILE (/MKINFILENAM L)) - (COND ((EQUAL OPTS "rf") (/RF)) - ((EQUAL OPTS "rq") (/RQ)) - ('T (/RQ-LIB))) - (|terminateSystemCommand|) - (|spadPrompt|)) - -(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) - -(defun /FLAG (L) - (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) - (SAY (FIRST L) " has flags: " X) - (TERSYSCOMMAND)) - -(defun |fin| () - (SETQ *EOF* 'T) - (THROW 'SPAD_READER NIL)) - - -(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) - -(defun STREAM2UC (STRM) - (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) - -(defun NEWNAMTRANS (X) - (COND - ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) - ((STRINGP X) X) - ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) - ((ATOM X) X) - ((EQCAR X 'QUOTE)) - (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) - -(defun GP2COND (L) - (COND ((NOT L) (ERROR "GP2COND")) - ((NOT (CDR L)) - (COND ((EQCAR (FIRST L) 'COLON) - (CONS (SECOND L) (LIST (LIST T 'FAIL)))) - (T (LIST (LIST T (FIRST L)))) )) - ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) - (T (ERROR "GP2COND")))) - -(FLAG JUNKTOKLIST 'KEY) - -(defmacro |report| (L) - (SUBST (SECOND L) 'x - '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) - -(defmacro |DomainSubstitutionMacro| (&rest L) - (|DomainSubstitutionFunction| (first L) (second L))) - -(defun |sort| (seq spadfn) - (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) - -#-Lucid -(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) - -#+Lucid -(defun QUOTIENT2 (X Y) ; following to force error check in division by zero - (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) - -#-Lucid -(define-function 'REMAINDER2 #'REM) - -#+Lucid -(defun REMAINDER2 (X Y) - (if (zerop y) (REM 1 Y) (REM X Y))) - -#-Lucid -(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) - -#+Lucid -(defun DIVIDE2 (X Y) - (if (zerop y) (truncate 1 Y) - (multiple-value-call #'cons (TRUNCATE X Y)))) - -(defmacro APPEND2 (x y) `(append ,x ,y)) - -(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) - -(defun |makeSF| (mantissa exponent) - (|float| (/ mantissa (expt 2 (- exponent))))) - -(define-function 'list1 #'list) -(define-function '|not| #'NOT) - -(defun |random| () (random (expt 2 26))) -(defun \,plus (x y) (+ x y)) -(defun \,times (x y) (* x y)) -(defun \,difference (x y) (- x y)) -(defun \,max (x y) (max x y)) -(defun \,min (x y) (min x y)) -;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) -(defun |BooleanEquality| (x y) (if x y (null y))) - -(defun S-PROCESS (X) - (let ((|$Index| 0) - (*print-pretty* t) - ($MACROASSOC ()) - ($NEWSPAD T) - (|$compUniquelyIfTrue| nil) - |$currentFunction| - |$topOp| - (|$semanticErrorStack| ()) - (|$warningStack| ()) - (|$returnMode| |$EmptyMode|) - (|$leaveLevelStack| ()) - $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| - |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| - |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| - (|$e| |$EmptyEnvironment|) - (|$genSDVar| 0) - (|$VariableCount| 0) - (|$previousTime| (TEMPUS-FUGIT))) - (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) - (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) - (SETQ |$exitModeStack| ()) - (SETQ |$postStack| nil) - (SETQ |$TraceFlag| T) - (if (NOT X) (RETURN NIL)) - (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) - (|parseTransform| (|postTransform| X)))) - ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) - (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) - (COND (|$PrintOnly| - (format t "~S =====>~%" |$currentLine|) - (RETURN (PRETTYPRINT X)))) - (if (NOT $BOOT) - (if |$InteractiveMode| - (|processInteractive| X NIL) - (if (setq U (|compTopLevel| X |$EmptyMode| - |$InteractiveFrame|)) - (SETQ |$InteractiveFrame| (third U)))) - (DEF-PROCESS X)) - (if |$semanticErrorStack| (|displaySemanticErrors|)) - (TERPRI)))) - -(MAKEPROP 'END_UNIT 'KEY T) - -(defun |process| (x) - (COND ((NOT (EQ TOK 'END_UNIT)) - (SETQ DEBUGMODE 'NO) - (SPAD_SYNTAX_ERROR) - (if |$InteractiveMode| (|spadThrow|)) - (S-PROCESS x)))) - -(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) - -(setq *PROMPT* 'LISP) - -(defun |New,ENTRY,1| () - (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* - SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) - $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS - XTOKENREADER STACK STACKX TRAPFLAG) - (SETQ XTRANS '|boot-New| - XTOKENREADER 'NewSYSTOK - SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) - (FLAG |boot-NewKEY| 'KEY) - (SETQ *PROMPT* 'Scratchpad-II) - (PROMPT) - (SETQ XCAPE '_) - (SETQ COMMENTCHR 'IGNORE) - (SETQ COLUMN 0) - (SETQ SINGLINEMODE T) ; SEE NewSYSTOK - (SETQ NewFLAG T) - (SETQ ULCASEFG T) - (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) - (if (/= 0 (setq N (NOTE STR))) - (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) - ) - '|END_OF_New|)) - -(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) - (let (zz) - (INITIALIZE) - (SETQ $previousTime (TEMPUS-FUGIT)) - (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) - (REMFLAG |boot-NewKEY| 'KEY) - INPUTSTREAM)) - -(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) - -(setq *prompt* 'new) - -(defmacro try (X) - `(LET ((|$autoLine|)) - (declare (special |$autoLine|)) - (|tryToFit| (|saveState|) ,X))) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) - '((COMMENT |formatCOMMENT|) - (SEQ |formatSEQ|) - (DEF |formatDEF|) - (LET |formatLET|) - (\: |formatColon|) - (ELT |formatELT|) - (SEGMENT |formatSEGMENT|) - (COND |formatCOND|) - (SCOND |formatSCOND|) - (QUOTE |formatQUOTE|) - (CONS |formatCONS|) - (|where| |formatWHERE|) - (APPEND |formatAPPEND|) - (REPEAT |formatREPEAT|) - (COLLECT |formatCOLLECT|) - (REDUCE |formatREDUCE|))) - -(defmacro |incTimeSum| (a b) - (if (not |$InteractiveTimingStatsIfTrue|) a - (let ((key b) (oldkey (gensym)) (val (gensym))) - `(prog (,oldkey ,val) - (setq ,oldkey (|incrementTimeSum| ,key)) - (setq ,val ,a) - (|incrementTimeSum| ,oldkey) - (return ,val))))) - -(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) - -(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) - -(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) - -(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) - -(defmacro |rplac| (&rest L) - (let (a b s) - (cond - ((EQCAR (SETQ A (CAR L)) 'ELT) - (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) - (SETQ S "CA") - (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) - (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) - ((ERROR "rplac")))) - ((PROGN - (SETQ A (CARCDREXPAND (CAR L) NIL)) - (SETQ B (CADR L)) - (COND - ((CDDR L) (ERROR 'RPLAC)) - ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) - ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) - ((ERROR 'RPLAC)))))))) - -(DEFUN ASSOCIATER (FN LST) - (COND ((NULL LST) NIL) - ((NULL (CDR LST)) (CAR LST)) - ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) - -(defun ISLOCALOP-1 (IND) - "Curindex points at character after '.'" - (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) - (if (TERMINATOR NEWCHR) (RETURN NIL)) - (setq SELECTOR - (do ((x nil)) - (nil) - (if (terminator newchr) - (reverse x) - (push (setq newchr (nextcharacter)) x)))) - (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) - (setq BUF (GETSTR (LENGTH SELECTOR))) - (mapc #'(lambda (x) (suffix x buf)) selector) - (setq buf (copy-seq selector)) - (setq TERMTOK (INTERN BUF)) - (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) - (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) - (GET TERMTOK IND)) - (return TERMTOK))) -; **** X. Random tables - -(defvar MATBORCH "*") -(defvar $MARGIN 3) -(defvar $LINELENGTH 71) -(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) -(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) -(defvar LITTLEIN " in ") -(defvar INITALPHLIST ALPHLIST) -(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) -(defvar PORDLST (COPY-tree INITXPARLST)) -(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) -(defvar LITTLEA '|a|) -(defvar LITTLEI '|i|) -(defvar *TALLPAR NIL) -(defvar ALLSTAR NIL) -(defvar BLANK " ") -(defvar PLUSS "+") -(defvar PERIOD ".") -(defvar SLASH "/") -(defvar COMMA ",") -(defvar LPAR "(") -(defvar RPAR ")") -(defvar EQSIGN "=") -(defvar DASH "-") -(defvar STAR "*") -(defvar DOLLAR "$") -(defvar COLON ":") - -(FLAG TEMPGENSYMLIST 'IS-GENSYM) - -(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) -(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) -(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) -(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) -(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) -(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) -(MAKEPROP 'LET '|Led| '(:= LET 125 124)) -(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) -(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) - -;; NAME: DECIMAL-LENGTH -;; PURPOSE: Computes number of decimal digits in print representation of x -;; This should made as efficient as possible. - -(DEFUN DECIMAL-LENGTH (X) - (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) - (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) - (IF (LESSP X 10) K (1+ K)))) - -;(DEFUN DECIMAL-LENGTH2 (X) -; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) -; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) - - -;; function to create byte and half-word vectors in new runtime system 8/90 - -#-:CCL -(defun |makeByteWordVec| (initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec| (initialvalue) - (list-to-vector initialvalue)) - -#-:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) - (make-array (length initialvalue) - :element-type (list 'mod (1+ n)) - :initial-contents initialvalue))) - -#+:CCL -(defun |makeByteWordVec2| (maxelement initialvalue) - (list-to-vector initialvalue)) - -(defun |knownEqualPred| (dom) - (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) - (if fun (get (bpiname (car fun)) '|SPADreplace|) - nil))) - -(defun |hashable| (dom) - (memq (|knownEqualPred| dom) - #-Lucid '(EQ EQL EQUAL) - #+Lucid '(EQ EQL EQUAL EQUALP) - )) - -;; simpler interpface to RDEFIOSTREAM -(defun RDEFINSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) - -(defun RDEFOUTSTREAM (&rest fn) - ;; following line prevents rdefiostream from adding a default filetype - (if (null (rest fn)) (setq fn (list (pathname (car fn))))) - (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) - -(defmacro |spadConstant| (dollar n) - `(spadcall (svref ,dollar (the fixnum ,n)))) - - diff --git a/src/interp/spad.lisp.pamphlet b/src/interp/spad.lisp.pamphlet new file mode 100644 index 00000000..010aa043 --- /dev/null +++ b/src/interp/spad.lisp.pamphlet @@ -0,0 +1,626 @@ +%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. + +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/spad.lisp} Pamphlet} +\author{Timothy Daly} + +\begin{document} +\maketitle + +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ + +<<*>>= +<> + +; NAME: Scratchpad Package +; PURPOSE: This is an initialization and system-building file for Scratchpad. + +(IMPORT-MODULE "bootlex") +(in-package "BOOT") + +;;; Common Block + +(defvar |$preserveSystemLisplib| t "if nil finalizeLisplib does MA REP") +(defvar |$incrementalLisplibFlag| nil "checked in compDefineLisplib") +(defvar |$reportInstantiations| nil) +(defvar |$reportEachInstantiation| nil) +(defvar |$reportCounts| nil) +(defvar |$CategoryDefaults| nil) +(defvar |$compForModeIfTrue| nil "checked in compSymbol") +(defvar |$functorForm| nil "checked in addModemap0") +(defvar |$formalArgList| nil "checked in compSymbol") +(defvar |$newComp| nil "use new compiler") +(defvar |$newCompCompare| nil "compare new compiler with old") +(defvar |$compileOnlyCertainItems| nil "list of functions to compile") +(defvar |$newCompAtTopLevel| nil "if t uses new compiler") +(defvar |$doNotCompileJustPrint| nil "switch for compile") +(defvar |$PrintCompilerMessageIfTrue| t) +(defvar |$Rep| '|$Rep| "should be bound to gensym? checked in coerce") +;; the following initialization of $ must not be a defvar +;; since that make $ special +(setq $ '$) ;; used in def of Ring which is Algebra($) +(defvar |$scanIfTrue| nil "if t continue compiling after errors") +(defvar |$Representation| nil "checked in compNoStacking") +(defvar |$definition| nil "checked in DomainSubstitutionFunction") +(defvar |$Attributes| nil "global attribute list used in JoinInner") +(defvar |$env| nil "checked in isDomainValuedVariable") +(defvar |$e| nil "checked in isDomainValuedVariable") +(defvar |$getPutTrace| nil) +(defvar |$specialCaseKeyList| nil "checked in optCall") +(defvar |$formulaFormat| nil "if true produce script formula output") +(defvar |$texFormat| nil "if true produce tex output") +(defvar |$fortranFormat| nil "if true produce fortran output") +(defvar |$algebraFormat| t "produce 2-d algebra output") +(defvar |$kernelWarn| NIL "") +(defvar |$kernelProtect| NIL "") +(defvar |$HiFiAccess| nil "if true maintain history file") +(defvar |$mapReturnTypes| nil) +(defvar /TRACENAMES NIL) + +(defvar INPUTSTREAM t "bogus initialization for now") + +(defvar |boot-NewKEY| NIL) +(setq /WSNAME 'NOBOOT) +(DEFVAR _ '&) +(defvar /EDIT-FM 'A1) +(defvar /EDIT-FT 'SPAD) +(defvar /RELEASE '"UNKNOWN") +(defvar /rp '/RP) +(defvar APLMODE NIL) +(defvar error-print) +(defvar ind) +(defvar INITCOLUMN 0) +(defvar JUNKTOKLIST '(FOR IN AS INTO OF TO)) +(defvar LCTRUE '|true|) +(defvar m-chrbuffer) +(defvar m-chrindex) +(defvar MARG 0 "Margin for testing by ?OP") +(defvar NewFlag) +(defvar ParseMode) +(defvar RLGENSYMFG NIL) +(defvar RLGENSYMLST NIL) +(defvar S-SPADTOK 'SPADSYSTOK) +(defvar sortpred) +(defvar SPADSYSKEY '(EOI EOL)) +(defvar STAKCOLUMN -1) +(setq XTOKENREADER 'SPADTOK) +(defvar xtrans '|boot-new|) +(defvar |$IOAlist| '((|%i| . (|gauss| 0 1)))) +(defvar |InteractiveMode|) +(defvar |NewFLAG| t) +(defvar |uc| 'UC) + +(DEFUN INTEGER-BIT (N I) (LOGBITP I N)) + +(DEFUN /TRANSPAD (X) + (PROG (proplist) + (setq proplist (LIST '(FLUID . |true|) + (CONS '|special| + (COPY-TREE |$InitialDomainsInScope|)))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (COPY-TREE |$InitialModemapFrame|)))) + (RETURN (PROGN (S-PROCESS X) NIL)))) + + ;; NIL needed below since END\_UNIT is not generated by current parser + +(defun |traceComp| () + (SETQ |$compCount| 0) + (EMBED '|comp| + '(LAMBDA (X Y Z) + (PROG (U) + (SETQ |$compCount| (1+ |$compCount|)) + (SETQ |yesOrNo| (if (SETQ U (|comp| X Y Z)) + (if (EQUAL (SECOND U) Y) '|yes| (SECOND U)) + ('T '|no|))) + (|sayBrightly| (CONS (MAKE-FULL-CVEC |$compCount| " ") + (LIST X " --> " Y '|%b| |yesOrNo| '|%d|))) + (SETQ |$compCount| (1- |$compCount|)) + (RETURN U) ))) + (|comp| $x $m $f) + (UNEMBED '|comp|)) + +(defun READ-SPAD (FN FM TO) + (LET ((proplist + (LIST '(FLUID . |true|) + (CONS '|special| (COPY-TREE |$InitialDomainsInScope|))))) + (SETQ |$InteractiveFrame| + (|addBinding| '|$DomainsInScope| proplist + (|addBinding| '|$Information| NIL + (|makeInitialModemapFrame|)))) + (READ-SPAD0 FN 'SPAD FM TO))) + +(defun READ-INPUT (FN FM TO) (READ-SPAD0 FN 'INPUT FM TO)) + +(defun READ-SPAD0 (FN FT FM TO) + (let (($newspad t)) (READ-SPAD1 FN FT FM TO))) + +(defun READ-SPAD-1 () (|New,ENTRY,1|)) + +(defun UNCONS (X) + (COND ((ATOM X) X) + ((EQCAR X 'CONS) (CONS (SECOND X) (UNCONS (THIRD X)))) + (T (ERROR "UNCONS")))) + +(defun OPTIMIZE\&PRINT (X) (PRETTYPRINT (/MDEF X))) + +(defun SPAD-PRINTTIME (A B) + (let (c msg) + (setq C (+ A B)) + (setq MSG (STRCONC "(" (STRINGIMAGE A) " + " (STRINGIMAGE B) + " = " (STRINGIMAGE C) " MS.)")) + (PRINT (STRCONC (STRINGPAD "" (DIFFERENCE 80 (SIZE MSG))) MSG)))) + +(defun SPAD-MODETRAN (X) (D-TRAN X)) + +(defun SPAD-EVAL (X) + (COND ((ATOM X) (EVAL X)) + ((CONS (FIRST X) (MAPCAR #'SPAD-EVAL (CDR X)))))) + +;************************************************************************ +; SYSTEM COMMANDS +;************************************************************************ + +(defun CLEARDATABASE () (OBEY "ERASE MODEMAP DATABASE")) + +(defun erase (FN FT) + (OBEY (STRCONC "ERASE " (STRINGIMAGE FN) " " (STRINGIMAGE FT)))) + +(defun READLISP (UPPER_CASE_FG) + (let (v expr val ) + (setq EXPR (READ-FROM-STRING + (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) + (line-buffer CURRENT-LINE)) + t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) + (VMPRINT EXPR) + (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) + (FORMAT t "~&VALUE = ~S" VAL) + (TERSYSCOMMAND))) + +(defun TERSYSCOMMAND () + (FRESH-LINE) + (SETQ CHR 'ENDOFLINECHR) + (SETQ TOK 'END_UNIT) + (|spadThrow|)) + +(defun /READ (L Q) +; (SETQ /EDIT-FN (OR (KAR L) /EDIT-FN)) +; (SETQ /EDIT-FT (OR (KAR (KDR L)) 'INPUT)) +; (SETQ /EDIT-FM (OR (KAR (KDR (KDR L))) '*)) +; (SETQ /EDITFILE (LIST /EDIT-FN /EDIT-FT /EDIT-FM)) + (SETQ /EDITFILE L) + (COND + (Q (/RQ)) + ('T (/RF)) ) + (FLAG |boot-NewKEY| 'KEY) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /EDIT (L) + (SETQ /EDITFILE L) + (/EF) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun /COMPINTERP (L OPTS) + (SETQ /EDITFILE (/MKINFILENAM L)) + (COND ((EQUAL OPTS "rf") (/RF)) + ((EQUAL OPTS "rq") (/RQ)) + ('T (/RQ-LIB))) + (|terminateSystemCommand|) + (|spadPrompt|)) + +(defun CPSAY (X) (let (n) (if (EQ 0 (setq N (OBEY X))) NIL (PRINT N)))) + +(defun /FLAG (L) + (MAKEPROP (FIRST L) 'FLAGS (LET ((X (UNION (CDR L)))) (GET (FIRST L) 'FLAGS))) + (SAY (FIRST L) " has flags: " X) + (TERSYSCOMMAND)) + +(defun |fin| () + (SETQ *EOF* 'T) + (THROW 'SPAD_READER NIL)) + + +(defun STRINGREST (X) (if (EQ (SIZE X) 1) (make-string 0) (SUBSTRING X 1 NIL))) + +(defun STREAM2UC (STRM) + (LET ((X (ELT (LASTATOM STRM) 1))) (SETELT X 0 (LC2UC (ELT X 0))))) + +(defun NEWNAMTRANS (X) + (COND + ((IDENTP X) (COND ( (GET X 'NEWNAM) (GET X 'NEWNAM)) ('T X))) + ((STRINGP X) X) + ((*VECP X) (MAPVWOC X (FUNCTION NEWNAMTRANS))) + ((ATOM X) X) + ((EQCAR X 'QUOTE)) + (T (CONS (NEWNAMTRANS (FIRST X)) (NEWNAMTRANS (CDR X)))))) + +(defun GP2COND (L) + (COND ((NOT L) (ERROR "GP2COND")) + ((NOT (CDR L)) + (COND ((EQCAR (FIRST L) 'COLON) + (CONS (SECOND L) (LIST (LIST T 'FAIL)))) + (T (LIST (LIST T (FIRST L)))) )) + ((EQCAR (FIRST L) 'COLON) (CONS (CDAR L) (GP2COND (CDR L)))) + (T (ERROR "GP2COND")))) + +(FLAG JUNKTOKLIST 'KEY) + +(defmacro |report| (L) + (SUBST (SECOND L) 'x + '(COND ($reportFlag (sayBrightly x)) ((QUOTE T) NIL)))) + +(defmacro |DomainSubstitutionMacro| (&rest L) + (|DomainSubstitutionFunction| (first L) (second L))) + +(defun |sort| (seq spadfn) + (sort (copy-seq seq) (function (lambda (x y) (SPADCALL X Y SPADFN))))) + +#-Lucid +(defun QUOTIENT2 (X Y) (values (TRUNCATE X Y))) + +#+Lucid +(defun QUOTIENT2 (X Y) ; following to force error check in division by zero + (values (if (zerop y) (truncate 1 Y) (TRUNCATE X Y)))) + +#-Lucid +(define-function 'REMAINDER2 #'REM) + +#+Lucid +(defun REMAINDER2 (X Y) + (if (zerop y) (REM 1 Y) (REM X Y))) + +#-Lucid +(defun DIVIDE2 (X Y) (multiple-value-call #'cons (TRUNCATE X Y))) + +#+Lucid +(defun DIVIDE2 (X Y) + (if (zerop y) (truncate 1 Y) + (multiple-value-call #'cons (TRUNCATE X Y)))) + +(defmacro APPEND2 (x y) `(append ,x ,y)) + +(defmacro |float| (x &optional (y 0.0d0)) `(float ,x ,y)) + +(defun |makeSF| (mantissa exponent) + (|float| (/ mantissa (expt 2 (- exponent))))) + +(define-function 'list1 #'list) +(define-function '|not| #'NOT) + +(defun |random| () (random (expt 2 26))) +(defun \,plus (x y) (+ x y)) +(defun \,times (x y) (* x y)) +(defun \,difference (x y) (- x y)) +(defun \,max (x y) (max x y)) +(defun \,min (x y) (min x y)) +;; This is used in the domain Boolean (BOOLEAN.NRLIB/code.lsp) +(defun |BooleanEquality| (x y) (if x y (null y))) + +(defun S-PROCESS (X) + (let ((|$Index| 0) + (*print-pretty* t) + ($MACROASSOC ()) + ($NEWSPAD T) + (|$compUniquelyIfTrue| nil) + |$currentFunction| + |$topOp| + (|$semanticErrorStack| ()) + (|$warningStack| ()) + (|$returnMode| |$EmptyMode|) + (|$leaveLevelStack| ()) + $TOP_LEVEL |$insideFunctorIfTrue| |$insideExpressionIfTrue| + |$insideCoerceInteractiveHardIfTrue| |$insideWhereIfTrue| + |$insideCategoryIfTrue| |$insideCapsuleFunctionIfTrue| |$form| + (|$e| |$EmptyEnvironment|) + (|$genSDVar| 0) + (|$VariableCount| 0) + (|$previousTime| (TEMPUS-FUGIT))) + (prog ((CURSTRM CUROUTSTREAM) |$s| |$x| |$m| u) + (declare (special CURSTRM |$s| |$x| |$m| CUROUTSTREAM)) + (SETQ |$exitModeStack| ()) + (SETQ |$postStack| nil) + (SETQ |$TraceFlag| T) + (if (NOT X) (RETURN NIL)) + (setq X (if $BOOT (DEF-RENAME (|new2OldLisp| X)) + (|parseTransform| (|postTransform| X)))) + ;; (if |$TranslateOnly| (RETURN (SETQ |$Translation| X))) + (when |$postStack| (|displayPreCompilationErrors|) (RETURN NIL)) + (COND (|$PrintOnly| + (format t "~S =====>~%" |$currentLine|) + (RETURN (PRETTYPRINT X)))) + (if (NOT $BOOT) + (if |$InteractiveMode| + (|processInteractive| X NIL) + (if (setq U (|compTopLevel| X |$EmptyMode| + |$InteractiveFrame|)) + (SETQ |$InteractiveFrame| (third U)))) + (DEF-PROCESS X)) + (if |$semanticErrorStack| (|displaySemanticErrors|)) + (TERPRI)))) + +(MAKEPROP 'END_UNIT 'KEY T) + +(defun |process| (x) + (COND ((NOT (EQ TOK 'END_UNIT)) + (SETQ DEBUGMODE 'NO) + (SPAD_SYNTAX_ERROR) + (if |$InteractiveMode| (|spadThrow|)) + (S-PROCESS x)))) + +(defun |evalSharpOne| (x \#1) (declare (special \#1)) (EVAL x)) + +(setq *PROMPT* 'LISP) + +(defun |New,ENTRY,1| () + (let (ZZ str N RLGENSYMFG RLGENSYMLST |NewFLAG| XCAPE *PROMPT* + SINGLELINEMODE OK ISID NBLNK COUNT CHR ULCASEFG ($LINESTACK 'BEGIN_UNIT) + $TOKSTACK COMMENTCHR TOK LINE BACK INPUTSTREAM XTRANS + XTOKENREADER STACK STACKX TRAPFLAG) + (SETQ XTRANS '|boot-New| + XTOKENREADER 'NewSYSTOK + SYNTAX_ERROR 'SPAD_SYNTAX_ERROR) + (FLAG |boot-NewKEY| 'KEY) + (SETQ *PROMPT* 'Scratchpad-II) + (PROMPT) + (SETQ XCAPE '_) + (SETQ COMMENTCHR 'IGNORE) + (SETQ COLUMN 0) + (SETQ SINGLINEMODE T) ; SEE NewSYSTOK + (SETQ NewFLAG T) + (SETQ ULCASEFG T) + (setq STR (|New,ENTRY,2| '|PARSE-NewEXPR| '|process| curinstream)) + (if (/= 0 (setq N (NOTE STR))) + (progn (SETQ CURINSTREAM (POINTW N CURINSTREAM))) + ) + '|END_OF_New|)) + +(defun |New,ENTRY,2| (RULE FN INPUTSTREAM) (declare (special INPUTSTREAM)) + (let (zz) + (INITIALIZE) + (SETQ $previousTime (TEMPUS-FUGIT)) + (setq ZZ (CONVERSATION '|PARSE-NewExpr| '|process|)) + (REMFLAG |boot-NewKEY| 'KEY) + INPUTSTREAM)) + +(defun INITIALIZE () (init-boot/spad-reader) (initialize-preparse INPUTSTREAM)) + +(setq *prompt* 'new) + +(defmacro try (X) + `(LET ((|$autoLine|)) + (declare (special |$autoLine|)) + (|tryToFit| (|saveState|) ,X))) + +(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'format (CADR X))) + '((COMMENT |formatCOMMENT|) + (SEQ |formatSEQ|) + (DEF |formatDEF|) + (LET |formatLET|) + (\: |formatColon|) + (ELT |formatELT|) + (SEGMENT |formatSEGMENT|) + (COND |formatCOND|) + (SCOND |formatSCOND|) + (QUOTE |formatQUOTE|) + (CONS |formatCONS|) + (|where| |formatWHERE|) + (APPEND |formatAPPEND|) + (REPEAT |formatREPEAT|) + (COLLECT |formatCOLLECT|) + (REDUCE |formatREDUCE|))) + +(defmacro |incTimeSum| (a b) + (if (not |$InteractiveTimingStatsIfTrue|) a + (let ((key b) (oldkey (gensym)) (val (gensym))) + `(prog (,oldkey ,val) + (setq ,oldkey (|incrementTimeSum| ,key)) + (setq ,val ,a) + (|incrementTimeSum| ,oldkey) + (return ,val))))) + +(defun GLESSEQP (X Y) (NOT (GGREATERP X Y))) + +(defun LEXLESSEQP (X Y) (NOT (LEXGREATERP X Y))) + +(defun SETELTFIRST (A B C) (declare (ignore b)) (RPLACA A C)) + +(defun SETELTREST (A B C) (declare (ignore b)) (RPLACD A C)) + +(defmacro |rplac| (&rest L) + (let (a b s) + (cond + ((EQCAR (SETQ A (CAR L)) 'ELT) + (COND ((AND (INTEGERP (SETQ B (CADDR A))) (>= B 0)) + (SETQ S "CA") + (do ((i 1 (1+ i))) ((> i b)) (SETQ S (STRCONC S "D"))) + (LIST 'RPLAC (LIST (INTERN (STRCONC S "R")) (CADR A)) (CADR L))) + ((ERROR "rplac")))) + ((PROGN + (SETQ A (CARCDREXPAND (CAR L) NIL)) + (SETQ B (CADR L)) + (COND + ((CDDR L) (ERROR 'RPLAC)) + ((EQCAR A 'CAR) (LIST 'RPLACA (CADR A) B)) + ((EQCAR A 'CDR) (LIST 'RPLACD (CADR A) B)) + ((ERROR 'RPLAC)))))))) + +(DEFUN ASSOCIATER (FN LST) + (COND ((NULL LST) NIL) + ((NULL (CDR LST)) (CAR LST)) + ((LIST FN (CAR LST) (ASSOCIATER FN (CDR LST)))))) + +(defun ISLOCALOP-1 (IND) + "Curindex points at character after '.'" + (prog (selector buf termtok (NEWCHR (NEXTCHARACTER))) + (if (TERMINATOR NEWCHR) (RETURN NIL)) + (setq SELECTOR + (do ((x nil)) + (nil) + (if (terminator newchr) + (reverse x) + (push (setq newchr (nextcharacter)) x)))) + (if (EQUAL NEWCHR '\.) (RETURN (ISLOCALOP-1 IND))) + (setq BUF (GETSTR (LENGTH SELECTOR))) + (mapc #'(lambda (x) (suffix x buf)) selector) + (setq buf (copy-seq selector)) + (setq TERMTOK (INTERN BUF)) + (if (NOT (GET TERMTOK 'GENERIC)) (RETURN NIL)) + (if (OR (GET TERMTOK '|Led|) (GET TERMTOK '|Nud|)) + (GET TERMTOK IND)) + (return TERMTOK))) +; **** X. Random tables + +(defvar MATBORCH "*") +(defvar $MARGIN 3) +(defvar $LINELENGTH 71) +(defvar TEMPGENSYMLIST '(|s| |r| |q| |p|)) +(defvar ALPHLIST '(|a| |b| |c| |d| |e| |f| |g|)) +(defvar LITTLEIN " in ") +(defvar INITALPHLIST ALPHLIST) +(defvar INITXPARLST '(|i| |j| |k| |l| |m| |n| |p| |q|)) +(defvar PORDLST (COPY-tree INITXPARLST)) +(defvar INITPARLST '(|x| |y| |z| |u| |v| |w| |r| |s| |t|)) +(defvar LITTLEA '|a|) +(defvar LITTLEI '|i|) +(defvar *TALLPAR NIL) +(defvar ALLSTAR NIL) +(defvar BLANK " ") +(defvar PLUSS "+") +(defvar PERIOD ".") +(defvar SLASH "/") +(defvar COMMA ",") +(defvar LPAR "(") +(defvar RPAR ")") +(defvar EQSIGN "=") +(defvar DASH "-") +(defvar STAR "*") +(defvar DOLLAR "$") +(defvar COLON ":") + +(FLAG TEMPGENSYMLIST 'IS-GENSYM) + +(MAKEPROP 'COND '|Nud| '(|if| |if| 130 0)) +(MAKEPROP 'CONS '|Led| '(CONS CONS 1000 1000)) +(MAKEPROP 'APPEND '|Led| '(APPEND APPEND 1000 1000)) +(MAKEPROP 'TAG '|Led| '(TAG TAG 122 121)) +(MAKEPROP 'EQUATNUM '|Nud| '(|dummy| |dummy| 0 0)) +(MAKEPROP 'EQUATNUM '|Led| '(|dummy| |dummy| 10000 0)) +(MAKEPROP 'LET '|Led| '(:= LET 125 124)) +(MAKEPROP 'RARROW '|Led| '(== DEF 122 121)) +(MAKEPROP 'SEGMENT '|Led| '(\.\. SEGMENT 401 699 (|boot-Seg|))) + +;; NAME: DECIMAL-LENGTH +;; PURPOSE: Computes number of decimal digits in print representation of x +;; This should made as efficient as possible. + +(DEFUN DECIMAL-LENGTH (X) + (LET* ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X)))) + (X (TRUNCATE (ABS X) (EXPT 10 (1- K))))) + (IF (LESSP X 10) K (1+ K)))) + +;(DEFUN DECIMAL-LENGTH2 (X) +; (LET ((K (FIX (* #.(LOG 2.0 10.) (INTEGER-LENGTH X))))) +; (IF (< (ABS X) (EXPT 10 K)) K (1+ K)))) + + +;; function to create byte and half-word vectors in new runtime system 8/90 + +#-:CCL +(defun |makeByteWordVec| (initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t (reduce #'max initialvalue))))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec| (initialvalue) + (list-to-vector initialvalue)) + +#-:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (let ((n (cond ((null initialvalue) 7) ('t maxelement)))) + (make-array (length initialvalue) + :element-type (list 'mod (1+ n)) + :initial-contents initialvalue))) + +#+:CCL +(defun |makeByteWordVec2| (maxelement initialvalue) + (list-to-vector initialvalue)) + +(defun |knownEqualPred| (dom) + (let ((fun (|compiledLookup| '= '((|Boolean|) $ $) dom))) + (if fun (get (bpiname (car fun)) '|SPADreplace|) + nil))) + +(defun |hashable| (dom) + (memq (|knownEqualPred| dom) + #-Lucid '(EQ EQL EQUAL) + #+Lucid '(EQ EQL EQUAL EQUALP) + )) + +;; simpler interpface to RDEFIOSTREAM +(defun RDEFINSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . INPUT)))) + +(defun RDEFOUTSTREAM (&rest fn) + ;; following line prevents rdefiostream from adding a default filetype + (if (null (rest fn)) (setq fn (list (pathname (car fn))))) + (rdefiostream (list (cons 'FILE fn) '(mode . OUTPUT)))) + +(defmacro |spadConstant| (dollar n) + `(spadcall (svref ,dollar (the fixnum ,n)))) + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/spaderror.lisp b/src/interp/spaderror.lisp deleted file mode 100644 index da5bd161..00000000 --- a/src/interp/spaderror.lisp +++ /dev/null @@ -1,113 +0,0 @@ -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -;; this files contains basic routines for error handling -(in-package "BOOT") - -(defun error-format (message args) - (let ((|$BreakMode| '|break|)) - (declare (special |$BreakMode|)) - (if (stringp message) (apply #'format nil message args) nil))) - -;;(defmacro |trappedSpadEval| (form) form) ;;nop for now - -#+:akcl -(setq |$quitTag| system::*quit-tag*) -#+:akcl -(defun |resetStackLimits| () (system:reset-stack-limits)) -#-:akcl -(setq |$quitTag| (gensym)) -#-:akcl -(defun |resetStackLimits| () nil) - -;; failed union branch -- value returned for numeric failure -(setq |$numericFailure| (cons 1 "failed")) - -(defvar |$oldBreakMode|) - -;; following macro evaluates form returning Union(type-of form, "failed") - -(defmacro |trapNumericErrors| (form) - `(let ((|$oldBreakMode| |$BreakMode|) - (|$BreakMode| '|trapNumerics|) - (val)) - (setq val (catch '|trapNumerics| ,form)) - (if (eq val |$numericFailure|) val - (cons 0 val)))) - -;;;;;; considering this version for kcl -;;(defmacro |trapNumericErrors| (form) -;; `(let ((val)) -;; (setq val (errorset ,form)) -;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) - -;; the following form embeds around the akcl error handler -#+:akcl -(eval-when - (load eval) - (unembed 'system:universal-error-handler) - (embed 'system:universal-error-handler - '(lambda (type correctable? op - continue-string error-string &rest args) - (block - nil - (setq |$NeedToSignalSessionManager| T) - (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) - (cond ((eq |$BreakMode| '|validate|) - (|systemError| (error-format error-string args))) - ((and (eq |$BreakMode| '|trapNumerics|) - (eq type :ERROR)) - (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) - ((and (eq |$BreakMode| '|trapNumerics|) - (boundp '|$oldBreakMode|) - (setq |$BreakMode| |$oldBreakMode|) - nil)) ;; resets error handler - ((and (null |$inLispVM|) - (memq |$BreakMode| '(|nobreak| |query| |resume|))) - (let ((|$inLispVM| T)) ;; turn off handler - (return - (|systemError| (error-format error-string args))))) - ((eq |$BreakMode| '|letPrint2|) - (setq |$BreakMode| nil) - (throw '|letPrint2| nil)))) - (apply system:universal-error-handler type correctable? op - continue-string error-string args ))))) - - - - - - - - - - diff --git a/src/interp/spaderror.lisp.pamphlet b/src/interp/spaderror.lisp.pamphlet new file mode 100644 index 00000000..618a94e4 --- /dev/null +++ b/src/interp/spaderror.lisp.pamphlet @@ -0,0 +1,141 @@ +%% Oh Emacs, this is a -*- Lisp -*- file despite apperance. +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/spaderroor.lisp} Pamphlet} +\author{Timothy Daly} + +\begin{document} +\maketitle + +\begin{abstract} +\end{abstract} + +\tableofcontents +\eject + +\section{License} + +<>= +;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are +;; met: +;; +;; - Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; +;; - Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the +;; names of its contributors may be used to endorse or promote products +;; derived from this software without specific prior written permission. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +;; this files contains basic routines for error handling +(in-package "BOOT") + +(defun error-format (message args) + (let ((|$BreakMode| '|break|)) + (declare (special |$BreakMode|)) + (if (stringp message) (apply #'format nil message args) nil))) + +;;(defmacro |trappedSpadEval| (form) form) ;;nop for now + +#+:akcl +(setq |$quitTag| system::*quit-tag*) +#+:akcl +(defun |resetStackLimits| () (system:reset-stack-limits)) +#-:akcl +(setq |$quitTag| (gensym)) +#-:akcl +(defun |resetStackLimits| () nil) + +;; failed union branch -- value returned for numeric failure +(setq |$numericFailure| (cons 1 "failed")) + +(defvar |$oldBreakMode|) + +;; following macro evaluates form returning Union(type-of form, "failed") + +(defmacro |trapNumericErrors| (form) + `(let ((|$oldBreakMode| |$BreakMode|) + (|$BreakMode| '|trapNumerics|) + (val)) + (setq val (catch '|trapNumerics| ,form)) + (if (eq val |$numericFailure|) val + (cons 0 val)))) + +;;;;;; considering this version for kcl +;;(defmacro |trapNumericErrors| (form) +;; `(let ((val)) +;; (setq val (errorset ,form)) +;; (if (NULL val) |$numericFailure| (cons 0 (car val))))) + +;; the following form embeds around the akcl error handler +#+:akcl +(eval-when + (load eval) + (unembed 'system:universal-error-handler) + (embed 'system:universal-error-handler + '(lambda (type correctable? op + continue-string error-string &rest args) + (block + nil + (setq |$NeedToSignalSessionManager| T) + (if (and (boundp '|$inLispVM|) (boundp '|$BreakMode|)) + (cond ((eq |$BreakMode| '|validate|) + (|systemError| (error-format error-string args))) + ((and (eq |$BreakMode| '|trapNumerics|) + (eq type :ERROR)) + (setq |$BreakMode| nil) (throw '|trapNumerics| |$numericFailure|)) + ((and (eq |$BreakMode| '|trapNumerics|) + (boundp '|$oldBreakMode|) + (setq |$BreakMode| |$oldBreakMode|) + nil)) ;; resets error handler + ((and (null |$inLispVM|) + (memq |$BreakMode| '(|nobreak| |query| |resume|))) + (let ((|$inLispVM| T)) ;; turn off handler + (return + (|systemError| (error-format error-string args))))) + ((eq |$BreakMode| '|letPrint2|) + (setq |$BreakMode| nil) + (throw '|letPrint2| nil)))) + (apply system:universal-error-handler type correctable? op + continue-string error-string args ))))) + + + + + + + + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/topics.boot b/src/interp/topics.boot index 18e06e35..32a7d7bf 100644 --- a/src/interp/topics.boot +++ b/src/interp/topics.boot @@ -29,9 +29,10 @@ -- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +)package "BOOT" $topicsDefaults := '( - (basic elt setelt qelt qsetelt eval xRange yRange zRange map map! qsetelt!) + (basic elt setelt qelt qsetelt eval xRange yRange zRange map map_! qsetelt_!) (conversion coerce convert retract) (hidden retractIfCan Zero One) (predicate _< _=) @@ -40,7 +41,7 @@ $topicsDefaults := '( (hyperbolic acosh acoth acsch asech asinh atanh cosh coth csch sech sinh tanh) (destructive setelt qsetelt) (extraction xRange yRange zRange elt qelt) - (transformation map map!)) + (transformation map map_!)) $topicSynonyms := '( (b . basic) @@ -138,7 +139,7 @@ skipBlanks(u,i,m) == -- Compute Topic Code for Operation --======================================================================= topicCode lst == - u := [y for x in lst] where y == + u := [y for x in lst] where y() == rename := LASSOC(x,$topicSynonyms) => rename x if null intersection('(basic extended hidden),u) then u := ['extended,:u] @@ -156,7 +157,7 @@ topicCode lst == --called to modify DOCUMENTATION property for each "con" addTopic2Documentation(con,docAlist) == alist := HGET($conTopicHash,con) or return docAlist - [y for x in docAlist] where y == + [y for x in docAlist] where y() == [op,:pairlist] := x code := LASSOC(op,alist) or 0 for sigDoc in pairlist repeat diff --git a/src/interp/topics.boot.pamphlet b/src/interp/topics.boot.pamphlet new file mode 100644 index 00000000..a269b18c --- /dev/null +++ b/src/interp/topics.boot.pamphlet @@ -0,0 +1,263 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/topics.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +$topicsDefaults := '( + (basic elt setelt qelt qsetelt eval xRange yRange zRange map map! qsetelt!) + (conversion coerce convert retract) + (hidden retractIfCan Zero One) + (predicate _< _=) + (algebraic _+ _- _* _*_* _/ quo rem exquo) + (trignometric acos acot acsc asec asin atan cos cot csc sec sin tan) + (hyperbolic acosh acoth acsch asech asinh atanh cosh coth csch sech sinh tanh) + (destructive setelt qsetelt) + (extraction xRange yRange zRange elt qelt) + (transformation map map!)) + +$topicSynonyms := '( + (b . basic) + (h . hidden) + (e . extended) + (a . algebraic) + (g . algebraic) + (c . construct) + (d . destructive) + (v . conversion) + (m . miscellaneous) + (x . extraction) + (p . predicate) + (tg . trignometric) + (hy . hyperbolic) + (t . transformation)) + +$groupAssoc := '((extended . 1) (basic . 2) (hidden . 4)) + +--======================================================================= +-- Create Hashtable of Operation Properties +--======================================================================= +--called at build-time before making DOCUMENTATION property +mkTopicHashTable() == --given $groupAssoc = ((extended . 1)(basic . 2)(xx . 4)..) + $defaultsHash := MAKE_-HASHTABLE 'ID --keys are ops, value is list of topic names + for [kind,:items] in $topicsDefaults repeat --$topicsDefaults is (( op ...) ..) + for item in items repeat + HPUT($defaultsHash,item,[kind,:HGET($defaultsHash,item)]) + $conTopicHash := MAKE_-HASHTABLE 'EQL --key is constructor name; value is + instream := OPEN '"topics.data" + while not EOFP instream repeat + line := READLINE instream + while blankLine? line repeat line := READLINE instream + m := MAXINDEX line --file "topics.data" has form: + m = -1 => 'skip --1 ConstructorName: + line.0 = char '_- => 'skip --2 constructorName or operation name + line := trimString line --3-n ... + m := MAXINDEX line -- (blank line) ... + line.m ^= (char '_:) => systemError('"wrong heading") + con := INTERN SUBSTRING(line,0,m) + alist := [lst while not EOFP instream and + not (blankLine? (line := READLINE instream)) and + line.0 ^= char '_- for i in 1.. + | lst := string2OpAlist line] + alist => HPUT($conTopicHash,con,alist) + --initialize table of topic classes + $topicHash := MAKE_-HASHTABLE 'ID --$topicHash has keys: topic and value: index + for [x,:c] in $groupAssoc repeat HPUT($topicHash,x,c) + $topicIndex := CDR LAST $groupAssoc + + --replace each property list by a topic code + --store under each construct an OR of all codes + for con in HKEYS $conTopicHash repeat + conCode := 0 + for pair in HGET($conTopicHash,con) repeat + RPLACD(pair,code := topicCode CDR pair) + conCode := LOGIOR(conCode,code) + HPUT($conTopicHash,con, + [['constructor,:conCode],:HGET($conTopicHash,con)]) + SHUT instream + +--reduce integers stored under names to 1 + its power of 2 + for key in HKEYS $topicHash repeat + HPUT($topicHash,key,INTEGER_-LENGTH HGET($topicHash,key)) + + $conTopicHash --keys are ops or 'constructor', values are codes + +blankLine? line == + MAXINDEX line = -1 or and/[line . j = (char '_ ) for j in 0..MAXINDEX line] + +string2OpAlist s == + m := #s + k := skipBlanks(s,0,m) or return nil + UPPER_-CASE_-P s.k => nil --skip constructor names + k := 0 + while (k := skipBlanks(s,k,m)) repeat + acc := [INTERN SUBSTRING(s,k,-k + (k := charPosition(char '_ ,s,k + 1))),:acc] + acc := NREVERSE acc + --now add defaults + if u := getDefaultProps first acc then acc := [first acc,:u,:rest acc] + acc + +getDefaultProps name == + u := HGET($defaultsHash,name) + if (s := PNAME name).(m := MAXINDEX s) = char '? then u := ['p,:u] + if s.m = char '_! then u := ['destructive,:u] + u + +skipBlanks(u,i,m) == + while i < m and u.i = $charBlank repeat i := i + 1 + i >= m => nil + i + +--======================================================================= +-- Compute Topic Code for Operation +--======================================================================= +topicCode lst == + u := [y for x in lst] where y == + rename := LASSOC(x,$topicSynonyms) => rename + x + if null intersection('(basic extended hidden),u) then u := ['extended,:u] + bitIndexList := nil + for x in REMDUP u repeat + bitIndexList := [fn x,:bitIndexList] where fn x == + k := HGET($topicHash,x) => k + HPUT($topicHash,x,$topicIndex := $topicIndex * 2) + $topicIndex + code := +/[i for i in bitIndexList] + +--======================================================================= +-- Add Codes to Documentation Property +--======================================================================= +--called to modify DOCUMENTATION property for each "con" +addTopic2Documentation(con,docAlist) == + alist := HGET($conTopicHash,con) or return docAlist + [y for x in docAlist] where y == + [op,:pairlist] := x + code := LASSOC(op,alist) or 0 + for sigDoc in pairlist repeat + sigDoc is [.,.] => RPLACD(rest sigDoc,code) + systemError sigDoc + docAlist + +--======================================================================= +-- Test: Display Topics for a given constructor +--======================================================================= +td con == + $topicClasses := ASSOCRIGHT mySort + [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] + hash := MAKE_-HASHTABLE 'ID + tdAdd(con,hash) + tdPrint hash + +tdAdd(con,hash) == + v := HGET($conTopicHash,con) + u := addTopic2Documentation(con,v) +--u := GETDATABASE(con,'DOCUMENTATION) + for pair in u | FIXP (code := myLastAtom pair) and (op := CAR pair) ^= 'construct repeat + for x in (names := code2Classes code) repeat HPUT(hash,x,insert(op,HGET(hash,x))) + +tdPrint hash == + for key in mySort HKEYS hash repeat + sayBrightly [key,'":"] + sayBrightlyNT '" " + for x in HGET(hash,key) repeat sayBrightlyNT ['" ",x] + TERPRI() + +topics con == + --assumes that DOCUMENTATION property already has #s added + $topicClasses := ASSOCRIGHT mySort + [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] + hash := MAKE_-HASHTABLE 'ID + tdAdd(con,hash) + for x in REMDUP [CAAR y for y in ancestorsOf(getConstructorForm con,nil)] repeat + tdAdd(x,hash) + for x in HKEYS hash repeat HPUT(hash,x,mySort HGET(hash,x)) + tdPrint hash + +code2Classes cc == + cc := 2*cc + [x while cc ^= 0 for x in $topicClasses | ODDP (cc := QUOTIENT(cc,2))] + +myLastAtom x == + while x is [.,:x] repeat nil + x + +--======================================================================= +-- Transfer Codes to opAlist +--======================================================================= + +transferClassCodes(conform,opAlist) == + transferCodeCon(opOf conform,opAlist) + for x in ancestorsOf(conform,nil) repeat + transferCodeCon(CAAR x,opAlist) + +transferCodeCon(con,opAlist) == + for pair in GETDATABASE(con,'DOCUMENTATION) + | FIXP (code := myLastAtom pair) repeat + u := ASSOC(QCAR pair,opAlist) => RPLACD(LASTNODE u,code) + +--======================================================================= +-- Filter Operation by Topic +--======================================================================= + +filterByTopic(opAlist,topic) == + bitNumber := HGET($topicHash,topic) + [x for x in opAlist + | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)] + +listOfTopics(conname) == + doc := GETDATABASE(conname,'DOCUMENTATION) + u := ASSOC('constructor,doc) or return nil + code := myLastAtom u +--null FIXP code => nil + mySort [key for key in HKEYS($topicHash) | LOGBITP(HGET($topicHash,key),code)] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/util.lisp.pamphlet b/src/interp/util.lisp.pamphlet index d938ea93..80d2443e 100644 --- a/src/interp/util.lisp.pamphlet +++ b/src/interp/util.lisp.pamphlet @@ -820,16 +820,19 @@ because of {\bf *print-level*} or {\bf *print-length*}. <>= (in-package "OLD-BOOT") -(defun boot (in-file out-file) ;; translates a single boot file +(defun boot (file) ;; translates a single boot file #+:CCL (setq *package* (find-package "BOOT")) #+:AKCL (in-package "BOOT") (let (*print-level* *print-length* + (fn (pathname-name file)) (*print-pretty* t)) (declare (special *print-level* *print-length*)) - (boot::boot in-file out-file))) + (boot::boot + file + (merge-pathnames (make-pathname :type "clisp") file)))) @ diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot deleted file mode 100644 index e6eb3ef2..00000000 --- a/src/interp/wi1.boot +++ /dev/null @@ -1,1261 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - --- !! do not delete the next function ! - -spad2AsTranslatorAutoloadOnceTrigger() == nil - -pairList(u,v) == [[x,:y] for x in u for y in v] - ---====================================================================== --- Temporary definitions---for tracing and debugging ---====================================================================== -tr fn == - $convertingSpadFile : local := true - $options: local := nil - sfn := STRINGIMAGE fn - newname := STRCONC(sfn,'".as") - $outStream :local := MAKE_-OUTSTREAM newname - markSay '"#pile" - markSay('"#include _"axiom.as_"") - markTerpri() - CATCH("SPAD__READER",compiler [INTERN sfn]) - SHUT $outStream - -stackMessage msg == ---if msg isnt ["cannot coerce: ",:.] then foobum msg - $compErrorMessageStack:= [msg,:$compErrorMessageStack] - nil - -ppFull x == - _*PRINT_-LEVEL_* : local := nil - _*PRINT_-DEPTH_* : local := nil - _*PRINT_-LENGTH_* : local := nil - pp x - -put(x,prop,val,e) == ---if prop = 'mode and CONTAINED('PART,val) then foobar val - $InteractiveMode and not EQ(e,$CategoryFrame) => - putIntSymTab(x,prop,val,e) - --e must never be $CapsuleModemapFrame - null atom x => put(first x,prop,val,e) - newProplist:= augProplistOf(x,prop,val,e) - prop="modemap" and $insideCapsuleFunctionIfTrue=true => - SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] - $CapsuleModemapFrame:= - addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), - $CapsuleModemapFrame) - e - addBinding(x,newProplist,e) - -addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == ---if CONTAINED('PART,proplist) then foobar proplist - EQ(proplist,getProplist(var,e)) => e - $InteractiveMode => addBindingInteractive(var,proplist,e) - if curContour is [[ =var,:.],:.] then curContour:= rest curContour - --Previous line should save some space - [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] - ---====================================================================== --- From define.boot ---====================================================================== -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - x := markKillAll x - isCategoryForm(x,e) => - parameters:= - union("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= union(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - - -compDefineFunctor(dfOriginal,m,e,prefix,fal) == - df := markInsertParts dfOriginal - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineLisplib(df,m,e,prefix,fal,fn) == - ["DEF",[op,:.],:.] := df - --fn= compDefineCategory OR compDefineFunctor - sayMSG fillerSpaces(72,'"-") - $LISPLIB: local := 'T - $op: local := op - $lisplibAttributes: local := NIL - $lisplibPredicates: local := NIL -- set by makePredicateBitVector - $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) - $lisplibForm: local := NIL - $lisplibKind: local := NIL - $lisplibModemap: local := NIL - $lisplibModemapAlist: local := NIL - $lisplibSlot1 : local := NIL -- used by NRT mechanisms - $lisplibOperationAlist: local := NIL - $lisplibSuperDomain: local := NIL - $libFile: local := NIL - $lisplibVariableAlist: local := NIL - $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc - $lisplibCategory: local := nil - --for categories, is rhs of definition; otherwise, is target of functor - --will eventually become the "constructorCategory" property in lisplib - --set in compDefineCategory if category, otherwise in finalizeLisplib - libName := getConstructorAbbreviation op - -- $incrementalLisplibFlag seems never to be set so next line not used - -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) - BOUNDP '$compileDocumentation and $compileDocumentation => - compileDocumentation libName - sayMSG ['" initializing ",$spadLibFT,:bright libName, - '"for",:bright op] - initializeLisplib libName - sayMSG ['" compiling into ",$spadLibFT,:bright libName] - res:= FUNCALL(fn,df,m,e,prefix,fal) - sayMSG ['" finalizing ",$spadLibFT,:bright libName] ---finalizeLisplib libName - FRESH_-LINE $algebraOutputStream - sayMSG fillerSpaces(72,'"-") - unloadOneConstructor(op,libName) - res - -compTopLevel(x,m,e) == ---+ signals that target is derived from lhs-- see NRTmakeSlot1Info - $NRTderivedTargetIfTrue: local := false - $killOptimizeIfTrue: local:= false - $forceAdd: local:= false - $compTimeSum: local := 0 - $resolveTimeSum: local := 0 - $packagesUsed: local := [] - -- The next line allows the new compiler to be tested interactively. - compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak - if x is ["where",:.] then x := markWhereTran x - def := - x is ["where",a,:.] => a - x - $originalTarget : local := - def is ["DEF",.,[target,:.],:.] => target - 'sorry - x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => - ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) - --keep old environment after top level function defs - FUNCALL(compFun,x,m,e) - -markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == - items := - tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] - [first tail] - [op,:argl] := form - [target,:atypeList] := sig - decls := [[":",a,b] for a in argl for b in atypeList | b] --- not (and/[null x for x in atypeList]) => --- systemError ['"unexpected WHERE argument list: ",:atypeList] - for x in items repeat - x is [":",a,b] => - a is ['LISTOF,:r] => - for y in r repeat decls := [[":",y,b],:decls] - decls := [x,:decls] - x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => - fn = target or fn is [=target] => ttype := bd - fn = body or fn is [=body] => body := bd - macros := [x,:macros] - systemError ['"unexpected WHERE item: ",x] - nargtypes := [p for arg in argl | - p := or/[t for d in decls | d is [.,=arg,t]] or - systemError ['"Missing WHERE declaration for :", arg]] - nform := form - ntarget := ttype or target - ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] - result := - REVERSE macros is [:m,e] => - mpart := - m => ['SEQ,:m,['exit,1,e]] - e - ['where,ndef,mpart] - ndef - result - -compPART(u,m,e) == ---------new------------------------------------------94/10/11 - ['PART,.,x] := u - T := comp(x,m,e) => markAny('compPART,u, T) - nil - -xxxxx x == x - -qt(n,T) == - null T => nil - if null getProplist('R,T.env) then xxxxx n - T - -qe(n,e) == - if null getProplist('R,e) then xxxxx n - e - -comp(x,m,e) == - qe(7,e) - T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) ---T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) - --------------------------------------------------------94/11/10 - nil - -comp0(x,m,e) == - qe(8,e) ---version of comp which skips the marking (see compReduce1) - T:= compNoStacking(x,m,e) => - $compStack:= nil - qt(10,T) - $compStack:= [[x,m,e,$exitModeStack],:$compStack] - nil - -compNoStacking(xOrig,m,e) == - $partExpression: local := nil - xOrig := markKillAllRecursive xOrig --->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) -----------------------------------------------------------94/10/11 - qt(11,compNoStacking0(xOrig,m,e)) - -markKillAllRecursive x == - x is [op,:r] => ---->op = 'PART => markKillAllRecursive CADR r - op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] -----------------------------------------------------------94/10/11 - constructor? op => markKillAll x - op = 'elt and constructor? opOf CAR r => - ['elt,markKillAllRecursive CAR r,CADR r] - x - x - -compNoStackingAux($partExpression,m,e) == ------------------not used---------------------94/10/11 - x := CADDR $partExpression - T := compNoStacking0(x,m,e) or return nil - markParts($partExpression,T) - -compNoStacking0(x,m,e) == - qe(1,e) - T := compNoStacking01(x,m,qe(51,e)) - qt(52,T) - -compNoStacking01(x,m,e) == ---compNoStacking0(x,m,e) == - if CONTAINED('MI,m) then m := markKillAll(m) - T:= comp2(x,m,e) => - (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => - [T.expr,"Rep",T.env]; qt(12,T)) - --$Representation is bound in compDefineFunctor, set by doIt - --this hack says that when something is undeclared, $ is - --preferred to the underlying representation -- RDJ 9/12/83 - T := compNoStacking1(x,m,e,$compStack) - qt(13,T) - -compNoStacking1(x,m,e,$compStack) == - u:= get(if m="$" then "Rep" else m,"value",e) => - m1 := markKillAll u.expr ---------------------> new <------------------------- - T:= comp2(x,m1,e) => coerce(T,m) - nil ---------------------> new <------------------------- - nil - -compWithMappingMode(x,m,oldE) == - ["Mapping",m',:sl] := m - $killOptimizeIfTrue: local:= true - e:= oldE - x := markKillAll x - ------------------ - m := markKillAll m - ------------------ ---if x is ['PART,.,y] then x := y ---------------------------------- - isFunctor x => - if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and - (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] - ) and extendsCategoryForm("$",target,m') then return [x,m,e] - if STRINGP x then x:= INTERN x - for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat - [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) - not null vl and not hasFormalMapVariable(x, vl) => return - [u,.,.] := comp([x,:vl],m',e) or return nil - extractCodeAndConstructTriple(u, m, oldE) - null vl and (t := comp([x], m', e)) => return - [u,.,.] := t - extractCodeAndConstructTriple(u, m, oldE) - [u,.,.]:= comp(x,m',e) or return nil - originalFun := u - if originalFun is ['WI,a,b] then u := b - uu := ['LAMBDA,vl,u] - --------------------------> 11/28 drop COMP-TRAN, optimizations - T := [uu,m,oldE] - originalFun is ['WI,a,b] => markLambda(vl,a,m,T) - markLambda(vl,originalFun,m,T) - -compAtom(x,m,e) == - T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) - x="nil" => - T:= - modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) - modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) - T => convert(T,m) ---> - FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] --- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') - t:= - isSymbol x => - compSymbol(x,m,e) or return nil - m = $Expression and primitiveType x => [x,m,e] - STRINGP x => - x ^= '"failed" and (member('(Symbol), $localImportStack) or - member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] - [x, x, e] - [x,primitiveType x or return nil,e] - convert(t,m) - -extractCodeAndConstructTriple(u, m, oldE) == - u := markKillAll u - u is ["call",fn,:.] => - if fn is ["applyFun",a] then fn := a - [fn,m,oldE] - [op,:.,env] := u - [["CONS",["function",op],env],m,oldE] - -compSymbol(s,m,e) == - s="$NoValue" => ["$NoValue",$NoValueMode,e] - isFluid s => [s,getmode(s,e) or return nil,e] - s="true" => ['(QUOTE T),$Boolean,e] - s="false" => [false,$Boolean,e] - s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] - v:= get(s,"value",e) => ---+ - MEMQ(s,$functorLocalParameters) => - NRTgetLocalIndex s - [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile - [s,v.mode,e] --s has been SETQd - m':= getmode(s,e) => - if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and - not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s - [s,m',e] --s is a declared argument - MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] ----> - m = $Symbol or m = $Expression => [['QUOTE,s],m,e] - ---> was ['QUOTE, s] - not isFunction(s,e) => errorRef s - -compForm(form,m,e) == - if form is [['PART,.,op],:r] then form := [op,:r] - ----------------------------------------------------- 94/10/16 - T:= - compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return - stackMessageIfNone ["cannot compile","%b",form,"%d"] - T - -compForm1(form,m,e) == - [op,:argl] := form - $NumberOfArgsIfInteger: local:= #argl --see compElt - op="error" => - [[op,:[([.,.,e]:=outputComp(x,e)).expr - for x in argl]],m,e] - op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) - op is ["elt",domain,op'] => - domain := markKillAll domain - domain="Lisp" => - --op'='QUOTE and null rest argl => [first argl,m,e] - val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] - markLisp([val,m,e],m) --------> new <------------- --- foobar domain --- markImport(domain,true) --------> new <------------- - domain=$Expression and op'="construct" => compExpressionList(argl,m,e) - (op'="COLLECT") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) --------> new <------------- - domain= 'Rep and - (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), - [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) - | x is [[ =domain,:.],:.]])) => ans --------> new <------------- - ans := compForm2([op',:argl],m,e:= addDomain(domain,e), - [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans - (op'="construct") and coerceable(domain,m,e) => - (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) - nil - - e:= addDomain(m,e) --???unneccessary because of comp2's call??? - (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T - compToApply(op,argl,m,e) - ---% WI and MI - -compForm3(form is [op,:argl],m,e,modemapList) == ---order modemaps so that ones from Rep are moved to the front - modemapList := compFormOrderModemaps(modemapList,m = "$") - qe(22,e) - T:= - or/ - [compFormWithModemap(form,m,e,first (mml:= ml)) - for ml in tails modemapList] or return nil - qt(14,T) - result := - $compUniquelyIfTrue => - or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => - THROW("compUniquely",nil) - qt(15,T) - qt(16,T) - qt(17,markAny('compForm3,form,result)) - -compFormOrderModemaps(mml,targetIsDollar?) == ---order modemaps so that ones from Rep are moved to the front ---exceptions: if $ is the target and there are 2 modemaps with --- identical signatures, move the $ one ahead - repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] - if repMms and targetIsDollar? then - dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" - and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] - repMms := [:dollarMms, :repMms] - null repMms => mml - [:repMms,:SETDIFFERENCE(mml,repMms)] - -compWI(["WI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compMI(["MI",a,b],m,E) == - u := comp(b,m,E) - pp (u => "====> ok"; 'NO) - u - -compWhere([.,form,:exprList],m,eInit) == - $insideExpressionIfTrue: local:= false - $insideWhereIfTrue: local:= true --- if not $insideFunctorIfTrue then --- $originalTarget := --- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => --- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and --- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and --- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => --- [ntarget,:rest osig] --- osig --- nil --- foobum exprList - e:= eInit - u:= - for item in exprList repeat - [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" - u="failed" => return nil - $insideWhereIfTrue:= false - [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil - eFinal:= - del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) - eInit - [x,m,eFinal] - -compMacro(form,m,e) == - $macroIfTrue: local:= true - ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form - firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] - markMacro(first lhs,rhs) - rhs := - rhs is ['CATEGORY,:.] => ['"-- the constructor category"] - rhs is ['Join,:.] => ['"-- the constructor category"] - rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] - rhs is ['add,:.] => ['"-- the constructor capsule"] - formatUnabbreviated rhs - sayBrightly ['" processing macro definition",'%b, - :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] - ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - m=$EmptyMode or m=$NoValueMode => - ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - ---compMacro(form,m,e) == --- $macroIfTrue: local:= true --- ["MDEF",lhs,signature,specialCases,rhs]:= form --- rhs := --- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] --- rhs is ['Join,:.] => ['"-- the constructor category"] --- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] --- rhs is ['add,:.] => ['"-- the constructor capsule"] --- formatUnabbreviated rhs --- sayBrightly ['" processing macro definition",'%b, --- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] --- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) --- m=$EmptyMode or m=$NoValueMode => --- rhs := markMacro(lhs,rhs) --- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] - -compSetq(oform,m,E) == - ["LET",form,val] := oform - T := compSetq1(form,val,m,E) => markSetq(oform,T) - nil - -compSetq1(oform,val,m,E) == - form := markKillAll oform - IDENTP form => setqSingle(form,val,m,E) - form is [":",x,y] => - [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) - compSetq(["LET",x,val],m,E') - form is [op,:l] => - op="CONS" => setqMultiple(uncons form,val,m,E) - op="Tuple" => setqMultiple(l,val,m,E) - setqSetelt(oform,form,val,m,E) - -setqSetelt(oform,[v,:s],val,m,E) == - T:= comp0(["setelt",:oform,val],m,E) or return nil ----> ------- - markComp(oform,T) - -setqSingle(id,val,m,E) == - $insideSetqSingleIfTrue: local:= true - --used for comping domain forms within functions - currentProplist:= getProplist(id,E) - m'':= get(id,'mode,E) or getmode(id,E) or - (if m=$NoValueMode then $EmptyMode else m) ------------------------> new <------------------------- - trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) ------------------------> new <------------------------- - T:= - (trialT and coerce(trialT,m'')) or eval or return nil where - eval() == - T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and - (T:=comp(val,maxm'',E)) => T - (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => - assignError(val,T.mode,id,m'') - T':= [x,m',e']:= convert(T,m) or return nil - if $profileCompiler = true then - null IDENTP id => nil - key := - MEMQ(id,rest $form) => 'arguments - 'locals - profileRecord(key,id,T.mode) - newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) - e':= (PAIRP id => e'; addBinding(id,newProplist,e')) - x1 := markKillAll x - if isDomainForm(x1,e') then - if isDomainInScope(id,e') then - stackWarning ["domain valued variable","%b",id,"%d", - "has been reassigned within its scope"] - e':= augModemapsFromDomain1(id,x1,e') - --all we do now is to allocate a slot number for lhs - --e.g. the LET form below will be changed by putInLocalDomainReferences ---+ - if (k:=NRTassocIndex(id)) - then - $markFreeStack := [id,:$markFreeStack] - form:=['SETELT,"$",k,x] - else form:= - $QuickLet => ["LET",id,x] - ["LET",id,x, - (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] - [form,m',e'] - -setqMultiple(nameList,val,m,e) == - val is ["CONS",:.] and m=$NoValueMode => - setqMultipleExplicit(nameList,uncons val,m,e) - val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) - --1. create a gensym, %add to local environment, compile and assign rhs - g:= genVariable() - e:= addBinding(g,nil,e) - T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil - e:= put(g,"mode",m1,e) - [x,m',e]:= convert(T,m) or return nil - --1.1 exit if result is a list - m1 is ["List",D] => - for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) - convert([["PROGN",x,["LET",nameList,g],g],m',e],m) - --2. verify that the #nameList = number of parts of right-hand-side - selectorModePairs:= - --list of modes - decompose(m1,#nameList,e) or return nil where - decompose(t,length,e) == - t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] - comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => - [[name,:mode] for [":",name,mode] in l] - stackMessage ["no multiple assigns to mode: ",t] - #nameList^=#selectorModePairs => - stackMessage [val," must decompose into ",#nameList," components"] - -- 3.generate code; return - assignList:= - [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr - for x in nameList for [y,:z] in selectorModePairs] - if assignList="failed" then NIL - else [MKPROGN [x,:assignList,g],m',e] - -setqMultipleExplicit(nameList,valList,m,e) == - #nameList^=#valList => - stackMessage ["Multiple assignment error; # of items in: ",nameList, - "must = # in: ",valList] - gensymList:= [genVariable() for name in nameList] - for g in gensymList for name in nameList repeat - e := put(g,"mode",get(name,"mode",e),e) - assignList:= - --should be fixed to declare genVar when possible - [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" - for g in gensymList for val in valList for name in nameList] - assignList="failed" => nil - reAssignList:= - [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" - for g in gensymList for name in nameList] - reAssignList="failed" => nil - T := [["PROGN",:[T.expr for T in assignList], - :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] - markMultipleExplicit(nameList,valList,T) - -canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends - atom expr => ValueFlag and level=exitCount - (op:= first expr)="QUOTE" => ValueFlag and level=exitCount - MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) - op="TAGGEDexit" => - expr is [.,count,data] => canReturn(data.expr,level,count,count=level) - level=exitCount and not ValueFlag => nil - op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] - op="TAGGEDreturn" => nil - op="CATCH" => - [.,gs,data]:= expr - (findThrow(gs,data,level,exitCount,ValueFlag) => true) where - findThrow(gs,expr,level,exitCount,ValueFlag) == - atom expr => nil - expr is ["THROW", =gs,data] => true - --this is pessimistic, but I know of no more accurate idea - expr is ["SEQ",:l] => - or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] - or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] - canReturn(data,level,exitCount,ValueFlag) - op = "COND" => - level = exitCount => - or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] - or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] - for v in rest expr] - op="IF" => - expr is [.,a,b,c] - if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then - SAY "IF statement can not cause consequents to be executed" - pp expr - canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) - or canReturn(c,level,exitCount,ValueFlag) - --now we have an ordinary form - atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - op is ["XLAM",args,bods] => - and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] - systemErrorHere '"canReturn" --for the time being - -compList(l,m is ["List",mUnder],e) == - markImport m - markImport mUnder - null l => [NIL,m,e] - Tl:= [[.,mUnder,e]:= - comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] - Tl="failed" => nil - T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] - -compVector(l,m is ["Vector",mUnder],e) == - markImport m - markImport mUnder - null l => [$EmptyVector,m,e] - Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] - Tl="failed" => nil - [["VECTOR",:[T.expr for T in Tl]],m,e] - -compColon([":",f,t],m,e) == - $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) - --if inside an expression, ":" means to convert to m "on faith" - f := markKillAll f - $lhsOfColon: local:= f - t:= - t := markKillAll t - atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' - isDomainForm(t,e) and not $insideCategoryIfTrue => - (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) - isDomainForm(t,e) or isCategoryForm(t,e) => t - t is ["Mapping",m',:r] => t - unknownTypeError t - t - if $insideCapsuleFunctionIfTrue then markDeclaredImport t - f is ["LISTOF",:l] => - (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) - e:= - f is [op,:argl] and not (t is ["Mapping",:.]) => - --for MPOLY--replace parameters by formal arguments: RDJ 3/83 - newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), - [(x is [":",a,m] => a; x) for x in argl],t) - signature:= - ["Mapping",newTarget,: - [(x is [":",a,m] => m; - getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] - put(op,"mode",signature,e) - put(f,"mode",t,e) - if not $bootStrapMode and $insideFunctorIfTrue and - makeCategoryForm(t,e) is [catform,e] then - e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) - ["/throwAway",getmode(f,e),e] - -compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) - -compConstruct1(form is ["construct",:l],m,e) == - y:= modeIsAggregateOf("List",m,e) => - T:= compList(l,["List",CADR y],e) => convert(T,m) - y:= modeIsAggregateOf("Vector",m,e) => - T:= compVector(l,["Vector",CADR y],e) => convert(T,m) - T:= compForm(form,m,e) => T - for D in getDomainsInScope e repeat - (y:=modeIsAggregateOf("List",D,e)) and - (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => - return T' - (y:=modeIsAggregateOf("Vector",D,e)) and - (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => - return T' - -compPretend(u := ["pretend",x,t],m,e) == - t := markKillAll t - m := markKillAll m - e:= addDomain(t,e) - T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil - if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] - T1:= [T.expr,t,T.env] - t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- - T':= coerce(T1,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - markPretend(T1,T') - nil - -compAtSign(["@",x,m'],m,e) == - m' := markKillAll m' - m := markKillAll m - e:= addDomain(m',e) - T:= comp(x,m',e) or return nil - coerce(T,m) - -compColonInside(x,m,e,m') == - m' := markKillAll m' - e:= addDomain(m',e) - T:= comp(x,$EmptyMode,e) or return nil - if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] - T:= [T.expr,m',T.env] - m := markKillAll m - T':= coerce(T,m) => - warningMessage => - stackWarning warningMessage - markCompColonInside("@",T') - stackWarning [":",m'," -- should replace by pretend"] - markCompColonInside("pretend",T') - nil - -resolve(min, mout) == - din := markKillAll min - dout := markKillAll mout - din=$NoValueMode or dout=$NoValueMode => $NoValueMode - dout=$EmptyMode => din - STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 - STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 - din^=dout and (STRINGP din or STRINGP dout) => - modeEqual(dout,$String) => dout - modeEqual(din,$String) => nil - mkUnion(din,dout) - dout - -coerce(T,m) == - T := [T.expr,markKillAll T.mode,T.env] - m := markKillAll m - if not get(m, 'isLiteral,T.env) then markImport m - $InteractiveMode => - keyedSystemError("S2GE0016",['"coerce", - '"function coerce called from the interpreter."]) ---==================> changes <====================== ---The following line is inappropriate for our needs::: ---rplac(CADR T,substitute("$",$Rep,CADR T)) - T' := coerce0(T,m) => T' - T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] ---==================> changes <====================== - coerce0(T,m) - -coerce0(T,m) == - T':= coerceEasy(T,m) => T' - T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) - T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) - T':= coerceExtraHard(T,m) => T' - T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil - T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) - stackMessage fn(T.expr,T.mode,m) where - -- if from from coerceable, this coerce was just a trial coercion - -- from compFormWithModemap to filter through the modemaps - fn(x,m1,m2) == - ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", - " to mode","%b",m2,"%d"] - -coerceSubset(T := [x,m,e],m') == - m = $SmallInteger => - m' = $Integer => [x,m',e] - m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] - nil --- pp [m, m'] - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] - nil - -coerceRep(T,m) == - md := T.mode - atom md => nil - CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or - CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T - nil - ---- GET rid of XLAMs -spadCompileOrSetq form == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - [nam,[lam,vl,body]] := form - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -coerceHard(T,m) == - $e: local:= T.env - m':= T.mode - STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] - modeEqual(m',m) or - (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and - modeEqual(m'',m) or - (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and - modeEqual(m'',m') => [T.expr,m,T.env] - STRINGP T.expr and T.expr=m => [T.expr,m,$e] - isCategoryForm(m,$e) => - $bootStrapMode = true => [T.expr,m,$e] - extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] - nil - nil - -coerceExtraHard(T is [x,m',e],m) == - T':= autoCoerceByModemap(T,m) => T' - isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and - member(t,l) and (T':= autoCoerceByModemap(T,t)) and - (T'':= coerce(T',m)) => T'' - m' is ['Record,:.] and m = $Expression => - [['coerceRe2E,x,['ELT,COPY m',0]],m,e] - nil - -compCoerce(u := ["::",x,m'],m,e) == - m' := markKillAll m' - e:= addDomain(m',e) - m := markKillAll m ---------------> new code <------------------- - T:= compCoerce1(x,m',e) => coerce(T,m) - T := comp(x,$EmptyMode,e) or return nil - T.mode = $SmallInteger and - MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => - compCoerce(["::",["::",x,$Integer],m'],m,e) ---------------> new code <------------------- - getmode(m',e) is ["Mapping",["UnionCategory",:l]] => - l := [markKillAll x for x in l] - T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil - coerce([T.expr,m',T.env],m) - -compCoerce1(x,m',e) == - T:= comp(x,m',e) - if null T then T := comp(x,$EmptyMode,e) - null T => return nil - m1:= - STRINGP T.mode => $String - T.mode - m':=resolve(m1,m') - T:=[T.expr,m1,T.env] - T':= coerce(T,m') => T' - T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] - [code,m',T.env] - -coerceByModemap([x,m,e],m') == ---+ modified 6/27 for new runtime system - u:= - [modemap - for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, - s] and (modeEqual(t,m') or isSubset(t,m',e)) - and (modeEqual(s,m) or isSubset(m,s,e))] or return nil - mm:=first u -- patch for non-trival conditons - fn := genDeltaEntry ['coerce,:mm] - T := [["call",fn,x],m',e] - markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) - -autoCoerceByModemap([x,source,e],target) == - u:= - [cexpr - for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ - .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) - ---====================================================================== --- From compiler.boot ---====================================================================== ---comp3x(x,m,$e) == - -comp3(x,m,$e) == - --returns a Triple or %else nil to signalcan't do' - $e:= addDomain(m,$e) - e:= $e --for debugging purposes - m is ["Mapping",:.] => compWithMappingMode(x,m,e) - m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) - STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) - ^x or atom x => compAtom(x,m,e) - op:= first x - getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u - op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) - op=":" => compColon(x,m,e) - op="::" => compCoerce(x,m,e) - not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => - compTypeOf(x,m,e) - ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- - x is ['PART,:.] => compPART(x,m,e) - ---------------------------------- - t:= qt(14,compExpression(x,m,e)) - t is [x',m',e'] and not member(m',getDomainsInScope e') => - qt(15,[x',m',addDomain(m',e')]) - qt(16,t) - -yyyyy x == x -compExpression(x,m,e) == - $insideExpressionIfTrue: local:= true - if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x - x := compRenameOp x - atom first x and (fn:= GETL(first x,"SPECIAL")) => - FUNCALL(fn,x,m,e) - compForm(x,m,e) - -compRenameOp x == ----------> new 12/3/94 - x is [op,:r] and op is ['PART,.,op1] => - [op1,:r] - x - -compCase(["case",x,m1],m,e) == - m' := markKillAll m1 - e:= addDomain(m',e) - T:= compCase1(x,m',e) => coerce(T,m) - nil - -compCase1(x,m,e) == - x1 := - x is ['PART,.,a] => a - x - [x',m',e']:= comp(x1,$EmptyMode,e) or return nil - if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) - -------------------------------------------------------------------------- - m' isnt ['Union,:r] => nil - mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') - | map is [.,.,s,t] and modeEqual(t,m) and - (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] - or return nil - u := [cexpr for [.,cexpr] in mml] - fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil - tag := genCaseTag(m, r, 1) or return nil - x1 := - switchMode => markRepper('rep, x) - x - markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) - -genCaseTag(t,l,n) == - l is [x, :l] => - x = t => - STRINGP x => INTERN x - INTERN STRCONC("value", STRINGIMAGE n) - x is ["::",=t,:.] => t - STRINGP x => genCaseTag(t, l, n) - genCaseTag(t, l, n + 1) - nil - -compIf(["IF",aOrig,b,c],m,E) == - a := markKillButIfs aOrig - [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil - [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil - [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil - xb':= coerce(Tb,mc) or return nil - x:= ["IF",xa,quotify xb'.expr,quotify xc] - (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where - Env(bEnv,cEnv,b,c,E) == - canReturn(b,0,0,true) => - (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) - canReturn(c,0,0,true) => cEnv - E - [x,mc,returnEnv] - -compBoolean(p,pWas,m,Einit) == - op := opOf p - [p',m,E]:= - fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => - APPLY(fop,[p,pWas,m,Einit]) or return nil - T := comp(p,m,Einit) or return nil - markAny('compBoolean,pWas,T) - [p',m,getSuccessEnvironment(markKillAll p,E), - getInverseEnvironment(markKillAll p,E)] - -compAnd([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) - -compOr([op,:args], pWas, m, e) == ---called ONLY from compBoolean - cargs := [T.expr for x in args - | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] - null cargs => nil - coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) - -compNot([op,arg], pWas, m, e) == ---called ONLY from compBoolean - [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil - coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) - -compDefine(form,m,e) == - $tripleHits: local:= 0 - $macroIfTrue: local - $packagesUsed: local - ['DEF,.,originalSignature,.,body] := form - if not $insideFunctorIfTrue then - $originalBody := COPY body - compDefine1(form,m,e) - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true - if signature.target is ['Mapping,:map] then - signature:= map - form:= ['DEF,lhs,signature,specialCases,rhs] - - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineCategory1(df,m,e,prefix,fal) == - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $catAddForm : local := nil --for conversion to new compiler 2/95 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $categoryTranForm : local := nil --for conversion to new compiler 10/93 - ['DEF,form,sig,sc,body] := df - body := markKillAll body --these parts will be replaced by compDefineLisplib - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines --- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil --- else - if categoryCapsule and not $bootStrapMode then - [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - defform := mkCategoryPackage(form,cat,categoryCapsule) - ['DEF,[.,arg,:.],:.] := defform - $categoryNameForDollar :local := arg - compDefine1(defform,$EmptyMode,e) - else - [body,T] := $categoryTranForm - markFinish(body,T) - - [d,m,e] - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local - $definition: local - --used by DomainSubstitutionFunction - $form: local - $op: local - $extraParms: local - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $:
- [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - T := compOrCroak(formalBody,signature'.target,e) ---------------------> new <------------------- - $catAddForm := - $originalBody is ['add,y,:.] => y - $originalBody - $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] ---------------------> new <------------------- - body:= optFunctorBody markKillAll T.expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) ----- lisplibWrite('"compilerInfo", ----- ['SETQ,'$CategoryFrame, ----- ['put,['QUOTE,op'],' ----- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, ----- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := - BOUNDP '$convertingSpadFile and $convertingSpadFile => nil - eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody ----- if $LISPLIB then ----- $lisplibForm:= form ----- $lisplibKind:= 'category ----- modemap:= [[parForm,:parSignature],[true,op']] ----- $lisplibModemap:= modemap ----- $lisplibCategory:= formalBody ----- form':=[op',:sargl] ----- augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] diff --git a/src/interp/wi1.boot.pamphlet b/src/interp/wi1.boot.pamphlet new file mode 100644 index 00000000..a86a7da2 --- /dev/null +++ b/src/interp/wi1.boot.pamphlet @@ -0,0 +1,1287 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/wi1.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +-- !! do not delete the next function ! + +spad2AsTranslatorAutoloadOnceTrigger() == nil + +pairList(u,v) == [[x,:y] for x in u for y in v] + +--====================================================================== +-- Temporary definitions---for tracing and debugging +--====================================================================== +tr fn == + $convertingSpadFile : local := true + $options: local := nil + sfn := STRINGIMAGE fn + newname := STRCONC(sfn,'".as") + $outStream :local := MAKE_-OUTSTREAM newname + markSay '"#pile" + markSay('"#include _"axiom.as_"") + markTerpri() + CATCH("SPAD__READER",compiler [INTERN sfn]) + SHUT $outStream + +stackMessage msg == +--if msg isnt ["cannot coerce: ",:.] then foobum msg + $compErrorMessageStack:= [msg,:$compErrorMessageStack] + nil + +ppFull x == + _*PRINT_-LEVEL_* : local := nil + _*PRINT_-DEPTH_* : local := nil + _*PRINT_-LENGTH_* : local := nil + pp x + +put(x,prop,val,e) == +--if prop = 'mode and CONTAINED('PART,val) then foobar val + $InteractiveMode and not EQ(e,$CategoryFrame) => + putIntSymTab(x,prop,val,e) + --e must never be $CapsuleModemapFrame + null atom x => put(first x,prop,val,e) + newProplist:= augProplistOf(x,prop,val,e) + prop="modemap" and $insideCapsuleFunctionIfTrue=true => + SAY ["**** modemap PUT on CapsuleModemapFrame: ",val] + $CapsuleModemapFrame:= + addBinding(x,augProplistOf(x,"modemap",val,$CapsuleModemapFrame), + $CapsuleModemapFrame) + e + addBinding(x,newProplist,e) + +addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == +--if CONTAINED('PART,proplist) then foobar proplist + EQ(proplist,getProplist(var,e)) => e + $InteractiveMode => addBindingInteractive(var,proplist,e) + if curContour is [[ =var,:.],:.] then curContour:= rest curContour + --Previous line should save some space + [[[lx,:curContour],:tailContour],:tailEnv] where lx:= [var,:proplist] + +--====================================================================== +-- From define.boot +--====================================================================== +compJoin(["Join",:argl],m,e) == + catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] + catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) + catList':= + [extract for x in catList] where + extract() == + x := markKillAll x + isCategoryForm(x,e) => + parameters:= + union("append"/[getParms(y,e) for y in rest x],parameters) + where getParms(y,e) == + atom y => + isDomainForm(y,e) => LIST y + nil + y is ['LENGTH,y'] => [y,y'] + LIST y + x + x is ["DomainSubstitutionMacro",pl,body] => + (parameters:= union(pl,parameters); body) + x is ["mkCategory",:.] => x + atom x and getmode(x,e)=$Category => x + stackSemanticError(["invalid argument to Join: ",x],nil) + x + T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] + convert(T,m) + + +compDefineFunctor(dfOriginal,m,e,prefix,fal) == + df := markInsertParts dfOriginal + $domainShell: local -- holds the category of the object being compiled + $profileCompiler: local := true + $profileAlist: local := nil + $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) + compDefineFunctor1(df,m,e,prefix,fal) + +compDefineLisplib(df,m,e,prefix,fal,fn) == + ["DEF",[op,:.],:.] := df + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibSlot1 : local := NIL -- used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc + $lisplibCategory: local := nil + --for categories, is rhs of definition; otherwise, is target of functor + --will eventually become the "constructorCategory" property in lisplib + --set in compDefineCategory if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + -- $incrementalLisplibFlag seems never to be set so next line not used + -- originalLisplibCategory:= getLisplib(libName,'constructorCategory) + BOUNDP '$compileDocumentation and $compileDocumentation => + compileDocumentation libName + sayMSG ['" initializing ",$spadLibFT,:bright libName, + '"for",:bright op] + initializeLisplib libName + sayMSG ['" compiling into ",$spadLibFT,:bright libName] + res:= FUNCALL(fn,df,m,e,prefix,fal) + sayMSG ['" finalizing ",$spadLibFT,:bright libName] +--finalizeLisplib libName + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + res + +compTopLevel(x,m,e) == +--+ signals that target is derived from lhs-- see NRTmakeSlot1Info + $NRTderivedTargetIfTrue: local := false + $killOptimizeIfTrue: local:= false + $forceAdd: local:= false + $compTimeSum: local := 0 + $resolveTimeSum: local := 0 + $packagesUsed: local := [] + -- The next line allows the new compiler to be tested interactively. + compFun := if $newCompAtTopLevel=true then 'newComp else 'compOrCroak + if x is ["where",:.] then x := markWhereTran x + def := + x is ["where",a,:.] => a + x + $originalTarget : local := + def is ["DEF",.,[target,:.],:.] => target + 'sorry + x is ["DEF",:.] or x is ["where",["DEF",:.],:.] => + ([val,mode,.]:= FUNCALL(compFun,x,m,e); [val,mode,e]) + --keep old environment after top level function defs + FUNCALL(compFun,x,m,e) + +markWhereTran ["where",["DEF",form,sig,clist,body],:tail] == + items := + tail is [['SEQ,:l,['exit,n,x]]] => [:l,x] + [first tail] + [op,:argl] := form + [target,:atypeList] := sig + decls := [[":",a,b] for a in argl for b in atypeList | b] +-- not (and/[null x for x in atypeList]) => +-- systemError ['"unexpected WHERE argument list: ",:atypeList] + for x in items repeat + x is [":",a,b] => + a is ['LISTOF,:r] => + for y in r repeat decls := [[":",y,b],:decls] + decls := [x,:decls] + x is [key,fn,p,q,bd] and MEMQ(key,'(DEF MDEF)) and p='(NIL) and q='(NIL) => + fn = target or fn is [=target] => ttype := bd + fn = body or fn is [=body] => body := bd + macros := [x,:macros] + systemError ['"unexpected WHERE item: ",x] + nargtypes := [p for arg in argl | + p := or/[t for d in decls | d is [.,=arg,t]] or + systemError ['"Missing WHERE declaration for :", arg]] + nform := form + ntarget := ttype or target + ndef := ['DEF,nform,[ntarget,:nargtypes],clist,body] + result := + REVERSE macros is [:m,e] => + mpart := + m => ['SEQ,:m,['exit,1,e]] + e + ['where,ndef,mpart] + ndef + result + +compPART(u,m,e) == +--------new------------------------------------------94/10/11 + ['PART,.,x] := u + T := comp(x,m,e) => markAny('compPART,u, T) + nil + +xxxxx x == x + +qt(n,T) == + null T => nil + if null getProplist('R,T.env) then xxxxx n + T + +qe(n,e) == + if null getProplist('R,e) then xxxxx n + e + +comp(x,m,e) == + qe(7,e) + T := qt(8,comp0(x,m,e)) => qt(9,markComp(x,T)) +--T := m = "$" and comp(x,$EmptyMode,e) => coerce(T, m) + --------------------------------------------------------94/11/10 + nil + +comp0(x,m,e) == + qe(8,e) +--version of comp which skips the marking (see compReduce1) + T:= compNoStacking(x,m,e) => + $compStack:= nil + qt(10,T) + $compStack:= [[x,m,e,$exitModeStack],:$compStack] + nil + +compNoStacking(xOrig,m,e) == + $partExpression: local := nil + xOrig := markKillAllRecursive xOrig +-->xOrig is ['PART,n,x] => compNoStackingAux(xOrig,m,e) +----------------------------------------------------------94/10/11 + qt(11,compNoStacking0(xOrig,m,e)) + +markKillAllRecursive x == + x is [op,:r] => +--->op = 'PART => markKillAllRecursive CADR r + op = 'PART => ['PART, CAR r, markKillAllRecursive CADR r] +----------------------------------------------------------94/10/11 + constructor? op => markKillAll x + op = 'elt and constructor? opOf CAR r => + ['elt,markKillAllRecursive CAR r,CADR r] + x + x + +compNoStackingAux($partExpression,m,e) == +-----------------not used---------------------94/10/11 + x := CADDR $partExpression + T := compNoStacking0(x,m,e) or return nil + markParts($partExpression,T) + +compNoStacking0(x,m,e) == + qe(1,e) + T := compNoStacking01(x,m,qe(51,e)) + qt(52,T) + +compNoStacking01(x,m,e) == +--compNoStacking0(x,m,e) == + if CONTAINED('MI,m) then m := markKillAll(m) + T:= comp2(x,m,e) => + (m=$EmptyMode and T.mode=IFCAR(get('Rep,'value,e)) => + [T.expr,"Rep",T.env]; qt(12,T)) + --$Representation is bound in compDefineFunctor, set by doIt + --this hack says that when something is undeclared, $ is + --preferred to the underlying representation -- RDJ 9/12/83 + T := compNoStacking1(x,m,e,$compStack) + qt(13,T) + +compNoStacking1(x,m,e,$compStack) == + u:= get(if m="$" then "Rep" else m,"value",e) => + m1 := markKillAll u.expr +--------------------> new <------------------------- + T:= comp2(x,m1,e) => coerce(T,m) + nil +--------------------> new <------------------------- + nil + +compWithMappingMode(x,m,oldE) == + ["Mapping",m',:sl] := m + $killOptimizeIfTrue: local:= true + e:= oldE + x := markKillAll x + ------------------ + m := markKillAll m + ------------------ +--if x is ['PART,.,y] then x := y +--------------------------------- + isFunctor x => + if get(x,"modemap",$CategoryFrame) is [[[.,target,:argModeList],.],:.] and + (and/[extendsCategoryForm("$",s,mode) for mode in argModeList for s in sl] + ) and extendsCategoryForm("$",target,m') then return [x,m,e] + if STRINGP x then x:= INTERN x + for m in sl for v in (vl:= take(#sl,$FormalMapVariableList)) repeat + [.,.,e]:= compMakeDeclaration([":",v,m],$EmptyMode,e) + not null vl and not hasFormalMapVariable(x, vl) => return + [u,.,.] := comp([x,:vl],m',e) or return nil + extractCodeAndConstructTriple(u, m, oldE) + null vl and (t := comp([x], m', e)) => return + [u,.,.] := t + extractCodeAndConstructTriple(u, m, oldE) + [u,.,.]:= comp(x,m',e) or return nil + originalFun := u + if originalFun is ['WI,a,b] then u := b + uu := ['LAMBDA,vl,u] + --------------------------> 11/28 drop COMP-TRAN, optimizations + T := [uu,m,oldE] + originalFun is ['WI,a,b] => markLambda(vl,a,m,T) + markLambda(vl,originalFun,m,T) + +compAtom(x,m,e) == + T:= compAtomWithModemap(x,m,e,get(x,"modemap",e)) => markCompAtom(x,T) + x="nil" => + T:= + modeIsAggregateOf('List,m,e) is [.,R]=> compList(x,['List,R],e) + modeIsAggregateOf('Vector,m,e) is [.,R]=> compVector(x,['Vector,R],e) + T => convert(T,m) +--> + FIXP x and MEMQ(opOf m, '(Integer NonNegativeInteger PositiveInteger SmallInteger)) => markAt [x,m,e] +-- FIXP x and (T := [x, $Integer,e]) and (T' := convert(T,m)) => markAt(T, T') + t:= + isSymbol x => + compSymbol(x,m,e) or return nil + m = $Expression and primitiveType x => [x,m,e] + STRINGP x => + x ^= '"failed" and (member('(Symbol), $localImportStack) or + member('(Symbol), $globalImportStack)) => markAt [x, '(String), e] + [x, x, e] + [x,primitiveType x or return nil,e] + convert(t,m) + +extractCodeAndConstructTriple(u, m, oldE) == + u := markKillAll u + u is ["call",fn,:.] => + if fn is ["applyFun",a] then fn := a + [fn,m,oldE] + [op,:.,env] := u + [["CONS",["function",op],env],m,oldE] + +compSymbol(s,m,e) == + s="$NoValue" => ["$NoValue",$NoValueMode,e] + isFluid s => [s,getmode(s,e) or return nil,e] + s="true" => ['(QUOTE T),$Boolean,e] + s="false" => [false,$Boolean,e] + s=m or get(s,"isLiteral",e) => [["QUOTE",s],s,e] + v:= get(s,"value",e) => +--+ + MEMQ(s,$functorLocalParameters) => + NRTgetLocalIndex s + [s,v.mode,e] --s will be replaced by an ELT form in beforeCompile + [s,v.mode,e] --s has been SETQd + m':= getmode(s,e) => + if not member(s,$formalArgList) and not MEMQ(s,$FormalMapVariableList) and + not isFunction(s,e) and null ($compForModeIfTrue=true) then errorRef s + [s,m',e] --s is a declared argument + MEMQ(s,$FormalMapVariableList) => stackMessage ["no mode found for",s] +---> + m = $Symbol or m = $Expression => [['QUOTE,s],m,e] + ---> was ['QUOTE, s] + not isFunction(s,e) => errorRef s + +compForm(form,m,e) == + if form is [['PART,.,op],:r] then form := [op,:r] + ----------------------------------------------------- 94/10/16 + T:= + compForm1(form,m,e) or compArgumentsAndTryAgain(form,m,e) or return + stackMessageIfNone ["cannot compile","%b",form,"%d"] + T + +compForm1(form,m,e) == + [op,:argl] := form + $NumberOfArgsIfInteger: local:= #argl --see compElt + op="error" => + [[op,:[([.,.,e]:=outputComp(x,e)).expr + for x in argl]],m,e] + op is ['MI,a,b] => compForm1([markKillExpr b,:argl],m,e) + op is ["elt",domain,op'] => + domain := markKillAll domain + domain="Lisp" => + --op'='QUOTE and null rest argl => [first argl,m,e] + val := [op',:[([.,.,e]:= compOrCroak(x,$EmptyMode,e)).expr for x in argl]] + markLisp([val,m,e],m) +-------> new <------------- +-- foobar domain +-- markImport(domain,true) +-------> new <------------- + domain=$Expression and op'="construct" => compExpressionList(argl,m,e) + (op'="COLLECT") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) +-------> new <------------- + domain= 'Rep and + (ans := compForm2([op',:argl],SUBST('Rep,'_$,m),e:= addDomain(domain,e), + [SUBST('Rep,'_$,x) for x in getFormModemaps([op',:argl],e) + | x is [[ =domain,:.],:.]])) => ans +-------> new <------------- + ans := compForm2([op',:argl],m,e:= addDomain(domain,e), + [x for x in getFormModemaps([op',:argl],e) | x is [[ =domain,:.],:.]]) => ans + (op'="construct") and coerceable(domain,m,e) => + (T:= comp([op',:argl],domain,e) or return nil; coerce(T,m)) + nil + + e:= addDomain(m,e) --???unneccessary because of comp2's call??? + (mmList:= getFormModemaps(form,e)) and (T:= compForm2(form,m,e,mmList)) => T + compToApply(op,argl,m,e) + +--% WI and MI + +compForm3(form is [op,:argl],m,e,modemapList) == +--order modemaps so that ones from Rep are moved to the front + modemapList := compFormOrderModemaps(modemapList,m = "$") + qe(22,e) + T:= + or/ + [compFormWithModemap(form,m,e,first (mml:= ml)) + for ml in tails modemapList] or return nil + qt(14,T) + result := + $compUniquelyIfTrue => + or/[compFormWithModemap(form,m,e,mm) for mm in rest mml] => + THROW("compUniquely",nil) + qt(15,T) + qt(16,T) + qt(17,markAny('compForm3,form,result)) + +compFormOrderModemaps(mml,targetIsDollar?) == +--order modemaps so that ones from Rep are moved to the front +--exceptions: if $ is the target and there are 2 modemaps with +-- identical signatures, move the $ one ahead + repMms := [mm for (mm:= [[dc,:.],:.]) in mml | dc = 'Rep] + if repMms and targetIsDollar? then + dollarMms := [mm for (mm := [[dc,:sig],:.]) in mml | dc = "$" + and or/[mm1 for (mm1:= [[dc1,:sig1],:.]) in repMms | sig1 = sig]] + repMms := [:dollarMms, :repMms] + null repMms => mml + [:repMms,:SETDIFFERENCE(mml,repMms)] + +compWI(["WI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compMI(["MI",a,b],m,E) == + u := comp(b,m,E) + pp (u => "====> ok"; 'NO) + u + +compWhere([.,form,:exprList],m,eInit) == + $insideExpressionIfTrue: local:= false + $insideWhereIfTrue: local:= true +-- if not $insideFunctorIfTrue then +-- $originalTarget := +-- form is ['DEF,a,osig,:.] and osig is [otarget,:.] => +-- exprList is [['SEQ,:l,['exit,n,y]]] and (u := [:l,y]) and +-- (ntarget := or/[def for x in u | x is [op,a',:.,def] and ([op,a',otarget]) and +-- MEMQ(op,'(DEF MDEF)) and (a' = otarget or a' is [=otarget])]) => +-- [ntarget,:rest osig] +-- osig +-- nil +-- foobum exprList + e:= eInit + u:= + for item in exprList repeat + [.,.,e]:= comp(item,$EmptyMode,e) or return "failed" + u="failed" => return nil + $insideWhereIfTrue:= false + [x,m,eAfter]:= comp(macroExpand(form,eBefore:= e),m,e) or return nil + eFinal:= + del:= deltaContour(eAfter,eBefore) => addContour(del,eInit) + eInit + [x,m,eFinal] + +compMacro(form,m,e) == + $macroIfTrue: local:= true + ["MDEF",lhs,signature,specialCases,rhs]:= form := markKillAll form + firstForm := ["MDEF",first lhs,'(NIL),'(NIL),rhs] + markMacro(first lhs,rhs) + rhs := + rhs is ['CATEGORY,:.] => ['"-- the constructor category"] + rhs is ['Join,:.] => ['"-- the constructor category"] + rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] + rhs is ['add,:.] => ['"-- the constructor capsule"] + formatUnabbreviated rhs + sayBrightly ['" processing macro definition",'%b, + :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] + ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + m=$EmptyMode or m=$NoValueMode => + ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +--compMacro(form,m,e) == +-- $macroIfTrue: local:= true +-- ["MDEF",lhs,signature,specialCases,rhs]:= form +-- rhs := +-- rhs is ['CATEGORY,:.] => ['"-- the constructor category"] +-- rhs is ['Join,:.] => ['"-- the constructor category"] +-- rhs is ['CAPSULE,:.] => ['"-- the constructor capsule"] +-- rhs is ['add,:.] => ['"-- the constructor capsule"] +-- formatUnabbreviated rhs +-- sayBrightly ['" processing macro definition",'%b, +-- :formatUnabbreviated lhs,'" ==> ",:rhs,'%d] +-- ["MDEF",lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) +-- m=$EmptyMode or m=$NoValueMode => +-- rhs := markMacro(lhs,rhs) +-- ["/throwAway",$NoValueMode,put(first lhs,"macro",rhs,e)] + +compSetq(oform,m,E) == + ["LET",form,val] := oform + T := compSetq1(form,val,m,E) => markSetq(oform,T) + nil + +compSetq1(oform,val,m,E) == + form := markKillAll oform + IDENTP form => setqSingle(form,val,m,E) + form is [":",x,y] => + [.,.,E']:= compMakeDeclaration(form,$EmptyMode,E) + compSetq(["LET",x,val],m,E') + form is [op,:l] => + op="CONS" => setqMultiple(uncons form,val,m,E) + op="Tuple" => setqMultiple(l,val,m,E) + setqSetelt(oform,form,val,m,E) + +setqSetelt(oform,[v,:s],val,m,E) == + T:= comp0(["setelt",:oform,val],m,E) or return nil +---> ------- + markComp(oform,T) + +setqSingle(id,val,m,E) == + $insideSetqSingleIfTrue: local:= true + --used for comping domain forms within functions + currentProplist:= getProplist(id,E) + m'':= get(id,'mode,E) or getmode(id,E) or + (if m=$NoValueMode then $EmptyMode else m) +-----------------------> new <------------------------- + trialT := m'' = "$" and get("Rep",'value,E) and comp(val,'Rep,E) +-----------------------> new <------------------------- + T:= + (trialT and coerce(trialT,m'')) or eval or return nil where + eval() == + T:= comp(val,m'',E) => T + not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and + (T:=comp(val,maxm'',E)) => T + (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => + assignError(val,T.mode,id,m'') + T':= [x,m',e']:= convert(T,m) or return nil + if $profileCompiler = true then + null IDENTP id => nil + key := + MEMQ(id,rest $form) => 'arguments + 'locals + profileRecord(key,id,T.mode) + newProplist:= consProplistOf(id,currentProplist,"value",markKillAll removeEnv T) + e':= (PAIRP id => e'; addBinding(id,newProplist,e')) + x1 := markKillAll x + if isDomainForm(x1,e') then + if isDomainInScope(id,e') then + stackWarning ["domain valued variable","%b",id,"%d", + "has been reassigned within its scope"] + e':= augModemapsFromDomain1(id,x1,e') + --all we do now is to allocate a slot number for lhs + --e.g. the LET form below will be changed by putInLocalDomainReferences +--+ + if (k:=NRTassocIndex(id)) + then + $markFreeStack := [id,:$markFreeStack] + form:=['SETELT,"$",k,x] + else form:= + $QuickLet => ["LET",id,x] + ["LET",id,x, + (isDomainForm(x,e') => ['ELT,id,0];CAR outputComp(id,e'))] + [form,m',e'] + +setqMultiple(nameList,val,m,e) == + val is ["CONS",:.] and m=$NoValueMode => + setqMultipleExplicit(nameList,uncons val,m,e) + val is ["Tuple",:l] and m=$NoValueMode => setqMultipleExplicit(nameList,l,m,e) + --1. create a gensym, %add to local environment, compile and assign rhs + g:= genVariable() + e:= addBinding(g,nil,e) + T:= [.,m1,.]:= compSetq1(g,val,$EmptyMode,e) or return nil + e:= put(g,"mode",m1,e) + [x,m',e]:= convert(T,m) or return nil + --1.1 exit if result is a list + m1 is ["List",D] => + for y in nameList repeat e:= put(y,"value",[genSomeVariable(),D,$noEnv],e) + convert([["PROGN",x,["LET",nameList,g],g],m',e],m) + --2. verify that the #nameList = number of parts of right-hand-side + selectorModePairs:= + --list of modes + decompose(m1,#nameList,e) or return nil where + decompose(t,length,e) == + t is ["Record",:l] => [[name,:mode] for [":",name,mode] in l] + comp(t,$EmptyMode,e) is [.,["RecordCategory",:l],.] => + [[name,:mode] for [":",name,mode] in l] + stackMessage ["no multiple assigns to mode: ",t] + #nameList^=#selectorModePairs => + stackMessage [val," must decompose into ",#nameList," components"] + -- 3.generate code; return + assignList:= + [([.,.,e]:= compSetq1(x,["elt",g,y],z,e) or return "failed").expr + for x in nameList for [y,:z] in selectorModePairs] + if assignList="failed" then NIL + else [MKPROGN [x,:assignList,g],m',e] + +setqMultipleExplicit(nameList,valList,m,e) == + #nameList^=#valList => + stackMessage ["Multiple assignment error; # of items in: ",nameList, + "must = # in: ",valList] + gensymList:= [genVariable() for name in nameList] + for g in gensymList for name in nameList repeat + e := put(g,"mode",get(name,"mode",e),e) + assignList:= + --should be fixed to declare genVar when possible + [[.,.,e]:= compSetq1(g,val,$EmptyMode,e) or return "failed" + for g in gensymList for val in valList for name in nameList] + assignList="failed" => nil + reAssignList:= + [[.,.,e]:= compSetq1(name,g,$EmptyMode,e) or return "failed" + for g in gensymList for name in nameList] + reAssignList="failed" => nil + T := [["PROGN",:[T.expr for T in assignList], + :[T.expr for T in reAssignList]], $NoValueMode, (LAST reAssignList).env] + markMultipleExplicit(nameList,valList,T) + +canReturn(expr,level,exitCount,ValueFlag) == --SPAD: exit and friends + atom expr => ValueFlag and level=exitCount + (op:= first expr)="QUOTE" => ValueFlag and level=exitCount + MEMQ(op,'(WI MI)) => canReturn(CADDR expr,level,count,ValueFlag) + op="TAGGEDexit" => + expr is [.,count,data] => canReturn(data.expr,level,count,count=level) + level=exitCount and not ValueFlag => nil + op="SEQ" => or/[canReturn(u,level+1,exitCount,false) for u in rest expr] + op="TAGGEDreturn" => nil + op="CATCH" => + [.,gs,data]:= expr + (findThrow(gs,data,level,exitCount,ValueFlag) => true) where + findThrow(gs,expr,level,exitCount,ValueFlag) == + atom expr => nil + expr is ["THROW", =gs,data] => true + --this is pessimistic, but I know of no more accurate idea + expr is ["SEQ",:l] => + or/[findThrow(gs,u,level+1,exitCount,ValueFlag) for u in l] + or/[findThrow(gs,u,level,exitCount,ValueFlag) for u in rest expr] + canReturn(data,level,exitCount,ValueFlag) + op = "COND" => + level = exitCount => + or/[canReturn(last u,level,exitCount,ValueFlag) for u in rest expr] + or/[or/[canReturn(u,level,exitCount,ValueFlag) for u in v] + for v in rest expr] + op="IF" => + expr is [.,a,b,c] + if not canReturn(a,0,0,true) and not (BOUNDP '$convert2NewCompiler and $convert2NewCompiler) then + SAY "IF statement can not cause consequents to be executed" + pp expr + canReturn(a,level,exitCount,nil) or canReturn(b,level,exitCount,ValueFlag) + or canReturn(c,level,exitCount,ValueFlag) + --now we have an ordinary form + atom op => and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + op is ["XLAM",args,bods] => + and/[canReturn(u,level,exitCount,ValueFlag) for u in expr] + systemErrorHere '"canReturn" --for the time being + +compList(l,m is ["List",mUnder],e) == + markImport m + markImport mUnder + null l => [NIL,m,e] + Tl:= [[.,mUnder,e]:= + comp(x,mUnder,e) or return "failed" for i in 1.. for x in l] + Tl="failed" => nil + T:= [["LIST",:[T.expr for T in Tl]],["List",mUnder],e] + +compVector(l,m is ["Vector",mUnder],e) == + markImport m + markImport mUnder + null l => [$EmptyVector,m,e] + Tl:= [[.,mUnder,e]:= comp(x,mUnder,e) or return "failed" for x in l] + Tl="failed" => nil + [["VECTOR",:[T.expr for T in Tl]],m,e] + +compColon([":",f,t],m,e) == + $insideExpressionIfTrue=true => compPretend(["pretend",f,t],m,e) + --if inside an expression, ":" means to convert to m "on faith" + f := markKillAll f + $lhsOfColon: local:= f + t:= + t := markKillAll t + atom t and (t':= ASSOC(t,getDomainsInScope e)) => t' + isDomainForm(t,e) and not $insideCategoryIfTrue => + (if not member(t,getDomainsInScope e) then e:= addDomain(t,e); t) + isDomainForm(t,e) or isCategoryForm(t,e) => t + t is ["Mapping",m',:r] => t + unknownTypeError t + t + if $insideCapsuleFunctionIfTrue then markDeclaredImport t + f is ["LISTOF",:l] => + (for x in l repeat T:= [.,.,e]:= compColon([":",x,t],m,e); T) + e:= + f is [op,:argl] and not (t is ["Mapping",:.]) => + --for MPOLY--replace parameters by formal arguments: RDJ 3/83 + newTarget:= EQSUBSTLIST(take(#argl,$FormalMapVariableList), + [(x is [":",a,m] => a; x) for x in argl],t) + signature:= + ["Mapping",newTarget,: + [(x is [":",a,m] => m; + getmode(x,e) or systemErrorHere '"compColonOld") for x in argl]] + put(op,"mode",signature,e) + put(f,"mode",t,e) + if not $bootStrapMode and $insideFunctorIfTrue and + makeCategoryForm(t,e) is [catform,e] then + e:= put(f,"value",[genSomeVariable(),t,$noEnv],e) + ["/throwAway",getmode(f,e),e] + +compConstruct(form,m,e) == (T := compConstruct1(form,m,e)) and markConstruct(form,T) + +compConstruct1(form is ["construct",:l],m,e) == + y:= modeIsAggregateOf("List",m,e) => + T:= compList(l,["List",CADR y],e) => convert(T,m) + y:= modeIsAggregateOf("Vector",m,e) => + T:= compVector(l,["Vector",CADR y],e) => convert(T,m) + T:= compForm(form,m,e) => T + for D in getDomainsInScope e repeat + (y:=modeIsAggregateOf("List",D,e)) and + (T:= compList(l,["List",CADR y],e)) and (T':= convert(T,m)) => + return T' + (y:=modeIsAggregateOf("Vector",D,e)) and + (T:= compVector(l,["Vector",CADR y],e)) and (T':= convert(T,m)) => + return T' + +compPretend(u := ["pretend",x,t],m,e) == + t := markKillAll t + m := markKillAll m + e:= addDomain(t,e) + T:= comp(x,t,e) or comp(x,$EmptyMode,e) or return nil + if T.mode=t then warningMessage:= ["pretend",t," -- should replace by @"] + T1:= [T.expr,t,T.env] + t = "$" and m = "Rep" => markPretend(T1,T1) -->! WATCH OUT: correct? !<-- + T':= coerce(T1,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + markPretend(T1,T') + nil + +compAtSign(["@",x,m'],m,e) == + m' := markKillAll m' + m := markKillAll m + e:= addDomain(m',e) + T:= comp(x,m',e) or return nil + coerce(T,m) + +compColonInside(x,m,e,m') == + m' := markKillAll m' + e:= addDomain(m',e) + T:= comp(x,$EmptyMode,e) or return nil + if T.mode=m' then warningMessage:= [":",m'," -- should replace by ::"] + T:= [T.expr,m',T.env] + m := markKillAll m + T':= coerce(T,m) => + warningMessage => + stackWarning warningMessage + markCompColonInside("@",T') + stackWarning [":",m'," -- should replace by pretend"] + markCompColonInside("pretend",T') + nil + +resolve(min, mout) == + din := markKillAll min + dout := markKillAll mout + din=$NoValueMode or dout=$NoValueMode => $NoValueMode + dout=$EmptyMode => din + STRINGP din and dout = '(Symbol) => dout ------> hack 8/14/94 + STRINGP dout and din = '(Symbol) => din ------> hack 8/14/94 + din^=dout and (STRINGP din or STRINGP dout) => + modeEqual(dout,$String) => dout + modeEqual(din,$String) => nil + mkUnion(din,dout) + dout + +coerce(T,m) == + T := [T.expr,markKillAll T.mode,T.env] + m := markKillAll m + if not get(m, 'isLiteral,T.env) then markImport m + $InteractiveMode => + keyedSystemError("S2GE0016",['"coerce", + '"function coerce called from the interpreter."]) +--==================> changes <====================== +--The following line is inappropriate for our needs::: +--rplac(CADR T,substitute("$",$Rep,CADR T)) + T' := coerce0(T,m) => T' + T := [T.expr,fullSubstitute("$",$Representation,T.mode),T.env] +--==================> changes <====================== + coerce0(T,m) + +coerce0(T,m) == + T':= coerceEasy(T,m) => T' + T':= coerceSubset(T,m) => markCoerce(T,T','AUTOSUBSET) + T':= coerceHard(T,m) => markCoerce(T,T','AUTOHARD) + T':= coerceExtraHard(T,m) => T' + T.expr = "$fromCoerceable$" or isSomeDomainVariable m => nil + T' := coerceRep(T,m) => markCoerce(T,T','AUTOREP) + stackMessage fn(T.expr,T.mode,m) where + -- if from from coerceable, this coerce was just a trial coercion + -- from compFormWithModemap to filter through the modemaps + fn(x,m1,m2) == + ["Cannot coerce","%b",x,"%d","%l"," of mode","%b",m1,"%d","%l", + " to mode","%b",m2,"%d"] + +coerceSubset(T := [x,m,e],m') == + m = $SmallInteger => + m' = $Integer => [x,m',e] + m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] + nil +-- pp [m, m'] + isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] + m is ['SubDomain,=m',:.] => [x,m',e] + (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and + -- obviously this is temporary + eval substitute(x,"#1",pred) => [x,m',e] + (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary + and eval substitute(x,"*",pred) => + [x,m',e] + nil + +coerceRep(T,m) == + md := T.mode + atom md => nil + CONTAINED('Rep,md) and SUBST('$,'Rep,md) = m or + CONTAINED('Rep,m) and SUBST('$,'Rep,m) = md => T + nil + +--- GET rid of XLAMs +spadCompileOrSetq form == + --bizarre hack to take account of the existence of "known" functions + --good for performance (LISPLLIB size, BPI size, NILSEC) + [nam,[lam,vl,body]] := form + CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] + if vl is [:vl',E] and body is [nam',: =vl'] then + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] + else if (ATOM body or and/[ATOM x for x in body]) + and vl is [:vl',E] and not CONTAINED(E,body) then + macform := ['XLAM,vl',body] + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] + $insideCapsuleFunctionIfTrue => first COMP LIST form + compileConstructor form + +coerceHard(T,m) == + $e: local:= T.env + m':= T.mode + STRINGP m' and modeEqual(m,$String) => [T.expr,m,$e] + modeEqual(m',m) or + (get(m',"value",$e) is [m'',:.] or getmode(m',$e) is ["Mapping",m'']) and + modeEqual(m'',m) or + (get(m,"value",$e) is [m'',:.] or getmode(m,$e) is ["Mapping",m'']) and + modeEqual(m'',m') => [T.expr,m,T.env] + STRINGP T.expr and T.expr=m => [T.expr,m,$e] + isCategoryForm(m,$e) => + $bootStrapMode = true => [T.expr,m,$e] + extendsCategoryForm(T.expr,T.mode,m) => [T.expr,m,$e] + nil + nil + +coerceExtraHard(T is [x,m',e],m) == + T':= autoCoerceByModemap(T,m) => T' + isUnionMode(m',e) is ["Union",:l] and (t:= hasType(x,e)) and + member(t,l) and (T':= autoCoerceByModemap(T,t)) and + (T'':= coerce(T',m)) => T'' + m' is ['Record,:.] and m = $Expression => + [['coerceRe2E,x,['ELT,COPY m',0]],m,e] + nil + +compCoerce(u := ["::",x,m'],m,e) == + m' := markKillAll m' + e:= addDomain(m',e) + m := markKillAll m +--------------> new code <------------------- + T:= compCoerce1(x,m',e) => coerce(T,m) + T := comp(x,$EmptyMode,e) or return nil + T.mode = $SmallInteger and + MEMQ(opOf m,'(NonNegativeInteger PositiveInteger)) => + compCoerce(["::",["::",x,$Integer],m'],m,e) +--------------> new code <------------------- + getmode(m',e) is ["Mapping",["UnionCategory",:l]] => + l := [markKillAll x for x in l] + T:= (or/[compCoerce1(x,m1,e) for m1 in l]) or return nil + coerce([T.expr,m',T.env],m) + +compCoerce1(x,m',e) == + T:= comp(x,m',e) + if null T then T := comp(x,$EmptyMode,e) + null T => return nil + m1:= + STRINGP T.mode => $String + T.mode + m':=resolve(m1,m') + T:=[T.expr,m1,T.env] + T':= coerce(T,m') => T' + T':= coerceByModemap(T,m') => T' + pred:=isSubset(m',T.mode,e) => + gg:=GENSYM() + pred:= substitute(gg,"*",pred) + code:= ['PROG1,['LET,gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] + [code,m',T.env] + +coerceByModemap([x,m,e],m') == +--+ modified 6/27 for new runtime system + u:= + [modemap + for (modemap:= [map,cexpr]) in getModemapList("coerce",1,e) | map is [.,t, + s] and (modeEqual(t,m') or isSubset(t,m',e)) + and (modeEqual(s,m) or isSubset(m,s,e))] or return nil + mm:=first u -- patch for non-trival conditons + fn := genDeltaEntry ['coerce,:mm] + T := [["call",fn,x],m',e] + markCoerceByModemap(x,m,m',markCallCoerce(x,m',T),nil) + +autoCoerceByModemap([x,source,e],target) == + u:= + [cexpr + for (modemap:= [map,cexpr]) in getModemapList("autoCoerce",1,e) | map is [ + .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + markCoerceByModemap(x,source,target,[["call",fn,x],target,e],true) + +--====================================================================== +-- From compiler.boot +--====================================================================== +--comp3x(x,m,$e) == + +comp3(x,m,$e) == + --returns a Triple or %else nil to signalcan't do' + $e:= addDomain(m,$e) + e:= $e --for debugging purposes + m is ["Mapping",:.] => compWithMappingMode(x,m,e) + m is ["QUOTE",a] => (x=a => [x,m,$e]; nil) + STRINGP m => (atom x => (m=x or m=STRINGIMAGE x => [m,m,e]; nil); nil) + ^x or atom x => compAtom(x,m,e) + op:= first x + getmode(op,e) is ["Mapping",:ml] and (u:= applyMapping(x,m,e,ml)) => u + op is ["KAPPA",sig,varlist,body] => compApply(sig,varlist,body,rest x,m,e) + op=":" => compColon(x,m,e) + op="::" => compCoerce(x,m,e) + not ($insideCompTypeOf=true) and stringPrefix?('"TypeOf",PNAME op) => + compTypeOf(x,m,e) + ------------special jump out code for PART (don't want $insideExpressionIfTrue=true)-- + x is ['PART,:.] => compPART(x,m,e) + ---------------------------------- + t:= qt(14,compExpression(x,m,e)) + t is [x',m',e'] and not member(m',getDomainsInScope e') => + qt(15,[x',m',addDomain(m',e')]) + qt(16,t) + +yyyyy x == x +compExpression(x,m,e) == + $insideExpressionIfTrue: local:= true + if x is ['LET,['PART,.,w],[['elt,B,'new],['PART,.,["#",['PART,.,l]]],:.],:.] then yyyyy x + x := compRenameOp x + atom first x and (fn:= GETL(first x,"SPECIAL")) => + FUNCALL(fn,x,m,e) + compForm(x,m,e) + +compRenameOp x == ----------> new 12/3/94 + x is [op,:r] and op is ['PART,.,op1] => + [op1,:r] + x + +compCase(["case",x,m1],m,e) == + m' := markKillAll m1 + e:= addDomain(m',e) + T:= compCase1(x,m',e) => coerce(T,m) + nil + +compCase1(x,m,e) == + x1 := + x is ['PART,.,a] => a + x + [x',m',e']:= comp(x1,$EmptyMode,e) or return nil + if m' = "$" then (m' := IFCAR get('Rep,'value,e)) and (switchMode := true) + -------------------------------------------------------------------------- + m' isnt ['Union,:r] => nil + mml := [mm for (mm := [map,cexpr]) in getModemapList("case",2,e') + | map is [.,.,s,t] and modeEqual(t,m) and + (modeEqual(s,m') or switchMode and modeEqual(s,"$"))] + or return nil + u := [cexpr for [.,cexpr] in mml] + fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil + tag := genCaseTag(m, r, 1) or return nil + x1 := + switchMode => markRepper('rep, x) + x + markCase(x, tag, markCaseWas(x1,[["call",fn,x'],$Boolean,e'])) + +genCaseTag(t,l,n) == + l is [x, :l] => + x = t => + STRINGP x => INTERN x + INTERN STRCONC("value", STRINGIMAGE n) + x is ["::",=t,:.] => t + STRINGP x => genCaseTag(t, l, n) + genCaseTag(t, l, n + 1) + nil + +compIf(["IF",aOrig,b,c],m,E) == + a := markKillButIfs aOrig + [xa,ma,Ea,Einv]:= compBoolean(a,aOrig,$Boolean,E) or return nil + [xb,mb,Eb]:= Tb:= compFromIf(b,m,Ea) or return nil + [xc,mc,Ec]:= Tc:= compFromIf(c,resolve(mb,m),Einv) or return nil + xb':= coerce(Tb,mc) or return nil + x:= ["IF",xa,quotify xb'.expr,quotify xc] + (returnEnv:= Env(xb'.env,Ec,xb'.expr,xc,E)) where + Env(bEnv,cEnv,b,c,E) == + canReturn(b,0,0,true) => + (canReturn(c,0,0,true) => intersectionEnvironment(bEnv,cEnv); bEnv) + canReturn(c,0,0,true) => cEnv + E + [x,mc,returnEnv] + +compBoolean(p,pWas,m,Einit) == + op := opOf p + [p',m,E]:= + fop := LASSOC(op,'((and . compAnd) (or . compOr) (not . compNot))) => + APPLY(fop,[p,pWas,m,Einit]) or return nil + T := comp(p,m,Einit) or return nil + markAny('compBoolean,pWas,T) + [p',m,getSuccessEnvironment(markKillAll p,E), + getInverseEnvironment(markKillAll p,E)] + +compAnd([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,e,.] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compAnd,pWas,[["AND",:cargs],$Boolean,e]),m) + +compOr([op,:args], pWas, m, e) == +--called ONLY from compBoolean + cargs := [T.expr for x in args + | [.,.,.,e] := T := compBoolean(x,x,$Boolean,e) or return nil] + null cargs => nil + coerce(markAny('compOr,pWas, [["OR",:cargs],$Boolean,e]),m) + +compNot([op,arg], pWas, m, e) == +--called ONLY from compBoolean + [x,m1,.,ei] := compBoolean(arg,arg,$Boolean,e) or return nil + coerce(markAny('compNot, pWas, [["NOT",x],$Boolean,ei]),m) + +compDefine(form,m,e) == + $tripleHits: local:= 0 + $macroIfTrue: local + $packagesUsed: local + ['DEF,.,originalSignature,.,body] := form + if not $insideFunctorIfTrue then + $originalBody := COPY body + compDefine1(form,m,e) + +compDefine1(form,m,e) == + $insideExpressionIfTrue: local:= false + --1. decompose after macro-expanding form + ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) + => [lhs,m,put(first lhs,'macro,rhs,e)] + null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and + (sig:= getSignatureFromMode(lhs,e)) => + -- here signature of lhs is determined by a previous declaration + compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) + if signature.target=$Category then $insideCategoryIfTrue:= true + if signature.target is ['Mapping,:map] then + signature:= map + form:= ['DEF,lhs,signature,specialCases,rhs] + + +-- RDJ (11/83): when argument and return types are all declared, +-- or arguments have types declared in the environment, +-- and there is no existing modemap for this signature, add +-- the modemap by a declaration, then strip off declarations and recurse + e := compDefineAddSignature(lhs,signature,e) +-- 2. if signature list for arguments is not empty, replace ('DEF,..) by +-- ('where,('DEF,..),..) with an empty signature list; +-- otherwise, fill in all NILs in the signature + not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) + signature.target=$Category => + compDefineCategory(form,m,e,nil,$formalArgList) + isDomainForm(rhs,e) and not $insideFunctorIfTrue => + if null signature.target then signature:= + [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: + rest signature] + rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) + compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, + $formalArgList) + null $form => stackAndThrow ['"bad == form ",form] + newPrefix:= + $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) + getAbbreviation($op,#rest $form) + compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) + +compDefineCategory(df,m,e,prefix,fal) == + $domainShell: local -- holds the category of the object being compiled + $lisplibCategory: local + not $insideFunctorIfTrue and $LISPLIB => + compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) + compDefineCategory1(df,m,e,prefix,fal) + +compDefineCategory1(df,m,e,prefix,fal) == + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $catAddForm : local := nil --for conversion to new compiler 2/95 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $categoryTranForm : local := nil --for conversion to new compiler 10/93 + ['DEF,form,sig,sc,body] := df + body := markKillAll body --these parts will be replaced by compDefineLisplib + categoryCapsule := +--+ + body is ['add,cat,capsule] => + body := cat + capsule + nil + [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) +--+ next two lines +-- if BOUNDP '$convertingSpadFile and $convertingSpadFile then nil +-- else + if categoryCapsule and not $bootStrapMode then + [.,.,e] := + $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 + $categoryPredicateList: local := + makeCategoryPredicates(form,$lisplibCategory) + defform := mkCategoryPackage(form,cat,categoryCapsule) + ['DEF,[.,arg,:.],:.] := defform + $categoryNameForDollar :local := arg + compDefine1(defform,$EmptyMode,e) + else + [body,T] := $categoryTranForm + markFinish(body,T) + + [d,m,e] + +compDefineCategory2(form,signature,specialCases,body,m,e, + $prefix,$formalArgList) == + --1. bind global variables + $insideCategoryIfTrue: local:= true + $TOP__LEVEL: local + $definition: local + --used by DomainSubstitutionFunction + $form: local + $op: local + $extraParms: local + --Set in DomainSubstitutionFunction, used further down +-- 1.1 augment e to add declaration $: + [$op,:argl]:= $definition:= form + e:= addBinding("$",[['mode,:$definition]],e) + +-- 2. obtain signature + signature':= + [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] + e:= giveFormalParametersValues(argl,e) + +-- 3. replace arguments by $1,..., substitute into body, +-- and introduce declarations into environment + sargl:= TAKE(# argl, $TriangleVariableList) + $functorForm:= $form:= [$op,:sargl] + $formalArgList:= [:sargl,:$formalArgList] + aList:= [[a,:sa] for a in argl for sa in sargl] + formalBody:= SUBLIS(aList,body) + signature' := SUBLIS(aList,signature') +--Begin lines for category default definitions + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $frontier: local := 0 + $getDomainCode: local := nil + $addForm: local:= nil + for x in sargl for t in rest signature' repeat + [.,.,e]:= compMakeDeclaration([":",x,t],m,e) + +-- 4. compile body in environment of %type declarations for arguments + op':= $op + -- following line causes cats with no with or Join to be fresh copies + if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then + formalBody := ['Join, formalBody] + T := compOrCroak(formalBody,signature'.target,e) +--------------------> new <------------------- + $catAddForm := + $originalBody is ['add,y,:.] => y + $originalBody + $categoryTranForm := [$originalBody,[$form,['Mapping,:signature'],T.env]] +--------------------> new <------------------- + body:= optFunctorBody markKillAll T.expr + if $extraParms then + formals:=actuals:=nil + for u in $extraParms repeat + formals:=[CAR u,:formals] + actuals:=[MKQ CDR u,:actuals] + body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] + if argl then body:= -- always subst for args after extraparms + ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: + [['devaluate,u] for u in sargl]]],body] + body:= + ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $functorForm]] + fun:= compile [op',['LAM,sargl,body]] + +-- 5. give operator a 'modemap property + pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] + parSignature:= SUBLIS(pairlis,signature') + parForm:= SUBLIS(pairlis,form) +---- lisplibWrite('"compilerInfo", +---- ['SETQ,'$CategoryFrame, +---- ['put,['QUOTE,op'],' +---- (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, +---- MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) + --Equivalent to the following two lines, we hope + if null sargl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) + +-- 6. put modemaps into InteractiveModemapFrame + $domainShell := + BOUNDP '$convertingSpadFile and $convertingSpadFile => nil + eval [op',:MAPCAR('MKQ,sargl)] + $lisplibCategory:= formalBody +---- if $LISPLIB then +---- $lisplibForm:= form +---- $lisplibKind:= 'category +---- modemap:= [[parForm,:parSignature],[true,op']] +---- $lisplibModemap:= modemap +---- $lisplibCategory:= formalBody +---- form':=[op',:sargl] +---- augLisplibModemapsFromCategory(form',formalBody,signature') + [fun,'(Category),e] +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot deleted file mode 100644 index 3842101e..00000000 --- a/src/interp/wi2.boot +++ /dev/null @@ -1,1229 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -)package "BOOT" - -compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == - ['DEF,form,signature,$functorSpecialCases,body] := df - signature := markKillAll signature - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local - $viewNames: local:= nil - - --This list is only used in genDomainViewName, for generating names - --for alternate views, if they do not already exist. - --format: Alist: (domain name . sublist) - --sublist is alist: category . name of view - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $DEFdepth : local := 0 --for conversion to new compiler 3/93 - $capsuleStack : local := nil --for conversion to new compiler 3/93 - $predicateStack:local := nil --for conversion to new compiler 3/93 - $signatureStack:local := nil --for conversion to new compiler 3/93 - $importStack : local := nil --for conversion to new compiler 3/93 - $globalImportStack : local := nil --for conversion to new compiler 3/93 - $globalDeclareStack : local := nil - $globalImportDefAlist: local:= nil - $localMacroStack : local := nil --for conversion to new compiler 3/93 - $freeStack : local := nil --for conversion to new compiler 3/93 - $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 - $localLoopVariables: local := nil - $pathStack : local := nil - $form: local - $op: local - $signature: local - $functorTarget: local - $Representation: local - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist:= nil - $functorForm: local - $functorLocalParameters: local - $CheckVectorList: local - --prevents CheckVector from printing out same message twice - $getDomainCode: local -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local - $genSDVar: local:= 0 - originale:= $e - [$op,:argl]:= form - $formalArgList:= [:argl,:$formalArgList] - $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] - $mutableDomain: local := - -- all defaulting packages should have caching turned off - isCategoryPackageName $op or - (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) - else false ) --true if domain has mutable state - signature':= - [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] - $functorForm:= $form:= [$op,:argl] - $globalImportStack := - [markKillAll x for x in rest $functorForm for typ in rest signature' - | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] - if null first signature' then signature':= - modemap2Signature getModemap($form,$e) - target:= first signature' - $functorTarget:= target - $e:= giveFormalParametersValues(argl,$e) - [ds,.,$e]:= compMakeCategoryObject(target,$e) or ---+ copy needed since slot1 is reset; compMake.. can return a cached vector - sayBrightly '" cannot produce category object:" - pp target - return nil - $domainShell:= COPY_-SEQ ds - $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") - attributeList := ds.2 --see below under "loadTimeAlist" ---+ 7 lines for $NRT follow - $goGetList: local := nil --->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 - $condAlist: local := nil - $uncondAlist: local := nil --->>-- next global initialized here, reset by NRTbuildFunctor - $NRTslot1PredicateList: local := - REMDUP [CADR x for x in attributeList] --->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) - $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList - $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor - --this is used below to set $lisplibSlot1 global - $NRTbase: local := 6 -- equals length of $domainShell - $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 - $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts - $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList - $NRTaddList: local := nil --list of fncts not defined in capsule (added) - $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector - $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) - $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... - -- the above optimizes the calls to local domains - $template: local:= nil --stored in the lisplib (if $NRTvec = true) - $functionLocations: local := nil --locations of defined functions in source - -- generate slots for arguments first, then for $NRTaddForm in compAdd - for x in argl repeat NRTgetLocalIndex x - [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD - if $insideCategoryPackageIfTrue^= true then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [['LET,'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) - $signature:= signature' - operationAlist:= SUBLIS($pairlis,$domainShell.(1)) - parSignature:= SUBLIS($pairlis,signature') - parForm:= SUBLIS($pairlis,form) - --- (3.1) now make a list of the functor's local parameters; for --- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); --- in this case, D is replaced by D1,..,Dn (gensyms) which are set --- to the A1,..,An view of D - if isPackageFunction() then $functorLocalParameters:= - [nil,: - [nil - for i in 6..MAXINDEX $domainShell | - $domainShell.i is [.,.,['ELT,'_$,.]]]] - --leave space for vector ops and package name to be stored ---+ - $functorLocalParameters:= - argPars := - makeFunctorArgumentParameters(argl,rest signature',first signature') - -- must do above to bring categories into scope --see line 5 of genDomainView - argl --- 4. compile body in environment of %type declarations for arguments - op':= $op - rettype:= signature'.target - SETQ($myFunctorBody, body) --------> new <-------- - T:= compFunctorBody(body,rettype,$e,parForm) ----------------> new <--------------------- - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) ----------------> new <--------------------- - -- If only compiling certain items, then ignore the body shell. - $compileOnlyCertainItems => - reportOnFunctorCompilation() - [nil, ['Mapping, :signature'], originale] - - body':= T.expr - lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM - fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) - --The above statement stops substitutions gettting in one another's way ---+ - operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) - if $LISPLIB then - augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) - reportOnFunctorCompilation() - --- 5. give operator a 'modemap property --- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - if null $bootStrapMode then - $NRTslot1Info := NRTmakeSlot1Info() - $isOpPackageName: local := isCategoryPackageName $op - if $isOpPackageName then lisplibWrite('"slot1DataBase", - ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) - $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) - $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) - -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended - libFn := getConstructorAbbreviation op' - $lookupFunction: local := - NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) - --either lookupComplete (for forgetful guys) or lookupIncomplete - $byteAddress :local := 0 - $byteVec :local := nil - $NRTslot1PredicateList := - [simpBool x for x in $NRTslot1PredicateList] - rwriteLispForm('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) - $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 - $lisplibOperationAlist:= operationAlist - $lisplibMissingFunctions:= $CheckVectorList - lisplibWrite('"compilerInfo", - ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isFunctor), - ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' - QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], - ['put,['QUOTE,op' ],'(QUOTE mode), - ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) - if null argl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) - [fun,['Mapping,:signature'],originale] - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local - target := markKillAll target - ("append"/[fn(a,augmentSig(s,findExtras(a,target))) - for a in argl for s in sigl]) where - findExtras(a,target) == - -- see if conditional information implies anything else - -- in the signature of a - target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] - target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where - findExtras1(a,x) == - x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['IF,c,p,q] => - union(findExtrasP(a,c), - union(findExtras1(a,p),findExtras1(a,q))) where - findExtrasP(a,x) == - x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] - nil - nil - augmentSig(s,ss) == - -- if we find something extra, add it to the signature - null ss => s - for u in ss repeat - $ConditionalOperators:=[CDR u,:$ConditionalOperators] - s is ['Join,:sl] => - u:=ASSQ('CATEGORY,ss) => - SUBST([:u,:ss],u,s) - ['Join,:sl,['CATEGORY,'package,:ss]] - ['Join,s,['CATEGORY,'package,:ss]] - fn(a,s) == - isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList0(a,rest s) - [genDomainView(a,a,s,"getDomainView")] - [a] - -compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == - ['DEF,form,originalSignature,specialCases,body] := df - signature := markKillAll originalSignature - $markFreeStack: local := nil --holds "free variables" - $localImportStack : local := nil --local import stack for function - $localDeclareStack: local := nil - $localLoopVariables: local := nil - originalDef := COPY df - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null member($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not member($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] ----------------------> new <--------------------------------- - returnType := signature'.target --- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) - trialT := returnType = "$" and comp(body,$EmptyMode,e) - ------------------------------------------------------ 11/1/94 - -- try comp-ing in $EmptyMode; if succeed - -- if we succeed then trialT.mode = "$" or "Rep" - -- do a coerce to get the correct result - T := (trialT and coerce(trialT,returnType)) - -------------------------------------- 11/1/94 - or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) - markChanges(originalDef,T,$signatureOfForm) - [nil,['Mapping,:signature'],oldE] - --------------------------------- - -compCapsuleInner(itemList,m,e) == - e:= addInformation(m,e) - --puts a new 'special' property of $Information - data:= ["PROGN",:itemList] - --RPLACd by compCapsuleItems and Friends - e:= compCapsuleItems(itemList,nil,e) - BOUNDP '$convert2NewCompiler and $convert2NewCompiler => - [nil,m,e] --nonsense but that's fine - localParList:= $functorLocalParameters - if $addForm then data:= ['add,$addForm,data] - code:= - $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data - processFunctorOrPackage($form,$signature,data,localParList,m,e) - [MKPF([:$getDomainCode,code],"PROGN"),m,e] - -compSingleCapsuleItem(item,$predl,$e) == - $localImportStack : local := nil - $localDeclareStack: local := nil - $markFreeStack: local := nil - newItem := macroExpandInPlace(item,qe(25,$e)) - qe(26,$e) - doIt(newItem, $predl) - qe(27,$e) - $e - -compImport(["import",:doms],m,e) == - for dom in doms repeat - dom := markKillAll dom - markImport dom - e:=addDomain(dom,e) - ["/throwAway",$NoValueMode,e] - -mkUnion(a,b) == - b="$" and $Rep is ["Union",:l] => b - a is ["Union",:l] => - b is ["Union",:l'] => ["Union",:setUnion(l,l')] - member(b, l) => a - ["Union",:setUnion([b],l)] - b is ["Union",:l] => - member(a, l) => b - ["Union",:setUnion([a],l)] - STRINGP a => ["Union",b,a] - ["Union",a,b] - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - $convert2NewCompiler: local := nil - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - c := markKillAll c - u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] - nil - -macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) - x is ['DEF,lhs,sig,spCases,rhs] => - ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), - macroExpand(rhs,e)] - x is ['MI,a,b] => - ['MI,a,macroExpand(b,e)] - macroExpandList(x,e) - -getSuccessEnvironment(a,e) == - -- the next four lines try to ensure that explicit special-case tests - -- prevent implicit ones from being generated - a is ["has",x,m] => - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) - e - a is ["is",id,m] => - id := unLet id - IDENTP id and isDomainForm(m,$EmptyEnvironment) => - e:=put(id,"specialCase",m,e) - currentProplist:= getProplist(id,e) - [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs - newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) - addBinding(id,newProplist,e) - e - a is ["case",x,m] and (x := unLet x) and IDENTP x => - put(x,"condition",[a,:get(x,"condition",e)],e) - e - -getInverseEnvironment(a,E) == - atom a => E - [op,:argl]:= a --- the next five lines try to ensure that explicit special-case tests --- prevent implicit ones from being generated - op="has" => - [x,m]:= argl - x := unLet x - IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) - E - a is ["case",x,m] and (x := unLet x) and IDENTP x => - --the next two lines are necessary to get 3-branched Unions to work - -- old-style unions, that is - if corrupted? get(x,"condition",E) then systemError 'condition - (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => - put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) - getUnionMode(x,E) is ["Union",:l] or systemError 'Union - if corrupted? l then systemError 'list - l':= delete(m,l) - for u in l' repeat - if u is ['_:,=m,:.] then l':= delete(u,l') - newpred:= MKPF([["case",x,m'] for m' in l'],"OR") - put(x,"condition",[newpred,:get(x,"condition",E)],E) - E - -unLet x == - x is ['LET,u,:.] => unLet u - x - -corrupted? u == - u is [op,:r] => - MEMQ(op,'(WI MI PART)) => true - or/[corrupted? x for x in r] - false - ---====================================================================== --- From apply.boot ---====================================================================== -applyMapping([op,:argl],m,e,ml) == - #argl^=#ml-1 => nil - isCategoryForm(first ml,e) => - --is op a functor? - pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] - ml' := SUBLIS(pairlis, ml) - argl':= - [T.expr for x in argl for m' in rest ml'] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= [op,:argl'] ----------------------> new <---------------------------- - if constructor? op then form := markKillAll form ----------------------> new <---------------------------- - convert([form,first ml',e],m) - argl':= - [T.expr for x in argl for m' in rest ml] where - T() == [.,.,e]:= comp(x,m',e) or return "failed" - if argl'="failed" then return nil - form:= - not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => - nprefix := $prefix or - -- following needed for referencing local funs at capsule level - getAbbreviation($op,#rest $form) - [op',:argl',"$"] where - op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) - ['call,['applyFun,op],:argl'] - pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] - convert([form,SUBLIS(pairlis,first ml),e],m) - -compFormWithModemap(form,m,e,modemap) == - compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) - -compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == - [op,:argl] := form := markKillExpr form - [[dc,:.],:.] := modemap -----------> new: <----------- - if Rep2Dollar? then - if dc = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) - else return nil -----------> new: <----------- - [map:= [.,target,:.],[pred,impl]]:= modemap - -- this fails if the subsuming modemap is conditional - --impl is ['Subsumed,:.] => nil - if isCategoryForm(target,e) and isFunctor op then - [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil - [map:= [.,target,:.],:cexpr]:= modemap - sv:=listOfSharpVars map - if sv then - -- SAY [ "compiling ", op, " in compFormWithModemap, - -- mode= ",map," sharp vars=",sv] - for x in argl for ss in $FormalMapVariableList repeat - if ss in sv then - [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) - -- SAY ["new map is",map] - not (target':= coerceable(target,m,e)) => nil - markMap := map - map:= [target',:rest map] - [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil - - --generate code; return - T:= - e':= - Tl => (LAST Tl).env - e - [x',m',e'] where - m':= SUBLIS(sl,map.(1)) - x':= - form':= [f,:[t.expr for t in Tl]] - m'=$Category or isCategoryForm(m',e) => form' - -- try to deal with new-style Unions where we know the conditions - op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and - (c:=get(z,'condition,e)) and - c is [['case,=z,c1]] and - (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => --- first is a full tag, as placed by getInverseEnvironment --- second is what getSuccessEnvironment will place there - ["CDR",z] - markTran(form,form',markMap,e') - qt(18,T) - convert(T,m) - -convert(T,m) == - tcheck T - qe(23,T.env) - coerce(T,resolve(T.mode,m) or return nil) - -compElt(origForm,m,E) == - form := markKillAll origForm - form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) - aDomain="Lisp" => - markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) - isDomainForm(aDomain,E) => - markImport opOf aDomain - E:= addDomain(aDomain,E) - mmList:= getModemapListFromDomain(anOp,0,aDomain,E) - modemap:= - n:=#mmList - 1=n => mmList.(0) - 0=n => - return - stackMessage ['"Operation ","%b",anOp,"%d", - '"missing from domain: ", aDomain] - stackWarning ['"more than 1 modemap for: ",anOp, - '" with dc=",aDomain,'" ===>" - ,mmList] - mmList.(0) -----------> new: <----------- - if aDomain = 'Rep then - modemap := SUBST('Rep,'_$,modemap) - m := SUBST('Rep,'_$,m) -----------> new: <----------- - [sig,[pred,val]]:= modemap - #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? ---+ - val := genDeltaEntry [opOf anOp,:modemap] - x := markTran(origForm,[val],sig,[E]) - [x,first rest sig,E] --implies fn calls used to access constants - compForm(origForm,m,E) - -pause op == op -compApplyModemap(form,modemap,$e,sl) == - [op,:argl] := form --form to be compiled - [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing - - -- $e is the current environment - -- sl substitution list, nil means bottom-up, otherwise top-down - - -- 0. fail immediately if #argl=#margl - - if #argl^=#margl then return nil - - -- 1. use modemap to evaluate arguments, returning failed if - -- not possible - - lt:= - [[.,m',$e]:= - comp(y,g,$e) or return "failed" where - g:= SUBLIS(sl,m) where - sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] - lt="failed" => return nil - - -- 2. coerce each argument to final domain, returning failed - -- if not possible - - lt':= [coerce(y,d) or return "failed" - for y in lt for d in SUBLIS(sl,margl)] - lt'="failed" => return nil - - -- 3. obtain domain-specific function, if possible, and return - - --$bindings is bound by compMapCond - [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil - ---+ can no longer trust what the modemap says for a reference into ---+ an exterior domain (it is calculating the displacement based on view ---+ information which is no longer valid; thus ignore this index and ---+ store the signature instead. - ---$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => - f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => - [genDeltaEntry [op,:modemap],lt',$bindings] - markImport mc - [f,lt',$bindings] - -compMapCond''(cexpr,dc) == - cexpr=true => true - --cexpr = "true" => true ----------------> new <---------------------- - cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] - cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] ----------------> new <---------------------- - cexpr is ["not",u] => not compMapCond''(u,dc) - cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) - --for the time being we'll stop here - shouldn't happen so far - --$disregardConditionIfTrue => true - --stackSemanticError(("not known that",'%b,name, - -- '%d,"has",'%b,cat,'%d),nil) - --now it must be an attribute - member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true - --for the time being we'll stop here - shouldn't happen so far - stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] - false - ---====================================================================== --- From nruncomp.boot ---====================================================================== -NRTgetLocalIndex1(item,killBindingIfTrue) == - k := NRTassocIndex item => k - item = $NRTaddForm => 5 - item = '$ => 0 - item = '_$_$ => 2 - value:= - MEMQ(item,$formalArgList) => item - nil - atom item and null MEMQ(item,'($ _$_$)) - and null value => --give slots to atoms - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - $NRTdeltaListComp:=[item,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - $NRTbase + $NRTdeltaLength - 1 - $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - saveIndex := $NRTbase + $NRTdeltaLength - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= item - ----94/11/07 - -- WAS: compOrCroak(item,$EmptyMode,$e).expr - RPLACA(saveNRTdeltaListComp,compEntry) - saveIndex - -optDeltaEntry(op,sig,dc,eltOrConst) == - return nil --------> kill it - $killOptimizeIfTrue = true => nil - ndc := - dc = '$ => $functorForm - atom dc and (dcval := get(dc,'value,$e)) => dcval.expr - dc ---if (atom dc) and (dcval := get(dc,'value,$e)) --- then ndc := dcval.expr --- else ndc := dc - sig := SUBST(ndc,dc,sig) - not MEMQ(KAR ndc,$optimizableConstructorNames) => nil - dcval := optCallEval ndc - -- MSUBST guarantees to use EQUAL testing - sig := MSUBST(devaluate dcval, ndc, sig) - if rest ndc then - for new in rest devaluate dcval for old in rest ndc repeat - sig := MSUBST(new,old,sig) - -- optCallEval sends (List X) to (LIst (Integer)) etc, - -- so we should make the same transformation - fn := compiledLookup(op,sig,dcval) - if null fn then - -- following code is to handle selectors like first, rest - nsig := [quoteSelector tt for tt in sig] where - quoteSelector(x) == - not(IDENTP x) => x - get(x,'value,$e) => x - x='$ => x - MKQ x - fn := compiledLookup(op,nsig,dcval) - if null fn then return nil - eltOrConst="CONST" => - hehe fn - [op] -----------> return just the op here --- ['XLAM,'ignore,MKQ SPADCALL fn] - GETL(compileTimeBindingOf first fn,'SPADreplace) - -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair - if $profileCompiler = true then - profileRecord(dc,op,sig) --- markImport dc - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - -- following hack needed to invert Rep to $ substitution - if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(sig,dc),consDomainForm(dc,nil)]] - --if null atom dc then - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (member(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= - dc - RPLACA(saveNRTdeltaListComp,compEntry) - chk(saveNRTdeltaListComp,102) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - ---====================================================================== --- From nruncomp.boot ---====================================================================== -parseIf t == - t isnt [p,a,b] => t - ifTran(parseTran p,parseTran a,parseTran b) where - ifTran(p,a,b) == - null($InteractiveMode) and p='true => a - null($InteractiveMode) and p='false => b - p is ['not,p'] => ifTran(p',b,a) - p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) - p is ['SEQ,:l,['exit,1,p']] => - ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] - --this assumes that l has no exits - a is ['IF, =p,a',.] => ['IF,p,a',b] - b is ['IF, =p,.,b'] => ['IF,p,a,b'] --- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => --- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] - ['IF,p,a,b] - ---====================================================================== --- From parse.boot ---====================================================================== -parseNot u == ['not,parseTran first u] - -makeSimplePredicateOrNil p == nil - ---====================================================================== --- From g-cndata.boot ---====================================================================== -mkUserConstructorAbbreviation(c,a,type) == - if $AnalyzeOnly or $convert2NewCompiler then - $abbreviationStack := [[type,a,:c],:$abbreviationStack] - if not atom c then c:= CAR c -- Existing constructors will be wrapped - constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) - clearClams() - clearConstructorCache(c) - installConstructor(c,type) - setAutoLoadProperty(c) - ---====================================================================== --- From iterator.boot ---====================================================================== - -compreduce(form is [.,op,x],m,e) == - T := compForm(form,m,e) or return nil - y := T.expr - RPLACA(y,"REDUCE") - ------------------<== distinquish this as the special reduce form - (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and - # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) - T - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == --------------------------------> 11/28 all new to preserve collect forms - markImport m - [collectOp,:itl,body]:= collectForm - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - T0 := comp0(body,m,e) or return nil - md := T0.mode - T1 := compOrCroak(collectForm,["List",md],e) - T := [["REDUCE",op,nil,T1.expr],md,T1.env] - markReduce(form,T) - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - ---------------> new <--------------------- - [y',m,e] := markInValue(y, e) - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return - stackMessage ["mode: ",m," must be a list or vector of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - markReduceIn(it, [["IN",x,y'],e]) - it is ["ON",x,y] => ----------------> new <--------------------- - x := markKillAll x - ------------------ - $formalArgList:= [x,:$formalArgList] - y := markKillAll y - markImport m ----------------> new <--------------------- - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [.,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [["ON",x,y'],e] - it is ["STEP",oindex,start,inc,:optFinal] => - index := markKillAll oindex - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil ----------------> new <--------------------- - u := smallIntegerStep(it,index,start,inc,optFinal,e) => u ----------------> new <--------------------- - [start,.,e]:= - comp(markKillAll start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(markKillAll inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(markKillAll final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer --- markImport ['Segment,indexmode] - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - markReduceWhile(it, [["WHILE",p'],e]) - it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - markReduceSuchthat(it, [["|",u.expr],u.env]) - nil - -smallIntegerStep(it,index,start,inc,optFinal,e) == - start := markKillAll start - inc := markKillAll inc - optFinal := markKillAll optFinal - startNum := source2Number start - incNum := source2Number inc - mode := get(index,"mode",e) ---fail if -----> a) index has a mode that is not $SmallInteger -----> b) one of start,inc, final won't comp as a $SmallInteger - mode and mode ^= $SmallInteger => nil - null (start':= comp(start,$SmallInteger,e)) => nil - null (inc':= comp(inc,$SmallInteger,start'.env)) => nil - if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then --- not (FIXP startNum and FIXP incNum) => return nil --- null FIXP startNum or ABSVAL startNum > 100 => return nil - -----> assume that optFinal is $SmallInteger - T := comp(final,$EmptyMode,inc'.env) or return nil - final' := T - maxSuperType(T.mode,e) ^= $Integer => return nil - givenRange := T.mode - indexmode:= $SmallInteger - [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - range := - FIXP startNum and FIXP incNum => - startNum > 0 and incNum > 0 => $PositiveInteger - startNum < 0 and incNum < 0 => $NegativeInteger - incNum > 0 => $NonNegativeInteger --startNum = 0 - $NonPositiveInteger - givenRange => givenRange - nil - e:= put(index,"range",range,e) - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - noptFinal := - final' => - [final'.expr] - nil - [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] - -source2Number n == - n := markKillAll n - n = $Zero => 0 - n = $One => 1 - n - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack --- pp '"---------" --- pp targetMode - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= T := - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - markRepeatBody(body, T) - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' ---------> new <-------------- - markImport m'' ---------> new <-------------- - markRepeat(form,coerceExit([form',m'',e'],targetMode)) - -chaseInferences(origPred,$e) == - pred := markKillAll origPred - ----------------------------12/4/94 do this immediately - foo hasToInfo pred where - foo pred == - knownInfo pred => nil - $e:= actOnInfo(pred,$e) - pred:= infoToHas pred - for u in get("$Information","special",$e) repeat - u is ["COND",:l] => - for [ante,:conseq] in l repeat - ante=pred => [foo w for w in conseq] - ante is ["and",:ante'] and member(pred,ante') => - ante':= delete(pred,ante') - v':= - LENGTH ante'=1 => first ante' - ["and",:ante'] - v':= ["COND",[v',:conseq]] - member(v',get("$Information","special",$e)) => nil - $e:= - put("$Information","special",[v',: - get("$Information","special",$e)],$e) - nil - $e - ---====================================================================== --- doit Code ---====================================================================== -doIt(item,$predl) == - $GENNO: local:= 0 - $coerceList: local := nil - ---> - if item is ['PART,.,a] then item := a - ------------------------------------- - item is ['SEQ,:.] => doItSeq item - isDomainForm(item,$e) => doItDomain item - item is ['LET,:.] => doItLet item - item is [":",a,t] => [.,.,$e]:= - markDeclaredImport markKillAll t - compOrCroak(item,$EmptyMode,$e) - item is ['import,:doms] => - item := ['import,:(doms := markKillAll doms)] - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - wiReplaceNode(item,'(PROGN),10) - item is ["IF",:.] => doItIf(item,$predl,$e) - item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) - item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['DEF,:.] => doItDef item - T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) - true => cannotDo() - -holdIt item == item - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then ---> new <----------------------- - qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) ----> new ----------- - x':=localExtras(oldFLP) - where localExtras(oldFLP) == - EQ(oldFLP,$functorLocalParameters) => NIL - flp1:=$functorLocalParameters - oldFLP':=oldFLP - n:=0 - while oldFLP' repeat - oldFLP':=CDR oldFLP' - flp1:=CDR flp1 - n:=n+1 - -- Now we have to add code to compile all the elements - -- of functorLocalParameters that were added during the - -- conditional compilation - nils:=ans:=[] - for u in flp1 repeat -- is =u form always an ATOM? - if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) - then - nils:=[u,:nils] - else - gv := GENSYM() - ans:=[['LET,gv,u],:ans] - nils:=[gv,:nils] - n:=n+1 - - $functorLocalParameters:=[:oldFLP,:REVERSE nils] - REVERSE ans - oldFLP:=$functorLocalParameters - if y^="noBranch" then ---> new <----------------------- - qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) ---> ----------- - y':=localExtras(oldFLP) - wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) - -doItSeq item == - ['SEQ,:l,['exit,1,x]] := item - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - -doItDomain item == - -- convert naked top level domains to import - u:= ['import, [first item,:rest item]] - markImport CADR u - stackWarning ["Use: import ", [first item,:rest item]] ---wiReplaceNode(item, u, 14) - RPLACA(item, first u) - RPLACD(item, rest u) - doIt(item,$predl) - -doItLet item == - qe(3,$e) - res := doItLet1 item - qe(4,$e) - res - -doItLet1 item == - ['LET,lhs,rhs,:.] := item - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - qe(5,$e) - code := markKillAll code - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - wiReplaceNode(item, code, 24) - lhs:= lhs' - if not member(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if (rhs' := rhsOfLetIsDomainForm code) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] - if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).(0) - --$Representation bound by compDefineFunctor, used in compNoStacking ---+ - if $NRTopt = true - then NRTgetLocalIndex $Representation ---+ - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] ---+ - qe(6,$e) - code is ['LET,:.] => - rhsCode:= rhs' - op := ($QuickCode => 'QSETREFV;'SETELT) - wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) - wiReplaceNode(item, code, 18) - -rhsOfLetIsDomainForm code == - code is ['LET,.,rhs',:.] => - isDomainForm(rhs',$e) => rhs' - isDomainForm(rhs' := markKillAll rhs',$e) => rhs' - false - false - -doItDef item == - ['DEF,[op,:.],:.] := item - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - chk(item,3) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - chk(item,4) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - wiReplaceNode(CDDR item,[functionPart], 20) - chk(item, 30) - -doItExpression(item,T) == - SETQ($ITEM,COPY item) - SETQ($T1,COPY T.expr) - chk(T.expr, 304) - u := markCapsuleExpression(item, T) - [code,.,$e]:= u - wiReplaceNode(item,code, 22) - -wiReplaceNode(node,ocode,key) == - ncode := CONS(first ocode, rest ocode) - code := replaceNodeInStructureBy(node,ncode) - SETQ($NODE,COPY node) - SETQ($NODE1, COPY first code) - SETQ($NODE2, COPY rest code) - RPLACA(node,first code) - RPLACD(node,rest code) - chk(code, key) - chk(node, key + 1) - -replaceNodeInStructureBy(node, x) == - $nodeCopy: local := [CAR node,:CDR node] - replaceNodeBy(node, x) - node - -replaceNodeBy(node, x) == - atom x => nil - for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) - nil - -chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == - cnt > 10000 => - sayBrightly ["--> ", key, " <---"] - hahaha(key) - atom x => cnt - VECP x => systemError nil - for y in x repeat cnt := fn(y, cnt + 1, key) - cnt - diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet new file mode 100644 index 00000000..e4dd5a8a --- /dev/null +++ b/src/interp/wi2.boot.pamphlet @@ -0,0 +1,1255 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/wi2.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject + +\section{License} + +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +)package "BOOT" + +compDefineFunctor1(df, m,$e,$prefix,$formalArgList) == + ['DEF,form,signature,$functorSpecialCases,body] := df + signature := markKillAll signature + if NRTPARSE = true then + [lineNumber,:$functorSpecialCases] := $functorSpecialCases +-- 1. bind global variables + $addForm: local + $viewNames: local:= nil + + --This list is only used in genDomainViewName, for generating names + --for alternate views, if they do not already exist. + --format: Alist: (domain name . sublist) + --sublist is alist: category . name of view + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $DEFdepth : local := 0 --for conversion to new compiler 3/93 + $capsuleStack : local := nil --for conversion to new compiler 3/93 + $predicateStack:local := nil --for conversion to new compiler 3/93 + $signatureStack:local := nil --for conversion to new compiler 3/93 + $importStack : local := nil --for conversion to new compiler 3/93 + $globalImportStack : local := nil --for conversion to new compiler 3/93 + $globalDeclareStack : local := nil + $globalImportDefAlist: local:= nil + $localMacroStack : local := nil --for conversion to new compiler 3/93 + $freeStack : local := nil --for conversion to new compiler 3/93 + $domainLevelVariableList: local := nil--for conversion to new compiler 3/93 + $localLoopVariables: local := nil + $pathStack : local := nil + $form: local + $op: local + $signature: local + $functorTarget: local + $Representation: local + --Set in doIt, accessed in the compiler - compNoStacking + $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry + $LocalDomainAlist:= nil + $functorForm: local + $functorLocalParameters: local + $CheckVectorList: local + --prevents CheckVector from printing out same message twice + $getDomainCode: local -- code for getting views + $insideFunctorIfTrue: local:= true + $functorsUsed: local --not currently used, finds dependent functors + $setelt: local := + $QuickCode = true => 'QSETREFV + 'SETELT + $TOP__LEVEL: local + $genSDVar: local:= 0 + originale:= $e + [$op,:argl]:= form + $formalArgList:= [:argl,:$formalArgList] + $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] + $mutableDomain: local := + -- all defaulting packages should have caching turned off + isCategoryPackageName $op or + (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) + else false ) --true if domain has mutable state + signature':= + [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] + $functorForm:= $form:= [$op,:argl] + $globalImportStack := + [markKillAll x for x in rest $functorForm for typ in rest signature' + | GETDATABASE(opOf typ,'CONSTRUCTORKIND) = 'category] + if null first signature' then signature':= + modemap2Signature getModemap($form,$e) + target:= first signature' + $functorTarget:= target + $e:= giveFormalParametersValues(argl,$e) + [ds,.,$e]:= compMakeCategoryObject(target,$e) or +--+ copy needed since slot1 is reset; compMake.. can return a cached vector + sayBrightly '" cannot produce category object:" + pp target + return nil + $domainShell:= COPY_-SEQ ds + $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") + attributeList := ds.2 --see below under "loadTimeAlist" +--+ 7 lines for $NRT follow + $goGetList: local := nil +-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 + $condAlist: local := nil + $uncondAlist: local := nil +-->>-- next global initialized here, reset by NRTbuildFunctor + $NRTslot1PredicateList: local := + REMDUP [CADR x for x in attributeList] +-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) + $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList + $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor + --this is used below to set $lisplibSlot1 global + $NRTbase: local := 6 -- equals length of $domainShell + $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 + $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts + $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList + $NRTaddList: local := nil --list of fncts not defined in capsule (added) + $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector + $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) + $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... + -- the above optimizes the calls to local domains + $template: local:= nil --stored in the lisplib (if $NRTvec = true) + $functionLocations: local := nil --locations of defined functions in source + -- generate slots for arguments first, then for $NRTaddForm in compAdd + for x in argl repeat NRTgetLocalIndex x + [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) + --The following loop sees if we can economise on ADDed operations + --by using those of Rep, if that is the same. Example: DIRPROD + if $insideCategoryPackageIfTrue^= true then + if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) + and FindRep(cb) = ab + where FindRep cb == + u:= + while cb repeat + ATOM cb => return nil + cb is [['LET,'Rep,v,:.],:.] => return (u:=v) + cb:=CDR cb + u + then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) + else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) + $signature:= signature' + operationAlist:= SUBLIS($pairlis,$domainShell.(1)) + parSignature:= SUBLIS($pairlis,signature') + parForm:= SUBLIS($pairlis,form) + +-- (3.1) now make a list of the functor's local parameters; for +-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); +-- in this case, D is replaced by D1,..,Dn (gensyms) which are set +-- to the A1,..,An view of D + if isPackageFunction() then $functorLocalParameters:= + [nil,: + [nil + for i in 6..MAXINDEX $domainShell | + $domainShell.i is [.,.,['ELT,'_$,.]]]] + --leave space for vector ops and package name to be stored +--+ + $functorLocalParameters:= + argPars := + makeFunctorArgumentParameters(argl,rest signature',first signature') + -- must do above to bring categories into scope --see line 5 of genDomainView + argl +-- 4. compile body in environment of %type declarations for arguments + op':= $op + rettype:= signature'.target + SETQ($myFunctorBody, body) --------> new <-------- + T:= compFunctorBody(body,rettype,$e,parForm) +---------------> new <--------------------- + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + return markFinish($originalBody,[$form,['Mapping,:signature'],T.env]) +---------------> new <--------------------- + -- If only compiling certain items, then ignore the body shell. + $compileOnlyCertainItems => + reportOnFunctorCompilation() + [nil, ['Mapping, :signature'], originale] + + body':= T.expr + lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM + fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) + --The above statement stops substitutions gettting in one another's way +--+ + operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) + if $LISPLIB then + augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) + reportOnFunctorCompilation() + +-- 5. give operator a 'modemap property +-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) + $insideFunctorIfTrue:= false + if $LISPLIB then + $lisplibKind:= + $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package + 'domain + $lisplibForm:= form + modemap:= [[parForm,:parSignature],[true,op']] + $lisplibModemap:= modemap + if null $bootStrapMode then + $NRTslot1Info := NRTmakeSlot1Info() + $isOpPackageName: local := isCategoryPackageName $op + if $isOpPackageName then lisplibWrite('"slot1DataBase", + ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) + $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) + $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) + -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended + libFn := getConstructorAbbreviation op' + $lookupFunction: local := + NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) + --either lookupComplete (for forgetful guys) or lookupIncomplete + $byteAddress :local := 0 + $byteVec :local := nil + $NRTslot1PredicateList := + [simpBool x for x in $NRTslot1PredicateList] + rwriteLispForm('loadTimeStuff, + ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) + $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 + $lisplibOperationAlist:= operationAlist + $lisplibMissingFunctions:= $CheckVectorList + lisplibWrite('"compilerInfo", + ['SETQ,'$CategoryFrame, + ['put,['QUOTE,op'],' + (QUOTE isFunctor), + ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' + QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], + ['put,['QUOTE,op' ],'(QUOTE mode), + ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) + if null argl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) + [fun,['Mapping,:signature'],originale] + +makeFunctorArgumentParameters(argl,sigl,target) == + $alternateViewList: local:= nil + $forceAdd: local:= true + $ConditionalOperators: local + target := markKillAll target + ("append"/[fn(a,augmentSig(s,findExtras(a,target))) + for a in argl for s in sigl]) where + findExtras(a,target) == + -- see if conditional information implies anything else + -- in the signature of a + target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] + target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where + findExtras1(a,x) == + x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['IF,c,p,q] => + union(findExtrasP(a,c), + union(findExtras1(a,p),findExtras1(a,q))) where + findExtrasP(a,x) == + x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] + nil + nil + augmentSig(s,ss) == + -- if we find something extra, add it to the signature + null ss => s + for u in ss repeat + $ConditionalOperators:=[CDR u,:$ConditionalOperators] + s is ['Join,:sl] => + u:=ASSQ('CATEGORY,ss) => + SUBST([:u,:ss],u,s) + ['Join,:sl,['CATEGORY,'package,:ss]] + ['Join,s,['CATEGORY,'package,:ss]] + fn(a,s) == + isCategoryForm(s,$CategoryFrame) => + s is ["Join",:catlist] => genDomainViewList0(a,rest s) + [genDomainView(a,a,s,"getDomainView")] + [a] + +compDefineCapsuleFunction(df,m,oldE,$prefix,$formalArgList) == + ['DEF,form,originalSignature,specialCases,body] := df + signature := markKillAll originalSignature + $markFreeStack: local := nil --holds "free variables" + $localImportStack : local := nil --local import stack for function + $localDeclareStack: local := nil + $localLoopVariables: local := nil + originalDef := COPY df + [lineNumber,:specialCases] := specialCases + e := oldE + --1. bind global variables + $form: local + $op: local + $functionStats: local:= [0,0] + $argumentConditionList: local + $finalEnv: local + --used by ReplaceExitEtc to get a common environment + $initCapsuleErrorCount: local:= #$semanticErrorStack + $insideCapsuleFunctionIfTrue: local:= true + $CapsuleModemapFrame: local:= e + $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) + $insideExpressionIfTrue: local:= true + $returnMode:= m + [$op,:argl]:= form + $form:= [$op,:argl] + argl:= stripOffArgumentConditions argl + $formalArgList:= [:argl,:$formalArgList] + + --let target and local signatures help determine modes of arguments + argModeList:= + identSig:= hasSigInTargetCategory(argl,form,first signature,e) => + (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + [getArgumentModeOrMoan(a,form,e) for a in argl] + argModeList:= stripOffSubdomainConditions(argModeList,argl) + signature':= [first signature,:argModeList] + if null identSig then --make $op a local function + oldE := put($op,'mode,['Mapping,:signature'],oldE) + + --obtain target type if not given + if null first signature' then signature':= + identSig => identSig + getSignature($op,rest signature',e) or return nil + e:= giveFormalParametersValues(argl,e) + + $signatureOfForm:= signature' --this global is bound in compCapsuleItems + $functionLocations := [[[$op,$signatureOfForm],:lineNumber], + :$functionLocations] + e:= addDomain(first signature',e) + e:= compArgumentConditions e + + if $profileCompiler then + for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) + + + --4. introduce needed domains into extendedEnv + for domain in signature' repeat e:= addDomain(domain,e) + + --6. compile body in environment with extended environment + rettype:= resolve(signature'.target,$returnMode) + + localOrExported := + null member($op,$formalArgList) and + getmode($op,e) is ['Mapping,:.] => 'local + 'exported + + --6a skip if compiling only certain items but not this one + -- could be moved closer to the top + formattedSig := formatUnabbreviated ['Mapping,:signature'] + $compileOnlyCertainItems and _ + not member($op, $compileOnlyCertainItems) => + sayBrightly ['" skipping ", localOrExported,:bright $op] + [nil,['Mapping,:signature'],oldE] + sayBrightly ['" compiling ",localOrExported, + :bright $op,'": ",:formattedSig] +---------------------> new <--------------------------------- + returnType := signature'.target +-- trialT := returnType = "$" and get("Rep",'value,e) and comp(body,'Rep,e) + trialT := returnType = "$" and comp(body,$EmptyMode,e) + ------------------------------------------------------ 11/1/94 + -- try comp-ing in $EmptyMode; if succeed + -- if we succeed then trialT.mode = "$" or "Rep" + -- do a coerce to get the correct result + T := (trialT and coerce(trialT,returnType)) + -------------------------------------- 11/1/94 + or CATCH('compCapsuleBody, compOrCroak(body,returnType,e)) + markChanges(originalDef,T,$signatureOfForm) + [nil,['Mapping,:signature'],oldE] + --------------------------------- + +compCapsuleInner(itemList,m,e) == + e:= addInformation(m,e) + --puts a new 'special' property of $Information + data:= ["PROGN",:itemList] + --RPLACd by compCapsuleItems and Friends + e:= compCapsuleItems(itemList,nil,e) + BOUNDP '$convert2NewCompiler and $convert2NewCompiler => + [nil,m,e] --nonsense but that's fine + localParList:= $functorLocalParameters + if $addForm then data:= ['add,$addForm,data] + code:= + $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data + processFunctorOrPackage($form,$signature,data,localParList,m,e) + [MKPF([:$getDomainCode,code],"PROGN"),m,e] + +compSingleCapsuleItem(item,$predl,$e) == + $localImportStack : local := nil + $localDeclareStack: local := nil + $markFreeStack: local := nil + newItem := macroExpandInPlace(item,qe(25,$e)) + qe(26,$e) + doIt(newItem, $predl) + qe(27,$e) + $e + +compImport(["import",:doms],m,e) == + for dom in doms repeat + dom := markKillAll dom + markImport dom + e:=addDomain(dom,e) + ["/throwAway",$NoValueMode,e] + +mkUnion(a,b) == + b="$" and $Rep is ["Union",:l] => b + a is ["Union",:l] => + b is ["Union",:l'] => ["Union",:setUnion(l,l')] + member(b, l) => a + ["Union",:setUnion([b],l)] + b is ["Union",:l] => + member(a, l) => b + ["Union",:setUnion([a],l)] + STRINGP a => ["Union",b,a] + ["Union",a,b] + +compForMode(x,m,e) == + $compForModeIfTrue: local:= true + $convert2NewCompiler: local := nil + comp(x,m,e) + +compMakeCategoryObject(c,$e) == + not isCategoryForm(c,$e) => nil + c := markKillAll c + u:= mkEvalableCategoryForm c => [eval markKillAll u,$Category,$e] + nil + +macroExpand(x,e) == --not worked out yet + atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + x is ['DEF,lhs,sig,spCases,rhs] => + ['DEF,macroExpand(lhs,e), macroExpandList(sig,e),macroExpandList(spCases,e), + macroExpand(rhs,e)] + x is ['MI,a,b] => + ['MI,a,macroExpand(b,e)] + macroExpandList(x,e) + +getSuccessEnvironment(a,e) == + -- the next four lines try to ensure that explicit special-case tests + -- prevent implicit ones from being generated + a is ["has",x,m] => + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,e) + e + a is ["is",id,m] => + id := unLet id + IDENTP id and isDomainForm(m,$EmptyEnvironment) => + e:=put(id,"specialCase",m,e) + currentProplist:= getProplist(id,e) + [.,.,e] := T := comp(m,$EmptyMode,e) or return nil -- duplicates compIs + newProplist:= consProplistOf(id,currentProplist,"value",removeEnv T) + addBinding(id,newProplist,e) + e + a is ["case",x,m] and (x := unLet x) and IDENTP x => + put(x,"condition",[a,:get(x,"condition",e)],e) + e + +getInverseEnvironment(a,E) == + atom a => E + [op,:argl]:= a +-- the next five lines try to ensure that explicit special-case tests +-- prevent implicit ones from being generated + op="has" => + [x,m]:= argl + x := unLet x + IDENTP x and isDomainForm(m,$EmptyEnvironment) => put(x,"specialCase",m,E) + E + a is ["case",x,m] and (x := unLet x) and IDENTP x => + --the next two lines are necessary to get 3-branched Unions to work + -- old-style unions, that is + if corrupted? get(x,"condition",E) then systemError 'condition + (get(x,"condition",E) is [["OR",:oldpred]]) and member(a,oldpred) => + put(x,"condition",LIST MKPF(delete(a,oldpred),"OR"),E) + getUnionMode(x,E) is ["Union",:l] or systemError 'Union + if corrupted? l then systemError 'list + l':= delete(m,l) + for u in l' repeat + if u is ['_:,=m,:.] then l':= delete(u,l') + newpred:= MKPF([["case",x,m'] for m' in l'],"OR") + put(x,"condition",[newpred,:get(x,"condition",E)],E) + E + +unLet x == + x is ['LET,u,:.] => unLet u + x + +corrupted? u == + u is [op,:r] => + MEMQ(op,'(WI MI PART)) => true + or/[corrupted? x for x in r] + false + +--====================================================================== +-- From apply.boot +--====================================================================== +applyMapping([op,:argl],m,e,ml) == + #argl^=#ml-1 => nil + isCategoryForm(first ml,e) => + --is op a functor? + pairlis:= [[v,:a] for a in argl for v in $FormalMapVariableList] + ml' := SUBLIS(pairlis, ml) + argl':= + [T.expr for x in argl for m' in rest ml'] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= [op,:argl'] +---------------------> new <---------------------------- + if constructor? op then form := markKillAll form +---------------------> new <---------------------------- + convert([form,first ml',e],m) + argl':= + [T.expr for x in argl for m' in rest ml] where + T() == [.,.,e]:= comp(x,m',e) or return "failed" + if argl'="failed" then return nil + form:= + not member(op,$formalArgList) and ATOM op and not get(op,'value,e) => + nprefix := $prefix or + -- following needed for referencing local funs at capsule level + getAbbreviation($op,#rest $form) + [op',:argl',"$"] where + op':= INTERN STRCONC(encodeItem nprefix,";",encodeItem op) + ['call,['applyFun,op],:argl'] + pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] + convert([form,SUBLIS(pairlis,first ml),e],m) + +compFormWithModemap(form,m,e,modemap) == + compFormWithModemap1(form,m,e,modemap,true) or compFormWithModemap1(form,m,e,modemap,false) + +compFormWithModemap1(form,m,e,modemap,Rep2Dollar?) == + [op,:argl] := form := markKillExpr form + [[dc,:.],:.] := modemap +----------> new: <----------- + if Rep2Dollar? then + if dc = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) + else return nil +----------> new: <----------- + [map:= [.,target,:.],[pred,impl]]:= modemap + -- this fails if the subsuming modemap is conditional + --impl is ['Subsumed,:.] => nil + if isCategoryForm(target,e) and isFunctor op then + [modemap,e]:= substituteIntoFunctorModemap(argl,modemap,e) or return nil + [map:= [.,target,:.],:cexpr]:= modemap + sv:=listOfSharpVars map + if sv then + -- SAY [ "compiling ", op, " in compFormWithModemap, + -- mode= ",map," sharp vars=",sv] + for x in argl for ss in $FormalMapVariableList repeat + if ss in sv then + [map:= [.,target,:.],:cexpr]:= modemap :=SUBST(x,ss,modemap) + -- SAY ["new map is",map] + not (target':= coerceable(target,m,e)) => nil + markMap := map + map:= [target',:rest map] + [f,Tl,sl]:= compApplyModemap(form,modemap,e,nil) or return nil + + --generate code; return + T:= + e':= + Tl => (LAST Tl).env + e + [x',m',e'] where + m':= SUBLIS(sl,map.(1)) + x':= + form':= [f,:[t.expr for t in Tl]] + m'=$Category or isCategoryForm(m',e) => form' + -- try to deal with new-style Unions where we know the conditions + op = "elt" and f is ['XLAM,:.] and IDENTP(z:=CAR argl) and + (c:=get(z,'condition,e)) and + c is [['case,=z,c1]] and + (c1 is ['_:,=(CADR argl),=m] or EQ(c1,CADR argl) ) => +-- first is a full tag, as placed by getInverseEnvironment +-- second is what getSuccessEnvironment will place there + ["CDR",z] + markTran(form,form',markMap,e') + qt(18,T) + convert(T,m) + +convert(T,m) == + tcheck T + qe(23,T.env) + coerce(T,resolve(T.mode,m) or return nil) + +compElt(origForm,m,E) == + form := markKillAll origForm + form isnt ["elt",aDomain,anOp] => compForm(origForm,m,E) + aDomain="Lisp" => + markLisp([anOp',m,E],E)where anOp'() == (anOp=$Zero => 0; anOp=$One => 1; anOp) + isDomainForm(aDomain,E) => + markImport opOf aDomain + E:= addDomain(aDomain,E) + mmList:= getModemapListFromDomain(anOp,0,aDomain,E) + modemap:= + n:=#mmList + 1=n => mmList.(0) + 0=n => + return + stackMessage ['"Operation ","%b",anOp,"%d", + '"missing from domain: ", aDomain] + stackWarning ['"more than 1 modemap for: ",anOp, + '" with dc=",aDomain,'" ===>" + ,mmList] + mmList.(0) +----------> new: <----------- + if aDomain = 'Rep then + modemap := SUBST('Rep,'_$,modemap) + m := SUBST('Rep,'_$,m) +----------> new: <----------- + [sig,[pred,val]]:= modemap + #sig^=2 and ^val is ["elt",:.] => nil --what does the second clause do ???? +--+ + val := genDeltaEntry [opOf anOp,:modemap] + x := markTran(origForm,[val],sig,[E]) + [x,first rest sig,E] --implies fn calls used to access constants + compForm(origForm,m,E) + +pause op == op +compApplyModemap(form,modemap,$e,sl) == + [op,:argl] := form --form to be compiled + [[mc,mr,:margl],:fnsel] := modemap --modemap we are testing + + -- $e is the current environment + -- sl substitution list, nil means bottom-up, otherwise top-down + + -- 0. fail immediately if #argl=#margl + + if #argl^=#margl then return nil + + -- 1. use modemap to evaluate arguments, returning failed if + -- not possible + + lt:= + [[.,m',$e]:= + comp(y,g,$e) or return "failed" where + g:= SUBLIS(sl,m) where + sl:= pmatchWithSl(m',m,sl) for y in argl for m in margl] + lt="failed" => return nil + + -- 2. coerce each argument to final domain, returning failed + -- if not possible + + lt':= [coerce(y,d) or return "failed" + for y in lt for d in SUBLIS(sl,margl)] + lt'="failed" => return nil + + -- 3. obtain domain-specific function, if possible, and return + + --$bindings is bound by compMapCond + [f,$bindings]:= compMapCond(op,mc,sl,fnsel) or return nil + +--+ can no longer trust what the modemap says for a reference into +--+ an exterior domain (it is calculating the displacement based on view +--+ information which is no longer valid; thus ignore this index and +--+ store the signature instead. + +--$NRTflag=true and f is [op1,d,.] and NE(d,'$) and member(op1,'(ELT CONST)) => + f is [op1,d,.] and member(op1,'(ELT CONST Subsumed)) => + [genDeltaEntry [op,:modemap],lt',$bindings] + markImport mc + [f,lt',$bindings] + +compMapCond''(cexpr,dc) == + cexpr=true => true + --cexpr = "true" => true +---------------> new <---------------------- + cexpr is [op,:l] and MEMQ(op,'(_and AND)) => and/[compMapCond''(u,dc) for u in l] + cexpr is [op,:l] and MEMQ(op,'(_or OR)) => or/[compMapCond''(u,dc) for u in l] +---------------> new <---------------------- + cexpr is ["not",u] => not compMapCond''(u,dc) + cexpr is ["has",name,cat] => (knownInfo cexpr => true; false) + --for the time being we'll stop here - shouldn't happen so far + --$disregardConditionIfTrue => true + --stackSemanticError(("not known that",'%b,name, + -- '%d,"has",'%b,cat,'%d),nil) + --now it must be an attribute + member(["ATTRIBUTE",dc,cexpr],get("$Information","special",$e)) => true + --for the time being we'll stop here - shouldn't happen so far + stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] + false + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +NRTgetLocalIndex1(item,killBindingIfTrue) == + k := NRTassocIndex item => k + item = $NRTaddForm => 5 + item = '$ => 0 + item = '_$_$ => 2 + value:= + MEMQ(item,$formalArgList) => item + nil + atom item and null MEMQ(item,'($ _$_$)) + and null value => --give slots to atoms + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + $NRTdeltaListComp:=[item,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + $NRTbase + $NRTdeltaLength - 1 + $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + saveIndex := $NRTbase + $NRTdeltaLength + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= item + ----94/11/07 + -- WAS: compOrCroak(item,$EmptyMode,$e).expr + RPLACA(saveNRTdeltaListComp,compEntry) + saveIndex + +optDeltaEntry(op,sig,dc,eltOrConst) == + return nil --------> kill it + $killOptimizeIfTrue = true => nil + ndc := + dc = '$ => $functorForm + atom dc and (dcval := get(dc,'value,$e)) => dcval.expr + dc +--if (atom dc) and (dcval := get(dc,'value,$e)) +-- then ndc := dcval.expr +-- else ndc := dc + sig := SUBST(ndc,dc,sig) + not MEMQ(KAR ndc,$optimizableConstructorNames) => nil + dcval := optCallEval ndc + -- MSUBST guarantees to use EQUAL testing + sig := MSUBST(devaluate dcval, ndc, sig) + if rest ndc then + for new in rest devaluate dcval for old in rest ndc repeat + sig := MSUBST(new,old,sig) + -- optCallEval sends (List X) to (LIst (Integer)) etc, + -- so we should make the same transformation + fn := compiledLookup(op,sig,dcval) + if null fn then + -- following code is to handle selectors like first, rest + nsig := [quoteSelector tt for tt in sig] where + quoteSelector(x) == + not(IDENTP x) => x + get(x,'value,$e) => x + x='$ => x + MKQ x + fn := compiledLookup(op,nsig,dcval) + if null fn then return nil + eltOrConst="CONST" => + hehe fn + [op] -----------> return just the op here +-- ['XLAM,'ignore,MKQ SPADCALL fn] + GETL(compileTimeBindingOf first fn,'SPADreplace) + +genDeltaEntry opMmPair == +--called from compApplyModemap +--$NRTdeltaLength=0.. always equals length of $NRTdeltaList + [.,[odc,:.],.] := opMmPair + --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) + [op,[dc,:sig],[.,cform:=[eltOrConst,:.]]] := opMmPair + if $profileCompiler = true then + profileRecord(dc,op,sig) +-- markImport dc + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + -- following hack needed to invert Rep to $ substitution + if odc = 'Rep and cform is [.,.,osig] then sig:=osig + newimp := optDeltaEntry(op,sig,dc,eltOrConst) => newimp + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(sig,dc),consDomainForm(dc,nil)]] + --if null atom dc then + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in sig]],['T,cform]] -- force pred to T + if null NRTassocIndex dc and dc ^= $NRTaddForm and + (member(dc,$functorLocalParameters) or null atom dc) then + --create "domain" entry to $NRTdeltaList + $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= + dc + RPLACA(saveNRTdeltaListComp,compEntry) + chk(saveNRTdeltaListComp,102) + u := + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == + (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 + --n + 1 since $NRTdeltaLength is 1 too large + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + 0 + u + +--====================================================================== +-- From nruncomp.boot +--====================================================================== +parseIf t == + t isnt [p,a,b] => t + ifTran(parseTran p,parseTran a,parseTran b) where + ifTran(p,a,b) == + null($InteractiveMode) and p='true => a + null($InteractiveMode) and p='false => b + p is ['not,p'] => ifTran(p',b,a) + p is ['IF,p',a',b'] => ifTran(p',ifTran(a',COPY a,COPY b),ifTran(b',a,b)) + p is ['SEQ,:l,['exit,1,p']] => + ['SEQ,:l,['exit,1,ifTran(p',incExitLevel a,incExitLevel b)]] + --this assumes that l has no exits + a is ['IF, =p,a',.] => ['IF,p,a',b] + b is ['IF, =p,.,b'] => ['IF,p,a,b'] +-- makeSimplePredicateOrNil p is ['SEQ,:s,['exit,1,val]] => +-- parseTran ['SEQ,:s,['exit,1,incExitLevel ['IF,val,a,b]]] + ['IF,p,a,b] + +--====================================================================== +-- From parse.boot +--====================================================================== +parseNot u == ['not,parseTran first u] + +makeSimplePredicateOrNil p == nil + +--====================================================================== +-- From g-cndata.boot +--====================================================================== +mkUserConstructorAbbreviation(c,a,type) == + if $AnalyzeOnly or $convert2NewCompiler then + $abbreviationStack := [[type,a,:c],:$abbreviationStack] + if not atom c then c:= CAR c -- Existing constructors will be wrapped + constructorAbbreviationErrorCheck(c,a,type,'abbreviationError) + clearClams() + clearConstructorCache(c) + installConstructor(c,type) + setAutoLoadProperty(c) + +--====================================================================== +-- From iterator.boot +--====================================================================== + +compreduce(form is [.,op,x],m,e) == + T := compForm(form,m,e) or return nil + y := T.expr + RPLACA(y,"REDUCE") + ------------------<== distinquish this as the special reduce form + (y is ["REDUCE",:.]) and (id:= getIdentity(op,e)) and (u := comp0(id,m,e)) and + # getNumberTypesInScope() > 1 => markSimpleReduce([:y, ["@",u.expr,m]], T) + T + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == +-------------------------------> 11/28 all new to preserve collect forms + markImport m + [collectOp,:itl,body]:= collectForm + $e:= e + itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] + itl="failed" => return nil + e:= $e + T0 := comp0(body,m,e) or return nil + md := T0.mode + T1 := compOrCroak(collectForm,["List",md],e) + T := [["REDUCE",op,nil,T1.expr],md,T1.env] + markReduce(form,T) + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + ---------------> new <--------------------- + [y',m,e] := markInValue(y, e) + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or modeIsAggregateOf("Vector",m,e) or return + stackMessage ["mode: ",m," must be a list or vector of some mode"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + markReduceIn(it, [["IN",x,y'],e]) + it is ["ON",x,y] => +---------------> new <--------------------- + x := markKillAll x + ------------------ + $formalArgList:= [x,:$formalArgList] + y := markKillAll y + markImport m +---------------> new <--------------------- + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [.,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of other modes"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [["ON",x,y'],e] + it is ["STEP",oindex,start,inc,:optFinal] => + index := markKillAll oindex + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil +---------------> new <--------------------- + u := smallIntegerStep(it,index,start,inc,optFinal,e) => u +---------------> new <--------------------- + [start,.,e]:= + comp(markKillAll start,$Integer,e) or return + stackMessage ["start value of index: ",start," must be an integer"] + [inc,.,e]:= + comp(markKillAll inc,$Integer,e) or return + stackMessage ["index increment:",inc," must be an integer"] + if optFinal is [final] then + [final,.,e]:= + comp(markKillAll final,$Integer,e) or return + stackMessage ["final value of index: ",final," must be an integer"] + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer +-- markImport ['Segment,indexmode] + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + markReduceStep(it, [["STEP",markStep(index),start,inc,:optFinal],e]) + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage ["WHILE operand: ",p," is not Boolean valued"] + markReduceWhile(it, [["WHILE",p'],e]) + it is ["UNTIL",p] => markReduceUntil(it, ($until:= p; ['$until,e])) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] + markReduceSuchthat(it, [["|",u.expr],u.env]) + nil + +smallIntegerStep(it,index,start,inc,optFinal,e) == + start := markKillAll start + inc := markKillAll inc + optFinal := markKillAll optFinal + startNum := source2Number start + incNum := source2Number inc + mode := get(index,"mode",e) +--fail if +----> a) index has a mode that is not $SmallInteger +----> b) one of start,inc, final won't comp as a $SmallInteger + mode and mode ^= $SmallInteger => nil + null (start':= comp(start,$SmallInteger,e)) => nil + null (inc':= comp(inc,$SmallInteger,start'.env)) => nil + if optFinal is [final] and not (final':= comp(final,$SmallInteger,inc'.env)) then +-- not (FIXP startNum and FIXP incNum) => return nil +-- null FIXP startNum or ABSVAL startNum > 100 => return nil + -----> assume that optFinal is $SmallInteger + T := comp(final,$EmptyMode,inc'.env) or return nil + final' := T + maxSuperType(T.mode,e) ^= $Integer => return nil + givenRange := T.mode + indexmode:= $SmallInteger + [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + range := + FIXP startNum and FIXP incNum => + startNum > 0 and incNum > 0 => $PositiveInteger + startNum < 0 and incNum < 0 => $NegativeInteger + incNum > 0 => $NonNegativeInteger --startNum = 0 + $NonPositiveInteger + givenRange => givenRange + nil + e:= put(index,"range",range,e) + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + noptFinal := + final' => + [final'.expr] + nil + [markStepSI(it,["ISTEP",index,start'.expr,inc'.expr,:noptFinal]),e] + +source2Number n == + n := markKillAll n + n = $Zero => 0 + n = $One => 1 + n + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack +-- pp '"---------" +-- pp targetMode + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= T := + -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or + compOrCroak(body,bodyMode,e) or return nil + markRepeatBody(body, T) + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' +--------> new <-------------- + markImport m'' +--------> new <-------------- + markRepeat(form,coerceExit([form',m'',e'],targetMode)) + +chaseInferences(origPred,$e) == + pred := markKillAll origPred + ----------------------------12/4/94 do this immediately + foo hasToInfo pred where + foo pred == + knownInfo pred => nil + $e:= actOnInfo(pred,$e) + pred:= infoToHas pred + for u in get("$Information","special",$e) repeat + u is ["COND",:l] => + for [ante,:conseq] in l repeat + ante=pred => [foo w for w in conseq] + ante is ["and",:ante'] and member(pred,ante') => + ante':= delete(pred,ante') + v':= + LENGTH ante'=1 => first ante' + ["and",:ante'] + v':= ["COND",[v',:conseq]] + member(v',get("$Information","special",$e)) => nil + $e:= + put("$Information","special",[v',: + get("$Information","special",$e)],$e) + nil + $e + +--====================================================================== +-- doit Code +--====================================================================== +doIt(item,$predl) == + $GENNO: local:= 0 + $coerceList: local := nil + ---> + if item is ['PART,.,a] then item := a + ------------------------------------- + item is ['SEQ,:.] => doItSeq item + isDomainForm(item,$e) => doItDomain item + item is ['LET,:.] => doItLet item + item is [":",a,t] => [.,.,$e]:= + markDeclaredImport markKillAll t + compOrCroak(item,$EmptyMode,$e) + item is ['import,:doms] => + item := ['import,:(doms := markKillAll doms)] + for dom in doms repeat + sayBrightly ['" importing ",:formatUnabbreviated dom] + [.,.,$e] := compOrCroak(item,$EmptyMode,$e) + wiReplaceNode(item,'(PROGN),10) + item is ["IF",:.] => doItIf(item,$predl,$e) + item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) + item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) + item is ['DEF,:.] => doItDef item + T:= compOrCroak(item,$EmptyMode,$e) => doItExpression(item,T) + true => cannotDo() + +holdIt item == item + +doItIf(item is [.,p,x,y],$predl,$e) == + olde:= $e + [p',.,$e]:= qt(19,comp(p,$Boolean,$e)) or userError ['"not a Boolean:",p] + oldFLP:=$functorLocalParameters + if x^="noBranch" then +--> new <----------------------- + qe(20,compSingleCapsuleItem(x,[p,:$predl],getSuccessEnvironment(markKillAll p,$e))) +---> new ----------- + x':=localExtras(oldFLP) + where localExtras(oldFLP) == + EQ(oldFLP,$functorLocalParameters) => NIL + flp1:=$functorLocalParameters + oldFLP':=oldFLP + n:=0 + while oldFLP' repeat + oldFLP':=CDR oldFLP' + flp1:=CDR flp1 + n:=n+1 + -- Now we have to add code to compile all the elements + -- of functorLocalParameters that were added during the + -- conditional compilation + nils:=ans:=[] + for u in flp1 repeat -- is =u form always an ATOM? + if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) + then + nils:=[u,:nils] + else + gv := GENSYM() + ans:=[['LET,gv,u],:ans] + nils:=[gv,:nils] + n:=n+1 + + $functorLocalParameters:=[:oldFLP,:REVERSE nils] + REVERSE ans + oldFLP:=$functorLocalParameters + if y^="noBranch" then +--> new <----------------------- + qe(21,compSingleCapsuleItem(y,[['not, p],:$predl],getInverseEnvironment(markKillAll p,olde))) +--> ----------- + y':=localExtras(oldFLP) + wiReplaceNode(item,["COND",[p',x,:x'],['(QUOTE T),y,:y']],12) + +doItSeq item == + ['SEQ,:l,['exit,1,x]] := item + RPLACA(item,"PROGN") + RPLACA(LASTNODE item,x) + for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) + +doItDomain item == + -- convert naked top level domains to import + u:= ['import, [first item,:rest item]] + markImport CADR u + stackWarning ["Use: import ", [first item,:rest item]] +--wiReplaceNode(item, u, 14) + RPLACA(item, first u) + RPLACD(item, rest u) + doIt(item,$predl) + +doItLet item == + qe(3,$e) + res := doItLet1 item + qe(4,$e) + res + +doItLet1 item == + ['LET,lhs,rhs,:.] := item + not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => + stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) + qe(5,$e) + code := markKillAll code + not (code is ['LET,lhs',rhs',:.] and atom lhs') => + code is ["PROGN",:.] => + stackSemanticError(["multiple assignment ",item," not allowed"],nil) + wiReplaceNode(item, code, 24) + lhs:= lhs' + if not member(KAR rhs,$NonMentionableDomainNames) and + not MEMQ(lhs, $functorLocalParameters) then + $functorLocalParameters:= [:$functorLocalParameters,lhs] + if (rhs' := rhsOfLetIsDomainForm code) then + if isFunctor rhs' then + $functorsUsed:= insert(opOf rhs',$functorsUsed) + $packagesUsed:= insert([opOf rhs'],$packagesUsed) + $globalImportDefAlist := pp [[lhs, :rhs'],:$globalImportDefAlist] + if lhs="Rep" then + $Representation:= (get("Rep",'value,$e)).(0) + --$Representation bound by compDefineFunctor, used in compNoStacking +--+ + if $NRTopt = true + then NRTgetLocalIndex $Representation +--+ + $LocalDomainAlist:= --see genDeltaEntry + [[lhs,:SUBLIS($LocalDomainAlist,get(lhs,'value,$e).0)],:$LocalDomainAlist] +--+ + qe(6,$e) + code is ['LET,:.] => + rhsCode:= rhs' + op := ($QuickCode => 'QSETREFV;'SETELT) + wiReplaceNode(item,[op,'$,NRTgetLocalIndexClear lhs,rhsCode], 16) + wiReplaceNode(item, code, 18) + +rhsOfLetIsDomainForm code == + code is ['LET,.,rhs',:.] => + isDomainForm(rhs',$e) => rhs' + isDomainForm(rhs' := markKillAll rhs',$e) => rhs' + false + false + +doItDef item == + ['DEF,[op,:.],:.] := item + body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) + chk(item,3) + RPLACA(item,"CodeDefine") + --Note that DescendCode, in CodeDefine, is looking for this + RPLACD(CADR item,[$signatureOfForm]) + chk(item,4) + --This is how the signature is updated for buildFunctor to recognise +--+ + functionPart:= ['dispatchFunction,t.expr] + wiReplaceNode(CDDR item,[functionPart], 20) + chk(item, 30) + +doItExpression(item,T) == + SETQ($ITEM,COPY item) + SETQ($T1,COPY T.expr) + chk(T.expr, 304) + u := markCapsuleExpression(item, T) + [code,.,$e]:= u + wiReplaceNode(item,code, 22) + +wiReplaceNode(node,ocode,key) == + ncode := CONS(first ocode, rest ocode) + code := replaceNodeInStructureBy(node,ncode) + SETQ($NODE,COPY node) + SETQ($NODE1, COPY first code) + SETQ($NODE2, COPY rest code) + RPLACA(node,first code) + RPLACD(node,rest code) + chk(code, key) + chk(node, key + 1) + +replaceNodeInStructureBy(node, x) == + $nodeCopy: local := [CAR node,:CDR node] + replaceNodeBy(node, x) + node + +replaceNodeBy(node, x) == + atom x => nil + for y in tails x | EQCAR(x,node) repeat RPLAC(CAR x, $nodeCopy) + nil + +chk(x,key) == fn(x,0,key) where fn(x,cnt,key) == + cnt > 10000 => + sayBrightly ["--> ", key, " <---"] + hahaha(key) + atom x => cnt + VECP x => systemError nil + for y in x repeat cnt := fn(y, cnt + 1, key) + cnt + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} diff --git a/src/interp/word.boot b/src/interp/word.boot deleted file mode 100644 index 95dfc7a1..00000000 --- a/src/interp/word.boot +++ /dev/null @@ -1,400 +0,0 @@ --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - ---======================================================================= --- Build Directories ---======================================================================= -buildFunctionTable(dicts) == - sayKeyedMsg("S2GL0011",NIL) - buildWordTable getListOfFunctionNames dicts - -buildWordTable u == - table:= MAKE_-HASHTABLE 'ID - for s in u repeat - key := UPCASE s.0 - HPUT(table,key,[[s,:wordsOfString s],:HGET(table,key)]) - for key in HKEYS table repeat - HPUT(table,key, - listSort(function GLESSEQP,removeDupOrderedAlist - listSort(function GLESSEQP, HGET(table,key),function CAR), - function CADR)) - table - -writeFunctionTables(filemode) == - $functionTable := NIL - writeFunctionTable(filemode,'SPADU,'(SPAD)) - $functionTable := NIL - writeFunctionTable(filemode,'SPADD,'(SPADSYS)) - $functionTable := NIL - writeFunctionTable(filemode,'SPADC,'(SPADSYS SCRATCHPAD_-COMPILER)) - $functionTable := NIL - 'done - -writeFunctionTable(filemode,name,dicts) == - _$ERASE makePathname(name,'DATABASE,filemode) - stream:= writeLib1(name,'DATABASE,filemode) - if not $functionTable then - $functionTable:= buildFunctionTable dicts - for key in HKEYS $functionTable repeat - rwrite(object2Identifier key,HGET($functionTable,key),stream) - RSHUT stream - 'done - -readFunctionTable() == - sayKeyedMsg("S2GL0011",NIL) - name := - $wordDictionary = 'user => 'SPADU - $wordDictionary = 'development => 'SPADD - 'SPADC - stream:= readLib(name,'DATABASE) - table:= MAKE_-HASHTABLE 'ID - for key in RKEYIDS makePathname(name,'DATABASE,"*") repeat - HPUT(table,kk:=object2Identifier key, rread(kk,stream,nil)) - RSHUT stream - table - -removeDupOrderedAlist u == - -- removes duplicate entries in ordered alist - -- (where duplicates are adjacent) - for x in tails u repeat - (y := rest x) and first first x = first first y => RPLACD(x,rest y) - u - -getListOfFunctionNames(fnames) == - -- fnames is a list of directories - res := nil - for fn in fnames repeat - null IOSTATE(fn,'DIRECT,'_*) => 'iterate - stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,fn,'DIRECT,'_*]],80,0) - while (not PLACEP (x:= READ_-LINE stream)) repeat - (s := SIZE x) < 26 => 'iterate - res:= [SUBSTRING(x,26,NIL),:res] - SHUT stream - res - -wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] - -wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] - -wordsOfString1(s,j) == - k := or/[i for i in j..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => - tailWords:= - isBreakCharacter s.(k+1) => - n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not isBreakCharacter s.i] - null n => [SUBSTRING(s,k,nil)] - n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] - m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => - [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] - [SUBSTRING(s,k,nil)] - k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] - tailWords - nil - -isBreakCharacter x == null SMALL__LITER x - --- SETANDFILEQ($functionTable,buildFunctionTable()) - ---======================================================================= --- Augment Function Directories ---======================================================================= -add2WordFunctionTable fn == ---called from DEF - $functionTable and - null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => - HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) - ---======================================================================= --- Guess Function Name ---======================================================================= -guess word == - u := bootFind word => INTERN u - nil - -bootFind word == - not $useWordFacility => NIL - list:= bootSearch word - PNAME word in list => nil --mismatch of directories: pretend it was not found - null list => centerAndHighlight('"no match found",80,'" ") - 1 = #list => doYouWant? first list - pickANumber(word,list) - -doYouWant? nam == - center80 ['"Do you mean",:bright nam,'"?"] - center80 ['"If so, type",:bright 'y,"or",:bright 'yes] - center80 ['"Anything else means",:bright 'no] - x := UPCASE queryUser nil - MEMQ(STRING2ID_-N(x,1),'(Y YES)) => nam - nil - -pickANumber(word,list) == - clearScreen() - centerNoHighlight(['"You asked for",:bright word],80,'"-") - centerAndHighlight('"Do you mean one of the following?",80,'" ") - n:= #list - xx:= (n > 99 => 3; n > 9 => 2; 1) - maxWidth:= 38 - 2*(1+xx) - [short,long] := say2Split(list,nil,nil,maxWidth) - extra:= - REMAINDER(length := # short,2) ^= 0 => 1 - 0 - halfLength:= length/2 - firstList:= TAKE(halfLength,short) - secondList:= TAKE(-halfLength,short) - secondStartIndex:= halfLength + extra - shortList:= - "append"/[[[:bright i,fillerSpaces(xx-WIDTH i,'" "),x], - [:bright(i+secondStartIndex),fillerSpaces(xx-WIDTH (i+halfLength),'" "),y]] - for i in 1.. for x in firstList for y in secondList] - say2PerLineThatFit shortList - i:= 1 + halfLength - if extra=1 then - sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),list.(i-1)] - for x in long for i in (1+length).. repeat - sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),x] - center80 ['"If so: type a number between",:bright 1,'"and",:bright n,"and ENTER"] - center80 ['"Anything else means",:bright 'no] - y := queryUser nil - x:= string2Integer y - FIXP x and x >= 1 and x <= #list => list.(x-1) - nil - -bootSearch word == ---if not $functionTable then $functionTable:= buildFunctionTable() - if not $functionTable then $functionTable:= readFunctionTable() - key := PNAME word - list := - hasWildCard? key => - pattern := patternTran key -- converts * to & - pattern.0 ^= '_& => - [x for [x,:.] in HGET($functionTable,UPCASE pattern.0)| - match?(pattern,COPY x)] - "append"/[[x for [x,:.] in HGET($functionTable,k)| match?(pattern,COPY x)] - for k in HKEYS $functionTable] - findApproximateWords(PNAME word,$functionTable) - list - -findApproximateWords(word,table) == - words:= wordsOfString word - upperWord:= UPCASE COPY word - n := #words - threshold:= - n = 1 => 3 - 4 - alist:= HGET(table,UPCASE word.0) - - --first try to break up as list of words - firstTry := [x for [x,:wordList] in alist | p] where p == - n = #wordList => - sum := 0 - for entry in wordList for part in words while sum < threshold repeat - sum:= sum + deltaWordEntry(part,entry) - sum < threshold => true - n < 3 => false - sum := 0 - badWord := false - for entry in wordList for part in words while sum < threshold repeat - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => badWord := true - sum := 1000 - sum < threshold - n+1 = #wordList => --assume one word is missing - sum := 0 - badWord := false - for entries in tails wordList for part in words - while sum < threshold repeat - entry := first entries - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - entries := rest entries --skip this bad word - entry := first entries - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold - n-1 = #wordList => --assume one word too many - sum := 0 - badWord := false - for entry in wordList for parts in tails words - while sum < threshold repeat - part := first parts - k:= deltaWordEntry(part,entry) - k < 2 => sum:= sum + k - null badWord => - badWord := true - parts := rest parts --skip this bad word - part := first parts - k := deltaWordEntry(part,entry) - k < 2 => sum := sum + k - sum := 1000 - sum := 1000 - sum < threshold - false - firstTry => firstTry - - --no winners, so try flattening to upper case and checking again - - wordSize := SIZE word - lastThreshold := MAX(3,wordSize/2) - vec := GETREFV lastThreshold - for [x,:.] in alist repeat - k := deltaWordEntry(upperWord,UPCASE COPY x) - k < lastThreshold => vec.k := [x,:vec.k] - or/[vec.k for k in 0..MAXINDEX vec] - -guessFromList(key,stringList) == - threshold := MAX(3,(SIZE key)/2) - vec := GETREFV threshold - for x in stringList repeat - k := deltaWordEntry(key,x) - k < threshold => vec.k := [x,:vec.k] - or/[vec.k for k in 0..MAXINDEX vec] - -deltaWordEntry(word,entry) == - word = entry => 0 - ABS(diff := SIZE word - SIZE entry) > 4 => 1000 - canForgeWord(word,entry) - ---+ Note these are optimized definitions below-- see commented out versions ---+ to understand the algorithm -canForgeWord(word,entry) == - forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) - -forge(word,w,W,entry,e,E,n) == - w > W => - e > E => n - QSADD1 QSPLUS(E-e,n) - e > E => QSADD1 QSPLUS(W-w,n) - word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) - w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) - word.w=entry.(e+1) => - word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) - forge(word,w+1,W,entry,e+2,E,QSADD1 n) - word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) - - (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => - --if word is long, can we delete chars to match 2 consective chars - deltaW >= deltaE and - (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) - and word.(k+1) = entry.(e+1) => - forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) - deltaW <= deltaE and - --if word is short, can we insert chars so as to match 2 consecutive chars - (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) - and word.(w+1) = entry.(k+1) => - forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - --check for two consecutive matches down the line - forge(word,w+1,W,entry,e+1,E,QSADD1 n) - ---+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm ---+ canForgeWord(word,entry) ==-- ---+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) ---+ --d=deletions, i=insertions, s=substitutions, t=transpositions ---+ --list is formed only for tuning purposes-- remove later on ---+ d + i + s + t - ---+forge(word,w,W,entry,e,E,d,i,s,t) == ---+ w > W => ---+ e > E => [d,i,s,t] ---+ [d,E-e+i+1,s,t] ---+ e > E => [W-w+d+1,i,s,t] ---+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) ---+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ word.w=entry.(e+1) => ---+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) ---+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) ---+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) ---+ ---+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => ---+ --if word is long, can we delete chars to match 2 consective chars ---+ deltaW >= deltaE and ---+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) ---+ and word.(k+1) = entry.(e+1) => ---+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) ---+ deltaW <= deltaE and ---+ --if word is short, can we insert chars so as to match 2 consecutive chars ---+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) ---+ and word.(w+1) = entry.(k+1) => ---+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) ---+ --check for two consecutive matches down the line ---+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) - ---======================================================================= --- String Pattern Matching ---======================================================================= -patternTran pattern == - null hasWildCard? pattern and LITER pattern.0 and - UPCASE copy pattern = pattern => - name:= abbreviation? INTERN pattern - or browseError [:bright pattern, - '"is not a constructor abbreviation"] - DOWNCASE PNAME name - maskConvert DOWNCASE pattern - -hasWildCard? str == - or/[str.i = '_? and (i=0 or not(str.(i-1) = '__ )) for i in 0..MAXINDEX str] - -maskConvert str == ---replace all ? not preceded by an underscore by & - buf:= GETSTR(#str) - j:= 0 --index into res - final := MAXINDEX str - for i in 0..final repeat - char := str.i - if char = '__ and i < final then - i:= i+1 - char := str.i - else if char = '_? then char := '_& - SUFFIX(char,buf) - buf - - -infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) - -prefix?(s,t) == substring?(s,t,0) - -suffix?(s,t) == - m := #s; n := #t - if m > n then return false - substring?(s,t,(n-m)) - -obSearch x == - vec:= OBARRAY() - pattern:= PNAME x - [y for i in 0..MAXINDEX OBARRAY() | - (IDENTP (y := vec.i) or CVEC y) and match?(pattern,COPY y)] - diff --git a/src/interp/word.boot.pamphlet b/src/interp/word.boot.pamphlet new file mode 100644 index 00000000..ac76dca3 --- /dev/null +++ b/src/interp/word.boot.pamphlet @@ -0,0 +1,422 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp word.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +\section{License} +<>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<> + +--======================================================================= +-- Build Directories +--======================================================================= +buildFunctionTable(dicts) == + sayKeyedMsg("S2GL0011",NIL) + buildWordTable getListOfFunctionNames dicts + +buildWordTable u == + table:= MAKE_-HASHTABLE 'ID + for s in u repeat + key := UPCASE s.0 + HPUT(table,key,[[s,:wordsOfString s],:HGET(table,key)]) + for key in HKEYS table repeat + HPUT(table,key, + listSort(function GLESSEQP,removeDupOrderedAlist + listSort(function GLESSEQP, HGET(table,key),function CAR), + function CADR)) + table + +writeFunctionTables(filemode) == + $functionTable := NIL + writeFunctionTable(filemode,'SPADU,'(SPAD)) + $functionTable := NIL + writeFunctionTable(filemode,'SPADD,'(SPADSYS)) + $functionTable := NIL + writeFunctionTable(filemode,'SPADC,'(SPADSYS SCRATCHPAD_-COMPILER)) + $functionTable := NIL + 'done + +writeFunctionTable(filemode,name,dicts) == + _$ERASE makePathname(name,'DATABASE,filemode) + stream:= writeLib1(name,'DATABASE,filemode) + if not $functionTable then + $functionTable:= buildFunctionTable dicts + for key in HKEYS $functionTable repeat + rwrite(object2Identifier key,HGET($functionTable,key),stream) + RSHUT stream + 'done + +readFunctionTable() == + sayKeyedMsg("S2GL0011",NIL) + name := + $wordDictionary = 'user => 'SPADU + $wordDictionary = 'development => 'SPADD + 'SPADC + stream:= readLib(name,'DATABASE) + table:= MAKE_-HASHTABLE 'ID + for key in RKEYIDS makePathname(name,'DATABASE,"*") repeat + HPUT(table,kk:=object2Identifier key, rread(kk,stream,nil)) + RSHUT stream + table + +removeDupOrderedAlist u == + -- removes duplicate entries in ordered alist + -- (where duplicates are adjacent) + for x in tails u repeat + (y := rest x) and first first x = first first y => RPLACD(x,rest y) + u + +getListOfFunctionNames(fnames) == + -- fnames is a list of directories + res := nil + for fn in fnames repeat + null IOSTATE(fn,'DIRECT,'_*) => 'iterate + stream:= DEFIOSTREAM(['(MODE . INPUT),['FILE,fn,'DIRECT,'_*]],80,0) + while (not PLACEP (x:= READ_-LINE stream)) repeat + (s := SIZE x) < 26 => 'iterate + res:= [SUBSTRING(x,26,NIL),:res] + SHUT stream + res + +wordsOfString(s) == [UPCASE x for x in wordsOfStringKeepCase s] + +wordsOfStringKeepCase s == wordsOfString1(s,0) or [COPY s] + +wordsOfString1(s,j) == + k := or/[i for i in j..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => + tailWords:= + isBreakCharacter s.(k+1) => + n:= or/[i for i in (k+2)..SUB1(MAXINDEX(s))|not isBreakCharacter s.i] + null n => [SUBSTRING(s,k,nil)] + n > k+1 => [SUBSTRING(s,k,n-k-1),:wordsOfString1(s,n-1)] + m := or/[i for i in (k+2)..SUB1(MAXINDEX(s)) | isBreakCharacter s.i] => + [SUBSTRING(s,k,m-k),:wordsOfString1(s,m)] + [SUBSTRING(s,k,nil)] + k > j+1 => [SUBSTRING(s,j,k-j),:tailWords] + tailWords + nil + +isBreakCharacter x == null SMALL__LITER x + +-- SETANDFILEQ($functionTable,buildFunctionTable()) + +--======================================================================= +-- Augment Function Directories +--======================================================================= +add2WordFunctionTable fn == +--called from DEF + $functionTable and + null LASSOC(s := PNAME fn,HGET($functionTable,(key := UPCASE s.0))) => + HPUT($functionTable,key,[[s,:wordsOfString s],:HGET($functionTable,key)]) + +--======================================================================= +-- Guess Function Name +--======================================================================= +guess word == + u := bootFind word => INTERN u + nil + +bootFind word == + not $useWordFacility => NIL + list:= bootSearch word + PNAME word in list => nil --mismatch of directories: pretend it was not found + null list => centerAndHighlight('"no match found",80,'" ") + 1 = #list => doYouWant? first list + pickANumber(word,list) + +doYouWant? nam == + center80 ['"Do you mean",:bright nam,'"?"] + center80 ['"If so, type",:bright 'y,"or",:bright 'yes] + center80 ['"Anything else means",:bright 'no] + x := UPCASE queryUser nil + MEMQ(STRING2ID_-N(x,1),'(Y YES)) => nam + nil + +pickANumber(word,list) == + clearScreen() + centerNoHighlight(['"You asked for",:bright word],80,'"-") + centerAndHighlight('"Do you mean one of the following?",80,'" ") + n:= #list + xx:= (n > 99 => 3; n > 9 => 2; 1) + maxWidth:= 38 - 2*(1+xx) + [short,long] := say2Split(list,nil,nil,maxWidth) + extra:= + REMAINDER(length := # short,2) ^= 0 => 1 + 0 + halfLength:= length/2 + firstList:= TAKE(halfLength,short) + secondList:= TAKE(-halfLength,short) + secondStartIndex:= halfLength + extra + shortList:= + "append"/[[[:bright i,fillerSpaces(xx-WIDTH i,'" "),x], + [:bright(i+secondStartIndex),fillerSpaces(xx-WIDTH (i+halfLength),'" "),y]] + for i in 1.. for x in firstList for y in secondList] + say2PerLineThatFit shortList + i:= 1 + halfLength + if extra=1 then + sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),list.(i-1)] + for x in long for i in (1+length).. repeat + sayBrightly [:bright i,fillerSpaces(xx-WIDTH i,'" "),x] + center80 ['"If so: type a number between",:bright 1,'"and",:bright n,"and ENTER"] + center80 ['"Anything else means",:bright 'no] + y := queryUser nil + x:= string2Integer y + FIXP x and x >= 1 and x <= #list => list.(x-1) + nil + +bootSearch word == +--if not $functionTable then $functionTable:= buildFunctionTable() + if not $functionTable then $functionTable:= readFunctionTable() + key := PNAME word + list := + hasWildCard? key => + pattern := patternTran key -- converts * to & + pattern.0 ^= '_& => + [x for [x,:.] in HGET($functionTable,UPCASE pattern.0)| + match?(pattern,COPY x)] + "append"/[[x for [x,:.] in HGET($functionTable,k)| match?(pattern,COPY x)] + for k in HKEYS $functionTable] + findApproximateWords(PNAME word,$functionTable) + list + +findApproximateWords(word,table) == + words:= wordsOfString word + upperWord:= UPCASE COPY word + n := #words + threshold:= + n = 1 => 3 + 4 + alist:= HGET(table,UPCASE word.0) + + --first try to break up as list of words + firstTry := [x for [x,:wordList] in alist | p] where p == + n = #wordList => + sum := 0 + for entry in wordList for part in words while sum < threshold repeat + sum:= sum + deltaWordEntry(part,entry) + sum < threshold => true + n < 3 => false + sum := 0 + badWord := false + for entry in wordList for part in words while sum < threshold repeat + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => badWord := true + sum := 1000 + sum < threshold + n+1 = #wordList => --assume one word is missing + sum := 0 + badWord := false + for entries in tails wordList for part in words + while sum < threshold repeat + entry := first entries + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + entries := rest entries --skip this bad word + entry := first entries + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold + n-1 = #wordList => --assume one word too many + sum := 0 + badWord := false + for entry in wordList for parts in tails words + while sum < threshold repeat + part := first parts + k:= deltaWordEntry(part,entry) + k < 2 => sum:= sum + k + null badWord => + badWord := true + parts := rest parts --skip this bad word + part := first parts + k := deltaWordEntry(part,entry) + k < 2 => sum := sum + k + sum := 1000 + sum := 1000 + sum < threshold + false + firstTry => firstTry + + --no winners, so try flattening to upper case and checking again + + wordSize := SIZE word + lastThreshold := MAX(3,wordSize/2) + vec := GETREFV lastThreshold + for [x,:.] in alist repeat + k := deltaWordEntry(upperWord,UPCASE COPY x) + k < lastThreshold => vec.k := [x,:vec.k] + or/[vec.k for k in 0..MAXINDEX vec] + +guessFromList(key,stringList) == + threshold := MAX(3,(SIZE key)/2) + vec := GETREFV threshold + for x in stringList repeat + k := deltaWordEntry(key,x) + k < threshold => vec.k := [x,:vec.k] + or/[vec.k for k in 0..MAXINDEX vec] + +deltaWordEntry(word,entry) == + word = entry => 0 + ABS(diff := SIZE word - SIZE entry) > 4 => 1000 + canForgeWord(word,entry) + +--+ Note these are optimized definitions below-- see commented out versions +--+ to understand the algorithm +canForgeWord(word,entry) == + forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0) + +forge(word,w,W,entry,e,E,n) == + w > W => + e > E => n + QSADD1 QSPLUS(E-e,n) + e > E => QSADD1 QSPLUS(W-w,n) + word.w = entry.e => forge(word,w+1,W,entry,e+1,E,n) + w=W or e=E => forge(word,w+1,W,entry,e+1,E,QSADD1 n) + word.w=entry.(e+1) => + word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,QSADD1 n) + forge(word,w+1,W,entry,e+2,E,QSADD1 n) + word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,QSADD1 n) + + (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => + --if word is long, can we delete chars to match 2 consective chars + deltaW >= deltaE and + (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) + and word.(k+1) = entry.(e+1) => + forge(word,k+2,W,entry,e+2,E,QSPLUS(k-w,n)) + deltaW <= deltaE and + --if word is short, can we insert chars so as to match 2 consecutive chars + (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) + and word.(w+1) = entry.(k+1) => + forge(word,w+2,W,entry,k+2,E,QSPLUS(n,k-e)) + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + --check for two consecutive matches down the line + forge(word,w+1,W,entry,e+1,E,QSADD1 n) + +--+ DO NOT REMOVE DEFINITIONS BELOW which explain the algorithm +--+ canForgeWord(word,entry) ==-- +--+ [d,i,s,t] := forge(word,0,MAXINDEX word,entry,0,MAXINDEX entry,0,0,0,0) +--+ --d=deletions, i=insertions, s=substitutions, t=transpositions +--+ --list is formed only for tuning purposes-- remove later on +--+ d + i + s + t + +--+forge(word,w,W,entry,e,E,d,i,s,t) == +--+ w > W => +--+ e > E => [d,i,s,t] +--+ [d,E-e+i+1,s,t] +--+ e > E => [W-w+d+1,i,s,t] +--+ word.w = entry.e => forge(word,w+1,W,entry,e+1,E,d,i,s,t) +--+ w=W or e=E => forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ word.w=entry.(e+1) => +--+ word.(w+1) = entry.e => forge(word,w+2,W,entry,e+2,E,d,i,s,t+1) +--+ forge(word,w+1,W,entry,e+2,E,d,i+1,s,t) +--+ word.(w+1)=entry.e => forge(word,w+2,W,entry,e+1,E,d+1,i,s,t) +--+ +--+ (deltaW := W-w) > 1 and (deltaE := E-e) > 1 => +--+ --if word is long, can we delete chars to match 2 consective chars +--+ deltaW >= deltaE and +--+ (k := or/[j for j in (w+2)..(W-1) | word.j = entry.e]) +--+ and word.(k+1) = entry.(e+1) => +--+ forge(word,k+2,W,entry,e+2,E,d+k-w,i,s,t) +--+ deltaW <= deltaE and +--+ --if word is short, can we insert chars so as to match 2 consecutive chars +--+ (k := or/[j for j in (e+2)..(E-1) | word.w = entry.j]) +--+ and word.(w+1) = entry.(k+1) => +--+ forge(word,w+2,W,entry,k+2,E,d,i+k-e,s,t) +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) +--+ --check for two consecutive matches down the line +--+ forge(word,w+1,W,entry,e+1,E,d,i,s+1,t) + +--======================================================================= +-- String Pattern Matching +--======================================================================= +patternTran pattern == + null hasWildCard? pattern and LITER pattern.0 and + UPCASE copy pattern = pattern => + name:= abbreviation? INTERN pattern + or browseError [:bright pattern, + '"is not a constructor abbreviation"] + DOWNCASE PNAME name + maskConvert DOWNCASE pattern + +hasWildCard? str == + or/[str.i = '_? and (i=0 or not(str.(i-1) = '__ )) for i in 0..MAXINDEX str] + +maskConvert str == +--replace all ? not preceded by an underscore by & + buf:= GETSTR(#str) + j:= 0 --index into res + final := MAXINDEX str + for i in 0..final repeat + char := str.i + if char = '__ and i < final then + i:= i+1 + char := str.i + else if char = '_? then char := '_& + SUFFIX(char,buf) + buf + + +infix?(s,t,x) == #s + #t >= #x and prefix?(s,x) and suffix?(t,x) + +prefix?(s,t) == substring?(s,t,0) + +suffix?(s,t) == + m := #s; n := #t + if m > n then return false + substring?(s,t,(n-m)) + +obSearch x == + vec:= OBARRAY() + pattern:= PNAME x + [y for i in 0..MAXINDEX OBARRAY() | + (IDENTP (y := vec.i) or CVEC y) and match?(pattern,COPY y)] + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} -- cgit v1.2.3