From 2ac7efb87c75f202ee89d53bf5a480402d11322f Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 19 Oct 2007 17:41:36 +0000 Subject: remove more pamphlets --- src/interp/br-prof.boot | 269 ++++ src/interp/br-prof.boot.pamphlet | 290 ----- src/interp/compress.boot | 69 ++ src/interp/compress.boot.pamphlet | 89 -- src/interp/i-output.boot | 2439 ++++++++++++++++++++++++++++++++++++ src/interp/i-output.boot.pamphlet | 2483 ------------------------------------- src/interp/interop.boot | 607 +++++++++ src/interp/interop.boot.pamphlet | 632 ---------- 8 files changed, 3384 insertions(+), 3494 deletions(-) create mode 100644 src/interp/br-prof.boot delete mode 100644 src/interp/br-prof.boot.pamphlet create mode 100644 src/interp/compress.boot delete mode 100644 src/interp/compress.boot.pamphlet create mode 100644 src/interp/i-output.boot delete mode 100644 src/interp/i-output.boot.pamphlet create mode 100644 src/interp/interop.boot delete mode 100644 src/interp/interop.boot.pamphlet diff --git a/src/interp/br-prof.boot b/src/interp/br-prof.boot new file mode 100644 index 00000000..d0c15452 --- /dev/null +++ b/src/interp/br-prof.boot @@ -0,0 +1,269 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +--====================> 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 deleted file mode 100644 index cc83fd57..00000000 --- a/src/interp/br-prof.boot.pamphlet +++ /dev/null @@ -1,290 +0,0 @@ -\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. - -@ - -<<*>>= -<> - -)package "BOOT" - ---====================> 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/compress.boot b/src/interp/compress.boot new file mode 100644 index 00000000..136aa896 --- /dev/null +++ b/src/interp/compress.boot @@ -0,0 +1,69 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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 deleted file mode 100644 index ddf74136..00000000 --- a/src/interp/compress.boot.pamphlet +++ /dev/null @@ -1,89 +0,0 @@ -\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/i-output.boot b/src/interp/i-output.boot new file mode 100644 index 00000000..055ddbc5 --- /dev/null +++ b/src/interp/i-output.boot @@ -0,0 +1,2439 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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" + +--Modified JHD February 1993: see files miscout.input for some tests of this +-- General principle is that maprin0 is the top-level routine, +-- which calls maprinChk to print the object (placing certain large +-- matrices on a look-aside list), then calls maprinRows to print these. +-- These prints call maprinChk recursively, and maprinChk has to ensure that +-- we do not end up in an infinite recursion: matrix1 = matrix2 ... + +--% Output display routines + +$defaultSpecialCharacters == [ + EBCDIC( 28), -- upper left corner + EBCDIC( 27), -- upper right corner + EBCDIC( 30), -- lower left corner + EBCDIC( 31), -- lower right corner + EBCDIC( 79), -- vertical bar + EBCDIC( 45), -- horizontal bar + EBCDIC(144), -- APL quad + EBCDIC(173), -- left bracket + EBCDIC(189), -- right bracket + EBCDIC(192), -- left brace + EBCDIC(208), -- right brace + EBCDIC( 59), -- top box tee + EBCDIC( 62), -- bottom box tee + EBCDIC( 63), -- right box tee + EBCDIC( 61), -- left box tee + EBCDIC( 44), -- center box tee + EBCDIC(224) -- back slash + ] + +$plainSpecialCharacters0 == [ + EBCDIC( 78), -- upper left corner (+) + EBCDIC( 78), -- upper right corner (+) + EBCDIC( 78), -- lower left corner (+) + EBCDIC( 78), -- lower right corner (+) + EBCDIC( 79), -- vertical bar + EBCDIC( 96), -- horizontal bar (-) + EBCDIC(111), -- APL quad (?) + EBCDIC(173), -- left bracket + EBCDIC(189), -- right bracket + EBCDIC(192), -- left brace + EBCDIC(208), -- right brace + EBCDIC( 78), -- top box tee (+) + EBCDIC( 78), -- bottom box tee (+) + EBCDIC( 78), -- right box tee (+) + EBCDIC( 78), -- left box tee (+) + EBCDIC( 78), -- center box tee (+) + EBCDIC(224) -- back slash + ] + +$plainSpecialCharacters1 == [ + EBCDIC(107), -- upper left corner (,) + EBCDIC(107), -- upper right corner (,) + EBCDIC(125), -- lower left corner (') + EBCDIC(125), -- lower right corner (') + EBCDIC( 79), -- vertical bar + EBCDIC( 96), -- horizontal bar (-) + EBCDIC(111), -- APL quad (?) + EBCDIC(173), -- left bracket + EBCDIC(189), -- right bracket + EBCDIC(192), -- left brace + EBCDIC(208), -- right brace + EBCDIC( 78), -- top box tee (+) + EBCDIC( 78), -- bottom box tee (+) + EBCDIC( 78), -- right box tee (+) + EBCDIC( 78), -- left box tee (+) + EBCDIC( 78), -- center box tee (+) + EBCDIC(224) -- back slash + ] + +$plainSpecialCharacters2 == [ + EBCDIC( 79), -- upper left corner (|) + EBCDIC( 79), -- upper right corner (|) + EBCDIC( 79), -- lower left corner (|) + EBCDIC( 79), -- lower right corner (|) + EBCDIC( 79), -- vertical bar + EBCDIC( 96), -- horizontal bar (-) + EBCDIC(111), -- APL quad (?) + EBCDIC(173), -- left bracket + EBCDIC(189), -- right bracket + EBCDIC(192), -- left brace + EBCDIC(208), -- right brace + EBCDIC( 78), -- top box tee (+) + EBCDIC( 78), -- bottom box tee (+) + EBCDIC( 78), -- right box tee (+) + EBCDIC( 78), -- left box tee (+) + EBCDIC( 78), -- center box tee (+) + EBCDIC(224) -- back slash + ] + +$plainSpecialCharacters3 == [ + EBCDIC( 96), -- upper left corner (-) + EBCDIC( 96), -- upper right corner (-) + EBCDIC( 96), -- lower left corner (-) + EBCDIC( 96), -- lower right corner (-) + EBCDIC( 79), -- vertical bar + EBCDIC( 96), -- horizontal bar (-) + EBCDIC(111), -- APL quad (?) + EBCDIC(173), -- left bracket + EBCDIC(189), -- right bracket + EBCDIC(192), -- left brace + EBCDIC(208), -- right brace + EBCDIC( 78), -- top box tee (+) + EBCDIC( 78), -- bottom box tee (+) + EBCDIC( 78), -- right box tee (+) + EBCDIC( 78), -- left box tee (+) + EBCDIC( 78), -- center box tee (+) + EBCDIC(224) -- back slash + ] + +$plainRTspecialCharacters == [ + '_+, -- upper left corner (+) + '_+, -- upper right corner (+) + '_+, -- lower left corner (+) + '_+, -- lower right corner (+) + '_|, -- vertical bar + '_-, -- horizontal bar (-) + '_?, -- APL quad (?) + '_[, -- left bracket + '_], -- right bracket + '_{, -- left brace + '_}, -- right brace + '_+, -- top box tee (+) + '_+, -- bottom box tee (+) + '_+, -- right box tee (+) + '_+, -- left box tee (+) + '_+, -- center box tee (+) + '_\ -- back slash + ] + +makeCharacter n ==> INTERN(STRING(CODE_-CHAR n)) + +$RTspecialCharacters == [ + makeCharacter 218, -- upper left corner (+) + makeCharacter 191, -- upper right corner (+) + makeCharacter 192, -- lower left corner (+) + makeCharacter 217, -- lower right corner (+) + makeCharacter 179, -- vertical bar + makeCharacter 196, -- horizontal bar (-) + $quadSymbol, -- APL quad (?) + '_[, -- left bracket + '_], -- right bracket + '_{, -- left brace + '_}, -- right brace + makeCharacter 194, -- top box tee (+) + makeCharacter 193, -- bottom box tee (+) + makeCharacter 180, -- right box tee (+) + makeCharacter 195, -- left box tee (+) + makeCharacter 197, -- center box tee (+) + '_\ -- back slash + ] + +$specialCharacters := $RTspecialCharacters + +$specialCharacterAlist == '( + (ulc . 0)_ + (urc . 1)_ + (llc . 2)_ + (lrc . 3)_ + (vbar . 4)_ + (hbar . 5)_ + (quad . 6)_ + (lbrk . 7)_ + (rbrk . 8)_ + (lbrc . 9)_ + (rbrc . 10)_ + (ttee . 11)_ + (btee . 12)_ + (rtee . 13)_ + (ltee . 14)_ + (ctee . 15)_ + (bslash . 16)_ + ) + +$collectOutput := nil + +specialChar(symbol) == + -- looks up symbol in $specialCharacterAlist, gets the index + -- into the EBCDIC table, and returns the appropriate character + null (code := IFCDR ASSQ(symbol,$specialCharacterAlist)) => '"?" + ELT($specialCharacters,code) + +rbrkSch() == PNAME specialChar 'rbrk +lbrkSch() == PNAME specialChar 'lbrk +quadSch() == PNAME specialChar 'quad + +isBinaryInfix x == + x in '(_= _+ _- _* _/ _*_* _^ "=" "+" "-" "*" "/" "**" "^") + +stringApp([.,u],x,y,d) == + appChar(STRCONC($DoubleQuote,atom2String u,$DoubleQuote),x,y,d) + +stringWidth u == + u is [.,u] or THROW('outputFailure,'outputFailure) + 2+#u + +obj2String o == + atom o => + STRINGP o => o + o = " " => '" " + o = ")" => '")" + o = "(" => '"(" + STRINGIMAGE o + APPLY('STRCONC,[obj2String o' for o' in o]) + +APP(u,x,y,d) == + atom u => appChar(atom2String u,x,y,d) + u is [[op,:.],a] and (s:= GETL(op,'PREFIXOP)) => + GETL(op,'isSuffix) => appChar(s,x+WIDTH a,y,APP(a,x,y,d)) + APP(a,x+#s,y,appChar(s,x,y,d)) + u is [[id,:.],:.] => + fn := GETL(id,'APP) => FUNCALL(fn,u,x,y,d) + not NUMBERP id and (d':= appInfix(u,x,y,d))=> d' + appelse(u,x,y,d) + appelse(u,x,y,d) + +atom2String x == + IDENTP x => PNAME x + STRINGP x => x + stringer x + +-- General convention in the "app..." functions: +-- Added from an attempt to fix bugs by JHD: 2 Aug 89 +-- the first argument is what has to be printed +-- the second - x - is the horizontal distance along the page +-- at which to start +-- the third - y - is some vertical hacking control +-- the foruth - d - is the "layout" so far +-- these functions return an updated "layout so far" in general + +appChar(string,x,y,d) == + if CHARP string then string := PNAME string + line:= LASSOC(y,d) => + if MAXINDEX string = 1 and char(string.0) = "%" then + string.1="b" => + bumpDeltaIfTrue:= true + string.0:= EBCDIC 29 + string.1:= EBCDIC 200 + string.1="d" => + bumpDeltaIfTrue:= true + string.0:= EBCDIC 29 + string.1:= EBCDIC 65 + shiftedX:= (y=0 => x+$highlightDelta; x) + --shift x for brightening characters -- presently only if y=0 + RPLACSTR(line,shiftedX,n:=#string,string,0,n) + if bumpDeltaIfTrue=true then $highlightDelta:= $highlightDelta+1 + d + appChar(string,x,y,nconc(d,[[y,:GETFULLSTR(10+$LINELENGTH+$MARGIN," ")]])) + +print(x,domain) == + dom:= devaluate domain + $InteractiveMode: local:= true + $dontDisplayEquatnum: local:= true + output(x,dom) + +mathprintWithNumber x == + x:= outputTran x + maprin + $IOindex => ['EQUATNUM,$IOindex,x] + x + +mathprint x == + x := outputTran x + $saturn => texFormat1 x + maprin x + +sayMath u == + for x in u repeat acc:= concat(acc,linearFormatName x) + sayALGEBRA acc + +--% Output transformations + +outputTran x == + x in '("failed" "nil" "prime" "sqfr" "irred") => + STRCONC('"_"",x,'"_"") + STRINGP x => x + VECP x => + outputTran ['BRACKET,['AGGLST,:[x.i for i in 0..MAXINDEX x]]] + NUMBERP x => + MINUSP x => ["-",MINUS x] + x + atom x => + x=$EmptyMode => specialChar 'quad + x + x is [c,var,mode] and c in '(_pretend _: _:_: _@) => + var := outputTran var + if PAIRP var then var := ['PAREN,var] + ['CONCATB,var,c,obj2String prefix2String mode] + x is ['ADEF,vars,.,.,body] => + vars := + vars is [x] => x + ['Tuple,:vars] + outputTran ["+->", vars, body] + x is ['MATRIX,:m] => outputTranMatrix m + x is ['matrix,['construct,c]] and + c is ['COLLECT,:m,d] and d is ['construct,e] and e is ['COLLECT,:.] => + outputTran ['COLLECT,:m,e] + x is ['LIST,:l] => outputTran ['BRACKET,['AGGLST,:l]] + x is ['MAP,:l] => outputMapTran l + x is ['brace, :l] => + ['BRACE, ['AGGLST,:[outputTran y for y in l]]] + x is ['return,l] => ['return,outputTran l] + x is ['return,.,:l] => ['return,:outputTran l] + x is ['construct,:l] => + ['BRACKET,['AGGLST,:[outputTran y for y in l]]] + + x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or + domain is ['Float]) and INTEGERP x and INTEGERP y and INTEGERP z and + z > 0 and (float := getFunctionFromDomain("float",domain,[$Integer,$Integer,$PositiveInteger])) => + f := SPADCALL(x,y,z,float) + o := coerceInteractive(mkObjWrap(f, domain), '(OutputForm)) + objValUnwrap o + + [op,:l]:= flattenOps x + --needed since "op" is string in some spad code + if STRINGP op then (op := INTERN op; x:= [op,:l]) + op = 'LAMBDA_-CLOSURE => 'Closure + x is ['break,:.] => 'break + x is ['SEGMENT,a] => + a' := outputTran a + if LISTP a' then a' := ['PAREN,a'] + ['SEGMENT,a'] + x is ['SEGMENT,a,b] => + a' := outputTran a + b' := outputTran b + if LISTP a' then a' := ['PAREN,a'] + if LISTP b' then b' := ['PAREN,b'] + ['SEGMENT,a',b'] + + op is ["$elt",targ,fun] or not $InteractiveMode and op is ["elt",targ,fun] => + -- l has the args + targ' := obj2String prefix2String targ + if 2 = #targ then targ' := ['PAREN,targ'] + ['CONCAT,outputTran [fun,:l],'"$",targ'] + x is ["$elt",targ,c] or not $InteractiveMode and x is ["elt",targ,c] => + targ' := obj2String prefix2String targ + if 2 = #targ then targ' := ['PAREN,targ'] + ['CONCAT,outputTran c,'"$",targ'] + x is ["-",a,b] => + a := outputTran a + b := outputTran b + INTEGERP b => + b < 0 => ["+",a,-b] + ["+",a,["-",b]] + b is ["-",c] => ["+",a,c] + ["+",a,["-",b]] + + -- next stuff translates exp(log(foo4)/foo3) into ROOT(foo4,foo3) + (x is ["**", ='"%e",foo1]) and (foo1 is [ ='"/",foo2, foo3]) and + INTEGERP(foo3) and (foo2 is ['log,foo4]) => + foo3 = 2 => ['ROOT,outputTran foo4] + ['ROOT,outputTran foo4,outputTran foo3] + (x is ["**", ='"%e",foo1]) and (foo1 is [op',foo2, foo3]) and + (op' = '"*") and ((foo3 is ['log,foo4]) or (foo2 is ['log,foo4])) => + foo3 is ['log,foo4] => + ["**", outputTran foo4, outputTran foo2] + foo4 := CADR foo2 + ["**", outputTran foo4, outputTran foo3] + op = 'IF => outputTranIf x + op = 'COLLECT => outputTranCollect x + op = 'REDUCE => outputTranReduce x + op = 'REPEAT => outputTranRepeat x + op = 'SEQ => outputTranSEQ x + op in '(cons nconc) => outputConstructTran x + l:= [outputTran y for y in l] + op = "*" => + l is [a] => outputTran a + l is [["-",a],:b] => + -- now this is tricky because we've already outputTran the list + -- expect trouble when outputTran hits b again + -- some things object to being outputTran twice ,e.g.matrices + -- same thing a bit lower down for "/" + a=1 => outputTran ["-",[op,:b]] + outputTran ["-",[op,a,:b]] + [op,:"append"/[(ss is ["*",:ll] => ll; [ss]) for ss in l]] + op = "+" => + l is [a] => outputTran a + [op,:"append"/[(ss is ["+",:ll] => ll; [ss]) for ss in l]] + op = "/" => + if $fractionDisplayType = 'horizontal then op := 'SLASH + else op := 'OVER + l is [["-",a],:b] => outputTran ["-",[op,a,:b]] + [outputTran op,:l] + op="|" and l is [["Tuple",:u],pred] => + ['PAREN,["|",['AGGLST,:l],pred]] + op='Tuple => ['PAREN,['AGGLST,:l]] + op='LISTOF => ['AGGLST,:l] + IDENTP op and ^(op in '(_* _*_*) ) and char("*") = (PNAME op).0 => + mkSuperSub(op,l) + [outputTran op,:l] + +-- The next two functions are designed to replace successive instances of +-- binary functions with the n-ary equivalent, cutting down on recursion +-- in outputTran and in partciular allowing big polynomials to be printed +-- without stack overflow. MCD. +flattenOps l == + [op, :args ] := l + op in ['"+",'"*","+","*"] => + [op,:checkArgs(op,args)] + l + +checkArgs(op,tail) == + head := [] + while tail repeat + term := first tail + atom term => + head := [term,:head] + tail := rest tail + not LISTP term => -- never happens? + head := [term,:head] + tail := rest tail + op=first term => + tail := [:rest term,:rest tail] + head := [term,:head] + tail := rest tail + REVERSE head + +outputTranSEQ ['SEQ,:l,exitform] == + if exitform is ['exit,.,a] then exitform := a + ['SC,:[outputTran x for x in l],outputTran exitform] + +outputTranIf ['IF,x,y,z] == + y = 'noBranch => + ['CONCATB,'if,['CONCATB,'not,outputTran x],'then,outputTran z] + z = 'noBranch => + ['CONCATB,'if,outputTran x,'then,outputTran y] + y' := outputTran y + z' := outputTran z +--y' is ['SC,:.] or z' is ['SC,:.] => +-- ['CONCATB,'if,outputTran x, +-- ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] +--['CONCATB,'if,outputTran x,'then,outputTran y,'else,outputTran z] + ['CONCATB,'if,outputTran x, + ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] + +outputMapTran l == + null l => NIL -- should not happen + + -- display subscripts linearly + $linearFormatScripts : local := true + + -- get the real names of the parameters + alias := get($op,'alias,$InteractiveFrame) + + rest l => -- if multiple forms, call repeatedly + ['SC,:[outputMapTran0(ll,alias) for ll in l]] + outputMapTran0(first l,alias) + +outputMapTran0(argDef,alias) == + arg := first argDef + def := rest argDef + [arg',:def'] := simplifyMapPattern(argDef,alias) + arg' := outputTran arg' + if null arg' then arg' := '"()" + ['CONCATB,$op,outputTran arg',"==",outputTran def'] + +outputTranReduce ['REDUCE,op,.,body] == + ['CONCAT,op,"/",outputTran body] + +outputTranRepeat ["REPEAT",:itl,body] == + body' := outputTran body + itl => + itlist:= outputTranIteration itl + ['CONCATB,itlist,'repeat,body'] + ['CONCATB,'repeat,body'] + +outputTranCollect [.,:itl,body] == + itlist:= outputTranIteration itl + ['BRACKET,['CONCATB,outputTran body,itlist]] + +outputTranIteration itl == + null rest itl => outputTranIterate first itl + ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl] + +outputTranIterate x == + x is ['STEP,n,init,step,:final] => + init' := outputTran init + if LISTP init then init' := ['PAREN,init'] + final' := + final => + LISTP first final => [['PAREN,outputTran first final]] + [outputTran first final] + NIL + ['STEP,outputTran n,init',outputTran step,:final'] + x is ["IN",n,s] => ["IN",outputTran n,outputTran s] + x is [op,p] and op in '(_| UNTIL WHILE) => + op:= DOWNCASE op + ['CONCATB,op,outputTran p] + throwKeyedMsg("S2IX0008",['outputTranIterate,['"illegal iterate: ",x]]) + +outputConstructTran x == + x is [op,a,b] => + a:= outputTran a + b:= outputTran b + op="cons" => + b is ['construct,:l] => ['construct,a,:l] + ['BRACKET,['AGGLST,:[a,[":",b]]]] + op="nconc" => + aPart := + a is ['construct,c] and c is ['SEGMENT,:.] => c + [":",a] + b is ['construct,:l] => ['construct,aPart,:l] + ['BRACKET,['AGGLST,aPart,[":",b]]] + [op,a,b] + atom x => x + [outputTran first x,:outputConstructTran rest x] + +outputTranMatrix x == + not VECP x => + -- assume that the only reason is that we've been done before + ["MATRIX",:x] + --keyedSystemError("S2GE0016",['"outputTranMatrix", + -- '"improper internal form for matrix found in output routines"]) + ["MATRIX",nil,:[outtranRow x.i for i in 0..MAXINDEX x]] where + outtranRow x == + not VECP x => + keyedSystemError("S2GE0016",['"outputTranMatrix", + '"improper internal form for matrix found in output routines"]) + ["ROW",:[outputTran x.i for i in 0..MAXINDEX x]] + +mkSuperSub(op,argl) == + $linearFormatScripts => linearFormatForm(op,argl) +-- l := [(STRINGP f => f; STRINGIMAGE f) +-- for f in linearFormatForm(op,argl)] +-- "STRCONC"/l + 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]) + -- if there is just a subscript use the SUB special form + #indexList=2 => + subPart:= ['SUB,cleanOp,:take(indexList.1,argl)] + l:= drop(indexList.1,argl) => [subPart,:l] + subPart + -- otherwise use the SUPERSUB form + superSubPart := NIL + for i in rest indexList repeat + scripts := + this:= take(i,argl) + argl:= drop(i,argl) + i=0 => ['AGGLST] + i=1 => first this + ['AGGLST,:this] + superSubPart := cons(scripts,superSubPart) + superSub := ['SUPERSUB,cleanOp,:reverse superSubPart] + argl => [superSub,:argl] + superSub + +timesApp(u,x,y,d) == + rightPrec:= getOpBindingPower("*","Led","right") + firstTime:= true + for arg in rest u repeat + op:= keyp arg + if ^firstTime and (needBlankForRoot(lastOp,op,arg) or + needStar(wasSimple,wasQuotient,wasNumber,arg,op) or + wasNumber and op = 'ROOT and subspan arg = 1) then + d:= APP(BLANK,x,y,d) + x:= x+1 + [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg + wasSimple:= atom arg and not NUMBERP arg or isRationalNumber arg + wasQuotient:= isQuotient op + wasNumber:= NUMBERP arg + lastOp := op + firstTime:= nil + d + +needBlankForRoot(lastOp,op,arg) == + lastOp ^= "^" and lastOp ^= "**" and not(subspan(arg)>0) => false + op = "**" and keyp CADR arg = 'ROOT => true + op = "^" and keyp CADR arg = 'ROOT => true + op = 'ROOT and CDDR arg => true + false + +stepApp([.,a,init,one,:optFinal],x,y,d) == + d:= appChar('"for ",x,y,d) + d:= APP(a,w:=x+4,y,d) + d:= appChar('" in ",w:=w+WIDTH a,y,d) + d:= APP(init,w:=w+4,y,d) + d:= APP('"..",w:=w+WIDTH init,y,d) + if optFinal then d:= APP(first optFinal,w+2,y,d) + d + +stepSub [.,a,init,one,:optFinal] == + m:= MAX(subspan a,subspan init) + optFinal => MAX(m,subspan first optFinal) + m + +stepSuper [.,a,init,one,:optFinal] == + m:= MAX(superspan a,superspan init) + optFinal => MAX(m,superspan first optFinal) + m + +stepWidth [.,a,init,one,:optFinal] == + 10+WIDTH a+WIDTH init+(optFinal => WIDTH first optFinal; 0) + +inApp([.,a,s],x,y,d) == --for [IN,a,s] + d:= appChar('"for ",x,y,d) + d:= APP(a,x+4,y,d) + d:= appChar('" in ",x+WIDTH a+4,y,d) + APP(s,x+WIDTH a+8,y,d) + +inSub [.,a,s] == MAX(subspan a,subspan s) + +inSuper [.,a,s] == MAX(superspan a,superspan s) + +inWidth [.,a,s] == 8+WIDTH a+WIDTH s + +centerApp([.,u],x,y,d) == + d := APP(u,x,y,d) + +concatApp([.,:l],x,y,d) == concatApp1(l,x,y,d,0) + +concatbApp([.,:l],x,y,d) == concatApp1(l,x,y,d,1) + +concatApp1(l,x,y,d,n) == + for u in l repeat + d:= APP(u,x,y,d) + x:=x+WIDTH u+n + d + +concatSub [.,:l] == "MAX"/[subspan x for x in l] + +concatSuper [.,:l] == "MAX"/[superspan x for x in l] + +concatWidth [.,:l] == +/[WIDTH x for x in l] + +concatbWidth [.,:l] == +/[1+WIDTH x for x in l]-1 + +exptApp([.,a,b],x,y,d) == + pren:= exptNeedsPren a + d:= + pren => appparu(a,x,y,d) + APP(a,x,y,d) + x':= x+WIDTH a+(pren => 2;0) + y':= 1+y+superspan a+subspan b + (0=superspan a => 0; -1) + APP(b,x',y',d) + +exptNeedsPren a == + atom a and null (INTEGERP a and a < 0) => false + key:= keyp a + key = "OVER" => true -- added JHD 2/Aug/90 + (key="SUB") or (null GETL(key,"Nud") and null GETL(key,"Led")) => false + true + +exptSub u == subspan CADR u + +exptSuper [.,a,b] == superspan a+height b+(superspan a=0 => 0;-1) + +exptWidth [.,a,b] == WIDTH a+WIDTH b+(exptNeedsPren a => 2;0) + +needStar(wasSimple,wasQuotient,wasNumber,cur,op) == + wasQuotient or isQuotient op => true + wasSimple => + atom cur or keyp cur="SUB" or isRationalNumber cur or op="**" or op = "^" or + (atom op and ^NUMBERP op and ^GETL(op,"APP")) + wasNumber => + NUMBERP(cur) or isRationalNumber cur or + ((op="**" or op ="^") and NUMBERP(CADR cur)) + +isQuotient op == + op="/" or op="OVER" + +timesWidth u == + rightPrec:= getOpBindingPower("*","Led","right") + firstTime:= true + w:= 0 + for arg in rest u repeat + op:= keyp arg + if ^firstTime and needStar(wasSimple,wasQuotient,wasNumber,arg,op) then + w:= w+1 + if infixArgNeedsParens(arg, rightPrec, "left") then w:= w+2 + w:= w+WIDTH arg + wasSimple:= atom arg and not NUMBERP arg --or isRationalNumber arg + wasQuotient:= isQuotient op + wasNumber:= NUMBERP arg + firstTime:= nil + w + +plusApp([.,frst,:rst],x,y,d) == + appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d)) + +appSum(u,x,y,d) == + for arg in u repeat + infixOp:= + syminusp arg => "-" + "+" + opString:= GETL(infixOp,"INFIXOP") or '"," + d:= APP(opString,x,y,d) + x:= x+WIDTH opString + arg:= absym arg --negate a neg. number or remove leading "-" + rightPrec:= getOpBindingPower(infixOp,"Led","right") + if infixOp = "-" then rightPrec:=rightPrec +1 + -- that +1 added JHD 2 Aug 89 to prevent x-(y+z) printing as x-y+z + -- Sutor found the example: + -- )cl all + -- p : P[x] P I := x - y - z + -- p :: P[x] FR P I + -- trailingCoef % + [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg + d + +appInfix(e,x,y,d) == + op := keyp e + leftPrec:= getOpBindingPower(op,"Led","left") + leftPrec = 1000 => return nil --no infix operator is allowed default value + rightPrec:= getOpBindingPower(op,"Led","right") + #e < 2 => throwKeyedMsg("S2IX0008",['appInfix, + '"fewer than 2 arguments to an infix function"]) + opString:= GETL(op,"INFIXOP") or '"," + opWidth:= WIDTH opString + [.,frst,:rst]:= e + null rst => + GETL(op,"isSuffix") => + [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) + d:= appChar(opString,x,y,d) + THROW('outputFailure,'outputFailure) + [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) --app in left arg + for arg in rst repeat + d:= appChar(opString,x,y,d) --app in the infix operator + x:= x+opWidth + [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",opString) --app in right arg + d + +appconc(d,x,y,w) == NCONC(d,[[[x,:y],:w]]) + +infixArgNeedsParens(arg, prec, leftOrRight) == + prec > getBindingPowerOf(leftOrRight, arg) + 1 + +appInfixArg(u,x,y,d,prec,leftOrRight,string) == + insertPrensIfTrue:= infixArgNeedsParens(u,prec,leftOrRight) + d:= + insertPrensIfTrue => appparu(u,x,y,d) + APP(u,x,y,d) + x:= x+WIDTH u + if string then d:= appconc(d,x,y,string) + [d,(insertPrensIfTrue => x+2; x)] + +leftBindingPowerOf(x, ind) == + y := GETL(x, ind) + y => ELEMN(y, 3, 0) + 0 + +rightBindingPowerOf(x, ind) == + y := GETL(x, ind) + y => ELEMN(y, 4, 105) + 105 + +getBindingPowerOf(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 => getBindingPowerOf(key,["/",:argl]) - 1 + op = 'OVER => getBindingPowerOf(key,["/",:argl]) + (n:= #argl)=1 => + key="left" and (m:= getOpBindingPower(op,"Nud","left")) => m + key="right" and (m:= getOpBindingPower(op,"Nud","right")) => m + 1000 + n>1 => + key="left" and (m:= getOpBindingPower(op,"Led","left")) => m + key="right" and (m:= getOpBindingPower(op,"Led","right")) => m + op="ELT" => 1002 + 1000 + 1000 + 1002 + +getOpBindingPower(op,LedOrNud,leftOrRight) == + if op in '(SLASH OVER) then op := "/" + exception:= + leftOrRight="left" => 0 + 105 + bp:= + leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) + rightBindingPowerOf(op,LedOrNud) + bp^=exception => bp + 1000 + +--% Brackets +bracketApp(u,x,y,d) == + u is [.,u] or THROW('outputFailure,'outputFailure) + d:= appChar(specialChar 'lbrk,x,y,d) + d:=APP(u,x+1,y,d) + appChar(specialChar 'rbrk,x+1+WIDTH u,y,d) + +--% Braces +braceApp(u,x,y,d) == + u is [.,u] or THROW('outputFailure,'outputFailure) + d:= appChar(specialChar 'lbrc,x,y,d) + d:=APP(u,x+1,y,d) + appChar(specialChar 'rbrc,x+1+WIDTH u,y,d) + +--% Aggregates +aggWidth u == + rest u is [a,:l] => WIDTH a + +/[1+WIDTH x for x in l] + 0 + +aggSub u == subspan rest u + +aggSuper u == superspan rest u + +aggApp(u,x,y,d) == aggregateApp(rest u,x,y,d,",") + +aggregateApp(u,x,y,d,s) == + if u is [a,:l] then + d:= APP(a,x,y,d) + x:= x+WIDTH a + for b in l repeat + d:= APP(s,x,y,d) + d:= APP(b,x+1,y,d) + x:= x+1+WIDTH b + d + +--% Function to compute Width + +outformWidth u == --WIDTH as called from OUTFORM to do a COPY + STRINGP u => + u = $EmptyString => 0 + u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1 + #u + atom u => # atom2String u + WIDTH COPY u + +WIDTH u == + STRINGP u => + u = $EmptyString => 0 + u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1 + #u + INTEGERP u => + if (u < 1) then + negative := 1 + u := -u + else + negative := 0 + -- Try and be fairly exact for smallish integers: + u = 0 => 1 + u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR ((LOG10 u) + 0.0000001) + -- Rough guess: integer-length returns log2 rounded up, so divide it by + -- roughly log2(10). This should return an over-estimate, but for objects + -- this big does it matter? + FLOOR(INTEGER_-LENGTH(u)/3.3) + atom u => # atom2String u + putWidth u is [[.,:n],:.] => n + THROW('outputFailure,'outputFailure) + +putWidth u == + atom u or u is [[.,:n],:.] and NUMBERP n => u + op:= keyp u +--NUMBERP op => nil + leftPrec:= getBindingPowerOf("left",u) + rightPrec:= getBindingPowerOf("right",u) + [firstEl,:l] := u + interSpace:= + SYMBOLP firstEl and GETL(firstEl,"INFIXOP") => 0 + 1 + argsWidth:= + l is [firstArg,:restArg] => + RPLACA(rest u,putWidth firstArg) + for y in tails restArg repeat RPLACA(y,putWidth first y) + widthFirstArg:= + 0=interSpace and infixArgNeedsParens(firstArg,leftPrec,"right")=> + 2+WIDTH firstArg + WIDTH firstArg + widthFirstArg + +/[interSpace+w for x in restArg] where w() == + 0=interSpace and infixArgNeedsParens(x, rightPrec, "left") => + 2+WIDTH x + WIDTH x + 0 + newFirst:= + atom (oldFirst:= first u) => + fn:= GETL(oldFirst,"WIDTH") => + [oldFirst,:FUNCALL(fn,[oldFirst,:l])] + if l then ll := rest l else ll := nil + [oldFirst,:opWidth(oldFirst,ll)+argsWidth] + [putWidth oldFirst,:2+WIDTH oldFirst+argsWidth] + RPLACA(u,newFirst) + u + +opWidth(op,has2Arguments) == + op = "EQUATNUM" => 4 + NUMBERP op => 2+SIZE STRINGIMAGE op + null has2Arguments => + a:= GETL(op,"PREFIXOP") => SIZE a + 2+SIZE PNAME op + a:= GETL(op,"INFIXOP") => SIZE a + 2+SIZE PNAME op + +matrixBorder(x,y1,y2,d,leftOrRight) == + y1 = y2 => + c := + leftOrRight = 'left => specialChar('lbrk) + specialChar('rbrk) + APP(c,x,y1,d) + for y in y1..y2 repeat + c := + y = y1 => + leftOrRight = 'left => specialChar('llc) + specialChar('lrc) + y = y2 => + leftOrRight = 'left => specialChar('ulc) + specialChar('urc) + specialChar('vbar) + d := APP(c,x,y,d) + d + +isRationalNumber x == nil + +widthSC u == 10000 + +--% The over-large matrix package + +maprinSpecial(x,$MARGIN,$LINELENGTH) == maprin0 x +-- above line changed JHD 13/2/93 since it used to call maPrin + +maprin x == + if $demoFlag=true then recordOrCompareDemoResult x + CATCH('output,maprin0 x) + nil + +maprin0 x == + $MatrixCount:local :=0 + $MatrixList:local :=nil + maprinChk x + if $MatrixList then maprinRows $MatrixList + -- above line moved JHD 28/2/93 to catch all routes through maprinChk + +maprinChk x == + null $MatrixList => maPrin x + ATOM x and (u:= ASSOC(x,$MatrixList)) => + $MatrixList := delete(u,$MatrixList) + maPrin deMatrix CDR u + x is ["=",arg,y] => --case for tracing with )math and printing matrices + u:=ASSOC(y,$MatrixList) => + -- we don't want to print matrix1 = matrix2 ... + $MatrixList := delete(u,$MatrixList) + maPrin ["=",arg, deMatrix CDR u] + maPrin x + x is ['EQUATNUM,n,y] => + $MatrixList is [[name,:value]] and y=name => + $MatrixList:=[] -- we are pulling this one off + maPrin ['EQUATNUM,n, deMatrix value] + IDENTP y => --------this part is never called + -- Not true: JHD 28/2/93 + -- m:=[[1,2,3],[4,5,6],[7,8,9]] + -- mm:=[[m,1,0],[0,m,1],[0,1,m]] + -- and try to print mm**5 + u := ASSOC(y,$MatrixList) + --$MatrixList := deleteAssoc(first u,$MatrixList) + -- deleteAssoc no longer exists + $MatrixList := delete(u,$MatrixList) + maPrin ['EQUATNUM,n,rest u] + if ^$collectOutput then TERPRI $algebraOutputStream + maPrin x + maPrin x + -- above line added JHD 13/2/93 since otherwise x gets lost + +maprinRows matrixList == + if ^$collectOutput then TERPRI($algebraOutputStream) + while matrixList repeat + y:=NREVERSE matrixList + --Makes the matrices come out in order, since CONSed on backwards + matrixList:=nil + firstName := first first y + for [name,:m] in y for n in 0.. repeat + if ^$collectOutput then TERPRI($algebraOutputStream) + andWhere := (name = firstName => '"where "; '"and ") + line := STRCONC(andWhere, PNAME name) + maprinChk ["=",line,m] + -- note that this could place a new element on $MatrixList, hence the loop + +deMatrix m == + ['BRACKET,['AGGLST, + :[['BRACKET,['AGGLST,:rest row]] for row in CDDR m]]] + +LargeMatrixp(u,width, dist) == + -- sees if there is a matrix wider than 'width' in the next 'dist' + -- part of u, a sized charybdis structure. + -- NIL if not, first such matrix if there is one + ATOM u => nil + CDAR u <= width => nil + --CDAR is the width of a charybdis structure + op:=CAAR u + op = 'MATRIX => largeMatrixAlist u + --We already know the structure is more than 'width' wide + MEMQ(op,'(LET RARROW SEGMENT _- CONCAT CONCATB PAREN BRACKET BRACE)) => + --Each of these prints the arguments in a width 3 smaller + dist:=dist-3 + width:=width-3 + ans:= + for v in CDR u repeat + (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans + dist:=dist - WIDTH v + dist<0 => return nil + ans + --Relying that falling out of a loop gives nil + MEMQ(op,'(_+ _* )) => + --Each of these prints the first argument in a width 3 smaller + (ans:=LargeMatrixp(CADR u,width-3,dist)) => largeMatrixAlist ans + n:=3+WIDTH CADR u + dist:=dist-n + ans:= + for v in CDDR u repeat + (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans + dist:=dist - WIDTH v + dist<0 => return nil + ans + --Relying that falling out of a loop gives nil + ans:= + for v in CDR u repeat + (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans + dist:=dist - WIDTH v + dist<0 => return nil + ans + --Relying that falling out of a loop gives nil + +largeMatrixAlist u == + u is [op,:r] => + op is ['MATRIX,:.] => deMatrix u + largeMatrixAlist op or largeMatrixAlist r + nil + +PushMatrix m == + --Adds the matrix to the look-aside list, and returns a name for it + name:= + for v in $MatrixList repeat + EQUAL(m,CDR v) => return CAR v + name => name + name:=INTERNL('"matrix",STRINGIMAGE($MatrixCount:=$MatrixCount+1)) + $MatrixList:=[[name,:m],:$MatrixList] + name + +quoteApp([.,a],x,y,d) == APP(a,x+1,y,appChar(PNAME "'",x,y,d)) + +quoteSub [.,a] == subspan a + +quoteSuper [.,a] == superspan a + +quoteWidth [.,a] == 1 + WIDTH a + +SubstWhileDesizing(u,m) == + -- arg. m is always nil (historical: EU directive to increase argument lists 1991/XGII) + --Replaces all occurrences of matrix m by name in u + --Taking out any outdated size information as it goes + ATOM u => u + [[op,:n],:l]:=u + --name := RASSOC(u,$MatrixList) => name + -- doesn't work since RASSOC seems to use an EQ test, and returns the + -- pair anyway. JHD 28/2/93 + op = 'MATRIX => + l':=SubstWhileDesizingList(CDR l,m) + u := + -- CDR l=l' => u + -- this was a CONS-saving optimisation, but it doesn't work JHD 28/2/93 + [op,nil,:l'] + PushMatrix u + l':=SubstWhileDesizingList(l,m) + -- [op,:l'] + ATOM op => [op,:l'] + [SubstWhileDesizing(op,m),:l'] + +--;SubstWhileDesizingList(u,m) == +--; -- m is always nil (historical) +--; u is [a,:b] => +--; a':=SubstWhileDesizing(a,m) +--; b':=SubstWhileDesizingList(b,m) +--;-- MCD & TTT think that this test is unnecessary and expensive +--;-- a=a' and b=b' => u +--; [a',:b'] +--; u + +SubstWhileDesizingList(u,m) == + u is [a,:b] => + res:= + ATOM a => [a] + [SubstWhileDesizing(a,m)] + tail:=res + for i in b repeat + if ATOM i then RPLACD(tail,[i]) else RPLACD(tail,[SubstWhileDesizing(i,m)]) + tail:=CDR tail + res + u + +--% Printing of Sigmas , Pis and Intsigns + +sigmaSub u == + --The depth function for sigmas with lower limit only + MAX(1 + height CADR u, subspan CADDR u) + +sigmaSup u == + --The height function for sigmas with lower limit only + MAX(1, superspan CADDR u) + +sigmaApp(u,x,y,d) == + u is [.,bot,arg] or THROW('outputFailure,'outputFailure) + bigopAppAux(bot,nil,arg,x,y,d,'sigma) + +sigma2App(u,x,y,d) == + [.,bot,top,arg]:=u + bigopAppAux(bot,top,arg,x,y,d,'sigma) + +bigopWidth(bot,top,arg,kind) == + kindWidth := (kind = 'pi => 5; 3) + MAX(kindWidth,WIDTH bot,(top => WIDTH top; 0)) + 2 + WIDTH arg + +half x ==> + QUOTIENT(x, 2) + +bigopAppAux(bot,top,arg,x,y,d,kind) == + botWidth := (bot => WIDTH bot; 0) + topWidth := WIDTH top + opWidth := + kind = 'pi => 5 + 3 + maxWidth := MAX(opWidth,botWidth,topWidth) + xCenter := half(maxWidth-1) + x + d:=APP(arg,x+2+maxWidth,y,d) + d:= + atom bot and SIZE atom2String bot = 1 => APP(bot,xCenter,y-2,d) + APP(bot,x + half(maxWidth - botWidth),y-2-superspan bot,d) + if top then + d:= + atom top and SIZE atom2String top = 1 => APP(top,xCenter,y+2,d) + APP(top,x + half(maxWidth - topWidth),y+2+subspan top,d) + delta := (kind = 'pi => 2; 1) + opCode := + kind = 'sigma => + [['(0 . 0),:'">"],_ + ['(0 . 1),:specialChar('hbar)],_ + ['(0 . -1),:specialChar('hbar)],_ + ['(1 . 1),:specialChar('hbar)],_ + ['(1 . -1),:specialChar('hbar)],_ + ['(2 . 1),:specialChar('urc )],_ + ['(2 . -1),:specialChar('lrc )]] + kind = 'pi => + [['(0 . 1),:specialChar('ulc )],_ + ['(1 . 0),:specialChar('vbar)],_ + ['(1 . 1),:specialChar('ttee)],_ + ['(1 . -1),:specialChar('vbar)],_ + ['(2 . 1),:specialChar('hbar)],_ + ['(3 . 0),:specialChar('vbar)],_ + ['(3 . 1),:specialChar('ttee)],_ + ['(3 . -1),:specialChar('vbar)],_ + ['(4 . 1),:specialChar('urc )]] + THROW('outputFailure,'outputFailure) + xLate(opCode,xCenter - delta,y,d) + +sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma) +sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma) + +sigma2Sub u == + --The depth function for sigmas with 2 limits + MAX(1 + height CADR u, subspan CADDDR u) + +sigma2Sup u == + --The depth function for sigmas with 2 limits + MAX(1 + height CADDR u, superspan CADDDR u) + +piSub u == + --The depth function for pi's (products) + MAX(1 + height CADR u, subspan CADDR u) + +piSup u == + --The height function for pi's (products) + MAX(1, superspan CADDR u) + +piApp(u,x,y,d) == + u is [.,bot,arg] or THROW('outputFailure,'outputFailure) + bigopAppAux(bot,nil,arg,x,y,d,'pi) + +piWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'pi) +pi2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'pi) + +pi2Sub u == + --The depth function for pi's with 2 limits + MAX(1 + height CADR u, subspan CADDDR u) + +pi2Sup u == + --The depth function for pi's with 2 limits + MAX(1 + height CADDR u, superspan CADDDR u) + +pi2App(u,x,y,d) == + [.,bot,top,arg]:=u + bigopAppAux(bot,top,arg,x,y,d,'pi) + +overlabelSuper [.,a,b] == 1 + height a + superspan b + +overlabelWidth [.,a,b] == WIDTH b + +overlabelApp([.,a,b], x, y, d) == + underApp:= APP(b,x,y,d) + endPoint := x + WIDTH b - 1 + middle := QUOTIENT(x + endPoint,2) + h := y + superspan b + 1 + d := APP(a,middle,h + 1,d) + apphor(x,x+WIDTH b-1,y+superspan b+1,d,"|") + +overbarSuper u == 1 + superspan u.1 + +overbarWidth u == WIDTH u.1 + +overbarApp(u,x,y,d) == + underApp:= APP(u.1,x,y,d) + apphor(x,x+WIDTH u.1-1,y+superspan u.1+1,d,UNDERBAR) + +indefIntegralSub u == + -- form is INDEFINTEGRAL(expr,dx) + MAX(1,subspan u.1,subspan u.2) + +indefIntegralSup u == + -- form is INDEFINTEGRAL(expr,dx) + MAX(1,superspan u.1,superspan u.2) + +indefIntegralApp(u,x,y,d) == + -- form is INDEFINTEGRAL(expr,dx) + [.,expr,dx]:=u + d := APP(expr,x+4,y,d) + d := APP(dx,x+5+WIDTH expr,y,d) + xLate( [['(0 . -1),:specialChar('llc) ],_ + ['(1 . -1),:specialChar('lrc) ],_ + ['(1 . 0),:specialChar('vbar)],_ + ['(1 . 1),:specialChar('ulc) ],_ + ['(2 . 1),:specialChar('urc) ]], x,y,d) + +indefIntegralWidth u == + -- form is INDEFINTEGRAL(expr,dx) + # u ^= 3 => THROW('outputFailure,'outputFailure) + 5 + WIDTH u.1 + WIDTH u.2 + +intSub u == + MAX(1 + height u.1, subspan u.3) + +intSup u == + MAX(1 + height u.2, superspan u.3) + +intApp(u,x,y,d) == + [.,bot,top,arg]:=u + d:=APP(arg,x+4+MAX(-4 + WIDTH bot, WIDTH top),y,d) + d:=APP(bot,x,y-2-superspan bot,d) + d:=APP(top,x+3,y+2+subspan top,d) + xLate( [['(0 . -1),:specialChar('llc) ],_ + ['(1 . -1),:specialChar('lrc) ],_ + ['(1 . 0),:specialChar('vbar)],_ + ['(1 . 1),:specialChar('ulc) ],_ + ['(2 . 1),:specialChar('urc) ]], x,y,d) + +intWidth u == + # u < 4 => THROW('outputFailure,'outputFailure) + MAX(-4 + WIDTH u.1, WIDTH u.2) + WIDTH u.3 + 5 + +xLate(l,x,y,d) == + for [[a,:b],:c] in l repeat + d:= appChar(c,x+a,y+b,d) + d + +concatTrouble(u,d,start,lineLength,$addBlankIfTrue) == + [x,:l] := splitConcat(u,lineLength,true) + null l => + sayALGEBRA ['%l,'%b,'" Too wide to Print",'%d] + THROW('output,nil) + charybdis(fixUp x,start,lineLength) + for y in l repeat + if d then prnd(start,d) + if lineLength > 2 then + charybdis(fixUp y,start+2,lineLength-2) -- JHD needs this to avoid lunacy + else charybdis(fixUp y,start,1) -- JHD needs this to avoid lunacy + BLANK + where + fixUp x == + rest x => + $addBlankIfTrue => ['CONCATB,:x] + ["CONCAT",:x] + first x + +splitConcat(list,maxWidth,firstTimeIfTrue) == + null list => nil + -- split list l into a list of n lists, each of which + -- has width < maxWidth + totalWidth:= 0 + oneOrZero := ($addBlankIfTrue => 1; 0) + l := list + maxW:= (firstTimeIfTrue => maxWidth; maxWidth-2) + maxW < 1 => [[x] for x in l] -- JHD 22.8.95, otherwise things can break + for x in tails l + while (width := oneOrZero + WIDTH first x + totalWidth) < maxW repeat + l:= x + totalWidth:= width + x:= rest l + RPLAC(rest l,nil) + [list,:splitConcat(x,maxWidth,nil)] + +spadPrint(x,m) == + m = $NoValueMode => x + if ^$collectOutput then TERPRI $algebraOutputStream + output(x,m) + if ^$collectOutput then TERPRI $algebraOutputStream + +formulaFormat expr == + sff := '(ScriptFormulaFormat) + formatFn := getFunctionFromDomain("coerce",sff,[$OutputForm]) + displayFn := getFunctionFromDomain("display",sff,[sff]) + SPADCALL(SPADCALL(expr,formatFn),displayFn) + if ^$collectOutput then + TERPRI $algebraOutputStream + FORCE_-OUTPUT $formulaOutputStream + NIL + +texFormat expr == + tf := '(TexFormat) + formatFn := + getFunctionFromDomain("convert",tf,[$OutputForm,$Integer]) + displayFn := getFunctionFromDomain("display",tf,[tf]) + SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn) + TERPRI $texOutputStream + FORCE_-OUTPUT $texOutputStream + NIL + +texFormat1 expr == + tf := '(TexFormat) + formatFn := getFunctionFromDomain("coerce",tf, [$OutputForm]) + displayFn := getFunctionFromDomain("display",tf,[tf]) + SPADCALL(SPADCALL(expr,formatFn),displayFn) + TERPRI $texOutputStream + FORCE_-OUTPUT $texOutputStream + NIL + +output(expr,domain) == + if isWrapped expr then expr := unwrap expr + isMapExpr expr => + if $formulaFormat then formulaFormat expr + if $texFormat then texFormat expr + if $algebraFormat then mathprintWithNumber expr + categoryForm? domain or domain in '((Mode) (Domain) (SubDomain (Domain))) => + if $algebraFormat then + mathprintWithNumber outputDomainConstructor expr + if $texFormat then + texFormat outputDomainConstructor expr + T := coerceInteractive(objNewWrap(expr,domain),$OutputForm) => + x := objValUnwrap T + if $formulaFormat then formulaFormat x + if $fortranFormat then + dispfortexp x + if ^$collectOutput then TERPRI $fortranOutputStream + FORCE_-OUTPUT $fortranOutputStream + if $algebraFormat then + mathprintWithNumber x + if $texFormat then texFormat x + (FUNCTIONP(opOf domain)) and + (printfun := compiledLookup("<<",'(TextWriter TextWriter $), evalDomain domain)) + and (textwrit := compiledLookup("print", '($), TextWriter())) => + sayMSGNT [:bright '"AXIOM-XL",'"output: "] + SPADCALL(SPADCALL textwrit, expr, printfun) + sayMSGNT '%l + + -- big hack for tuples for new compiler + domain is ['Tuple, S] => output(asTupleAsList expr, ['List, S]) + + sayALGEBRA [:bright '"LISP",'"output:",'%l,expr or '"NIL"] + +outputNumber(start,linelength,num) == + if start > 1 then blnks := fillerSpaces(start-1,'" ") + else blnks := '"" + under:='"__" + firsttime:=(linelength>3) + if linelength>2 then + linelength:=linelength-1 + while SIZE(num) > linelength repeat + if $collectOutput then + $outputLines := [CONCAT(blnks, SUBSTRING(num,0,linelength),under), + :$outputLines] + else + sayALGEBRA [blnks, + SUBSTRING(num,0,linelength),under] + num := SUBSTRING(num,linelength,NIL) + if firsttime then + blnks:=CONCAT(blnks,'" ") + linelength:=linelength-1 + firsttime:=NIL + if $collectOutput then + $outputLines := [CONCAT(blnks, num), :$outputLines] + else + sayALGEBRA [blnks, num] + +outputString(start,linelength,str) == + if start > 1 then blnks := fillerSpaces(start-1,'" ") + else blnks := '"" + while SIZE(str) > linelength repeat + if $collectOutput then + $outputLines := [CONCAT(blnks, SUBSTRING(str,0,linelength)), + :$outputLines] + else + sayALGEBRA [blnks, SUBSTRING(str,0,linelength)] + str := SUBSTRING(str,linelength,NIL) + if $collectOutput then + $outputLines := [CONCAT(blnks, str), :$outputLines] + else + sayALGEBRA [blnks, str] + +outputDomainConstructor form == + if VECTORP form then form := devaluate form + atom (u:= prefix2String form) => u + v:= [object2String(x) for x in u] + return INTERNL eval ['STRCONC,:v] + +getOutputAbbreviatedForm form == + form is [op,:argl] => + op in '(Union Record) => outputDomainConstructor form + op is "Mapping" => formatMapping argl + u:= constructor? op or op + null argl => u + ml:= getPartialConstructorModemapSig(op) + argl:= [fn for x in argl for m in ml] where fn() == + categoryForm?(m) => outputDomainConstructor x + x' := coerceInteractive(objNewWrap(x,m),$OutputForm) + x' => objValUnwrap x' + '"unprintableObject" + [u,:argl] + form + +outputOp x == + x is [op,:args] and (GETL(op,"LED") or GETL(op,"NUD")) => + n:= + GETL(op,"NARY") => 2 + #args + newop:= INTERN STRCONC("*",STRINGIMAGE n,PNAME op) + [newop,:[outputOp y for y in args]] + x + +--% MAP PRINTER (FROM EV BOOT) + +printMap u == + printBasic specialChar 'lbrk + initialFlag:= isInitialMap u + if u is [x,:l] then + printMap1(x,initialFlag and x is [[n],:.] and n=1) + for y in l repeat (printBasic " , "; printMap1(y,initialFlag)) + printBasic specialChar 'rbrk + if ^$collectOutput then TERPRI $algebraOutputStream + +isInitialMap u == + u is [[[n],.],:l] and INTEGERP n and + (and/[x is [[ =i],.] for x in l for i in n+1..]) + +printMap1(x,initialFlag) == + initialFlag => printBasic CADR x + if CDAR x then printBasic first x else printBasic CAAR x + printBasic " E " + printBasic CADR x + +printBasic x == + x='(One) => PRIN1(1,$algebraOutputStream) + x='(Zero) => PRIN1(0,$algebraOutputStream) + IDENTP x => PRINTEXP(PNAME x,$algebraOutputStream) + atom x => PRIN1(x,$algebraOutputStream) + PRIN0(x,$algebraOutputStream) + +charybdis(u,start,linelength) == + EQ(keyp u,'EQUATNUM) and ^(CDDR u) => + charybdis(['PAREN,u.1],start,linelength) + charyTop(u,start,linelength) + +charyTop(u,start,linelength) == + u is ['SC,:l] or u is [['SC,:.],:l] => + for a in l repeat charyTop(a,start,linelength) + '" " + u is [['CONCATB,:.],:m,[['SC,:.],:l]] => + charyTop(['CONCATB,:m],start,linelength) + charyTop(['SC,:l],start+2,linelength-2) + u is ['CENTER,a] => + b := charyTopWidth a + (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength) + charyTop(b,half(linelength-start-w),linelength) + v := charyTopWidth u + EQ(keyp u,'ELSE) => charyElse(u,v,start,linelength) + WIDTH(v) > linelength => charyTrouble(u,v,start,linelength) + d := APP(v,start,0,nil) + n := superspan v + m := - subspan v +--> + $testOutputLineFlag => + $testOutputLineList := + [:ASSOCRIGHT SORTBY('CAR,d),:$testOutputLineList] + until n < m repeat + scylla(n,d) + n := n - 1 + '" " + +charyTopWidth u == + atom u => u + atom first u => putWidth u + NUMBERP CDAR u => u + putWidth u + +charyTrouble(u,v,start,linelength) == + al:= LargeMatrixp(u,linelength,2*linelength) => + --$MatrixList => + --[[m,:m1]] := al + --maPrin sublisMatAlist(m,m1,u) + --above three lines commented out JHD 25/2/93 since don't work + --u := SubstWhileDesizing(u,first first al) + u := SubstWhileDesizing(u,nil) + maprinChk u + charyTrouble1(u,v,start,linelength) + +sublisMatAlist(m,m1,u) == + u is [op,:r] => + op is ['MATRIX,:.] and u=m => m1 + op1 := sublisMatAlist(m,m1,op) + r1 := [sublisMatAlist(m,m1,s) for s in r] + op = op1 and r1 = r => u + [op1,:r1] + u + +charyTrouble1(u,v,start,linelength) == + NUMBERP u => outputNumber(start,linelength,atom2String u) + atom u => outputString(start,linelength,atom2String u) + EQ(x:= keyp u,'_-) => charyMinus(u,v,start,linelength) + MEMQ(x,'(_+ _* AGGLST)) => charySplit(u,v,start,linelength) + EQ(x,'EQUATNUM) => charyEquatnum(u,v,start,linelength) + d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) + x = 'OVER => + charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) + EQ(3,LENGTH u) and GET(x,'Led) => + d:= PNAME first GET(x,'Led) + charyBinary(d,u,v,start,linelength) + EQ(x,'CONCAT) => + concatTrouble(rest v,d,start,linelength,nil) + EQ(x,'CONCATB) => + (rest v) is [loop, 'repeat, body] => + charyTop(['CONCATB,loop,'repeat],start,linelength) + charyTop(body,start+2,linelength-2) + (rest v) is [wu, loop, 'repeat, body] and + (keyp wu) is ['CONCATB,wu',.] and wu' in '(while until) => + charyTop(['CONCATB,wu,loop,'repeat],start,linelength) + charyTop(body,start+2,linelength-2) + concatTrouble(rest v,d,start,linelength,true) + GETL(x,'INFIXOP) => charySplit(u,v,start,linelength) + EQ(x,'PAREN) and + (EQ(keyp u.1,'AGGLST) and (v:= ",") or EQ(keyp u.1,'AGGSET) and + (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)") + EQ(x,'PAREN) and EQ(keyp u.1,'CONCATB) => + bracketagglist(rest u.1,start,linelength," ","_(","_)") + EQ(x,'BRACKET) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => + bracketagglist(rest u.1,start,linelength,v, + specialChar 'lbrk, specialChar 'rbrk) + EQ(x,'BRACE) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => + bracketagglist(rest u.1,start,linelength,v, + specialChar 'lbrc, specialChar 'rbrc) + EQ(x,'EXT) => longext(u,start,linelength) + EQ(x,'MATRIX) => MATUNWND() + EQ(x,'ELSE) => charyElse(u,v,start,linelength) + EQ(x,'SC) => charySemiColon(u,v,start,linelength) + charybdis(x,start,linelength) + if rest u then charybdis(['ELSE,:rest u],start,linelength) + -- changed from charybdis(...) by JHD 2 Aug 89, since rest u might be null + '" " + +charySemiColon(u,v,start,linelength) == + for a in rest u repeat + charyTop(a,start,linelength) + nil + +charyMinus(u,v,start,linelength) == + charybdis('"-",start,linelength) + charybdis(v.1,start+3,linelength-3) + '" " + +charyBinary(d,u,v,start,linelength) == + d in '(" := " "= ") => + charybdis(['CONCATB,v.1,d],start,linelength) + charybdis(v.2,start+2,linelength-2) + '" " + charybdis(v.1,start+2,linelength-2) + if d then prnd(start,d) + charybdis(v.2,start+2,linelength-2) + '" " + +charyEquatnum(u,v,start,linelength) == + charybdis(['PAREN,u.1],start,linelength) + charybdis(u.2,start,linelength) + '" " + +charySplit(u,v,start,linelength) == + v:= [first v.0,:rest v] + m:= rest v + WIDTH v.1 > linelength-2 => + charybdis(v.1,start+2,linelength-2) + ^(CDDR v) => '" " + dm:= CDDR v + ddm:= rest dm + split2(u,dm,ddm,start,linelength) + for i in 0.. repeat + dm := rest m + ddm := rest dm + RPLACD(dm,nil) + WIDTH v > linelength - 2 => return nil + RPLAC(first v, first v.0) + RPLACD(dm,ddm) + m := rest m + RPLAC(first v,first v.0) + RPLACD(m,nil) + charybdis(v,start + 2,linelength - 2) + split2(u,dm,ddm,start,linelength) + +split2(u,dm,ddm,start,linelength) == +--prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; opSrch(keyp u,OPLIST))) + prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; '",")) + RPLACD(dm,ddm) + m:= WIDTH [keyp u,:dm] start+2; start),(m => linelength-2; linelength)) + '" " + +charyElse(u,v,start,linelength) == + charybdis(v.1,start+3,linelength-3) + ^(CDDR u) => '" " + prnd(start,'",") + charybdis(['ELSE,:CDDR v],start,linelength) + '" " + +scylla(n,v) == + y := LASSOC(n,v) + null y => nil + if STRINGP(y) then y := DROPTRAILINGBLANKS COPY y + if $collectOutput then + $outputLines := [y, :$outputLines] + else + PRINTEXP(y,$algebraOutputStream) + TERPRI $algebraOutputStream + nil + +keyp(u) == + atom u => nil + atom first u => first u + CAAR u + +absym x == + (NUMBERP x) and (MINUSP x) => -x + ^(atom x) and (keyp(x) = '_-) => CADR x + x + +agg(n,u) == + (n = 1) => CADR u + agg(n - 1, rest u) + +aggwidth u == + null u => 0 + null rest u => WIDTH first u + 1 + (WIDTH first u) + (aggwidth rest u) + +argsapp(u,x,y,d) == appargs(rest u,x,y,d) + +subspan u == + atom u => 0 + NUMBERP rest u => subspan first u + (not atom first u and_ + atom CAAR u and_ + not NUMBERP CAAR u and_ + GETL(CAAR u, 'SUBSPAN) ) => + APPLX(GETL(CAAR u, 'SUBSPAN), LIST u) + MAX(subspan first u, subspan rest u) + +agggsub u == subspan rest u + +superspan u == + atom u => 0 + NUMBERP rest u => superspan first u + (not atom first u and_ + atom CAAR u and_ + not NUMBERP CAAR u and_ + GETL(CAAR u, 'SUPERSPAN) ) => + APPLX(GETL(CAAR u, 'SUPERSPAN), LIST u) + MAX(superspan first u, superspan rest u) + +agggsuper u == superspan rest u + +agggwidth u == aggwidth rest u + +appagg(u,x,y,d) == appagg1(u,x,y,d,'",") + +appagg1(u,x,y,d,s) == + null u => d + null rest u => APP(first u,x,y,d) + temp := x + WIDTH first u + temparg1 := APP(first u,x,y,d) + temparg2 := APP(s,temp,y,temparg1) + appagg1(rest u, 1 + temp, y, temparg2,s) + +--Note the similarity between the definition below of appargs and above +--of appagg. (why?) + +appargs(u,x,y,d) == appargs1(u,x,y,d,'";") + +--Note that the definition of appargs1 below is identical to that of +--appagg1 above except that the former calls appargs and the latter +--calls appagg. + +appargs1(u,x,y,d,s) == + null u => d + null rest u => APP(first u,x,y,d) + temp := x + WIDTH first u + temparg1 := APP(first u,x,y,d) + temparg2 := APP(s,temp,y,temparg1) + true => appargs(rest u, 1 + temp, y, temparg2) + +apprpar(x, y, y1, y2, d) == + (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('")", x, y, d) + true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) + +apprpar1(x, y, y1, y2, d) == + (y1 = y2) => APP('")", x, y2, d) + true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) + +applpar(x, y, y1, y2, d) == + (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('"(", x, y, d) + true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) + +applpar1(x, y, y1, y2, d) == + (y1 = y2) => APP('"(", x, y2, d) + true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) + +--The body of the function appelse assigns 6 local variables. +--It then finishes by calling apprpar. + +appelse(u,x,y,d) == + w := WIDTH CAAR u + b := y - subspan rest u + p := y + superspan rest u + temparg1 := APP(keyp u, x, y, d) + temparg2 := applpar(x + w, y, b, p, temparg1) + temparg3 := appagg(rest u, x + 1 + w, y, temparg2) + apprpar(x + 1 + w + aggwidth rest u, y, b, p, temparg3) + +appext(u,x,y,d) == + xptr := x + yptr := y - (subspan CADR u + superspan agg(3,u) + 1) + d := APP(CADR u,x,y,d) + d := APP(agg(2,u),xptr,yptr,d) + xptr := xptr + WIDTH agg(2,u) + d := APP('"=", xptr, yptr,d) + d := APP(agg(3,u), 1 + xptr, yptr, d) + yptr := y + 1 + superspan CADR u + SUBSPAD agg(4,u) + d := APP(agg(4,u), x, yptr, d) + temp := 1 + WIDTH agg(2,u) + WIDTH agg(3,u) + n := MAX(WIDTH CADR u, WIDTH agg(4,u), temp) + if EQCAR(first(z := agg(5,u)), 'EXT) and + (EQ(n,3) or (n > 3 and ^(atom z)) ) then + n := 1 + n + d := APP(z, x + n, y, d) + +apphor(x1,x2,y,d,char) == + temp := (x1 = x2 => d; apphor(x1, x2 - 1, y, d,char)) + APP(char, x2, y, temp) + +syminusp x == + NUMBERP x => MINUSP x + ^(atom x) and EQ(keyp x,'_-) + +appsum(u, x, y, d) == + null u => d + ac := absym first u + sc := + syminusp first u => '"-" + true => '"+" + dp := member(keyp absym first u, '(_+ _-)) + tempx := x + WIDTH ac + (dp => 5; true => 3) + tempdblock := + temparg1 := APP(sc, x + 1, y, d) + dp => + bot := y - subspan ac + top := y + superspan ac + temparg2 := applpar(x + 3, y, bot, top, temparg1) + temparg3 := APP(ac, x + 4, y, temparg2) + apprpar(x + 4 + WIDTH ac, y, bot, top, temparg3) + true => APP(ac, x + 3, y, temparg1) + appsum(rest u, tempx, y, tempdblock) + +appneg(u, x, y, d) == + appsum(LIST u, x - 1, y, d) + +appparu(u, x, y, d) == + bot := y - subspan u + top := y + superspan u + temparg1 := applpar(x, y, bot, top, d) + temparg2 := APP(u, x + 1, y, temparg1) + apprpar(x + 1 + WIDTH u, y, bot, top, temparg2) + +appparu1(u, x, y, d) == + appparu(CADR u, x, y, d) + +appsc(u, x, y, d) == + appagg1(rest u, x, y, d, '";") + +appsetq(u, x, y, d) == + w := WIDTH first u + temparg1 := APP(CADR u, x, y, d) + temparg2 := APP('":", x + w, y, temparg1) + APP(CADR rest u, x + 2 + w, y, temparg2) + +appsub(u, x, y, d) == + temparg1 := x + WIDTH CADR u + temparg2 := y - 1 - superspan CDDR u + temparg3 := APP(CADR u, x, y, d) + appagg(CDDR u, temparg1, temparg2, temparg3) + +starstarcond(l, iforwhen) == + null l => l + EQ((a := CAAR l), 1) => + LIST('CONCAT, CADR first l, '" OTHERWISE") + EQCAR(a, 'COMPARG) => + starstarcond(CONS(transcomparg(CADR a), rest l), iforwhen) + null rest l => + LIST('CONCAT, CADR first l, + LIST('CONCAT, iforwhen, CAAR l)) + true => LIST('VCONCAT, + starstarcond(CONS(first l, nil), iforwhen), + LIST('VCONCAT, '" ", + starstarcond(rest l, iforwhen))) + +eq0(u) == 0 + +height(u) == + superspan(u) + 1 + subspan(u) + +extsub(u) == + MAX(subspan agg(5, u), height(agg(3, u)), subspan CADR u ) + +extsuper(u) == + MAX(superspan CADR u + height agg(4, u), superspan agg(5, u) ) + +extwidth(u) == + n := MAX(WIDTH CADR u, + WIDTH agg(4, u), + 1 + WIDTH agg(2, u) + WIDTH agg(3, u) ) + nil or + (EQCAR(first(z := agg(5, u)), 'EXT) and _ + (EQ(n, 3) or ((n > 3) and null atom z) ) => + n := 1 + n) + true => n + WIDTH agg(5, u) + +appfrac(u, x, y, d) == + -- Added "1+" to both QUOTIENT statements so that when exact centering is + -- not possible, expressions are offset to the right rather than left. + -- MCD 16-8-95 + w := WIDTH u + tempx := x + QUOTIENT(1+w - WIDTH CADR rest u, 2) + tempy := y - superspan CADR rest u - 1 + temparg3 := APP(CADR rest u, tempx, tempy, d) + temparg4 := apphor(x, x + w - 1, y, temparg3,specialChar('hbar)) + APP(CADR u, + x + QUOTIENT(1+w - WIDTH CADR u, 2), + y + 1 + subspan CADR u, + temparg4) + +fracsub(u) == height CADR rest u + +fracsuper(u) == height CADR u + +fracwidth(u) == + numw := WIDTH (num := CADR u) + denw := WIDTH (den := CADDR u) + if num is [[op,:.],:.] and op = 'OVER then numw := numw + 2 + if den is [[op,:.],:.] and op = 'OVER then denw := denw + 2 + MAX(numw,denw) + +slashSub u == + MAX(1,subspan(CADR u),subspan(CADR rest u)) + +slashSuper u == + MAX(1,superspan(CADR u),superspan(CADR rest u)) + +slashApp(u, x, y, d) == + -- to print things as a/b as opposed to + -- a + -- - + -- b + temparg1 := APP(CADR u, x, y, d) + temparg2 := APP('"/", x + WIDTH CADR u, y, temparg1) + APP(CADR rest u, + x + 1 + WIDTH CADR u, y, temparg2) + +slashWidth(u) == + -- to print things as a/b as opposed to + -- a + -- - + -- b + 1 + WIDTH CADR u + WIDTH CADR rest u + +longext(u, i, n) == + x := REVERSE u + y := first x + u := remWidth(REVERSEWOC(CONS('" ", rest x))) + charybdis(u, i, n) + if ^$collectOutput then TERPRI $algebraOutputStream + charybdis(CONS('ELSE, LIST y), i, n) + '" " + +appvertline(char, x, yl, yu, d) == + yu < yl => d + temparg := appvertline(char, x, yl, yu - 1, d) + true => APP(char, x, yu, temparg) + +appHorizLine(xl, xu, y, d) == + xu < xl => d + temparg := appHorizLine(xl, xu - 1, y, d) + true => APP(MATBORCH, xu, y, temparg) + +rootApp(u, x, y, d) == + widB := WIDTH u.1 + supB := superspan u.1 + subB := subspan u.1 + if #u > 2 then + widR := WIDTH u.2 + subR := subspan u.2 + d := APP(u.2, x, y - subB + 1 + subR, d) + else + widR := 1 + d := APP(u.1, x + widR + 1, y, d) + d := apphor(x+widR+1, x+widR+widB, y+supB+1, d, specialChar('hbar)) + d := appvertline(specialChar('vbar), x+widR, y - subB, y + supB, d) + d := APP(specialChar('ulc), x+widR, y + supB+1, d) + d := APP(specialChar('urc), x + widR + widB + 1, y + supB+1, d) + d := APP(specialChar('bslash), x + widR - 1, y - subB, d) + +boxApp(u, x, y, d) == + CDDR u => boxLApp(u, x, y, d) + a := 1 + superspan u.1 + b := 1 + subspan u.1 + w := 2 + WIDTH u.1 + d := appvertline(specialChar('vbar), x,y - b + 1, y + a - 1, d) + d := appvertline(specialChar('vbar), x + w + 1, y - b,y + a,d) + d := apphor(x + 1, x + w, y - b, d, specialChar('hbar)) + d := apphor(x + 1, x + w, y + a, d, specialChar('hbar)) + d := APP(specialChar('ulc), x, y + a, d) + d := APP(specialChar('urc), x + w + 1, y + a, d) + d := APP(specialChar('llc), x, y - b, d) + d := APP(specialChar('lrc), x + w + 1, y - b, d) + d := APP(u.1, 2 + x, y, d) + +boxLApp(u, x, y, d) == + la := superspan u.2 + lb := subspan u.2 + lw := 2 + WIDTH u.2 + lh := 2 + la + lb + a := superspan u.1+1 + b := subspan u.1+1 + w := MAX(lw, 2 + WIDTH u.1) + -- next line used to have h instead of lh + top := y + a + lh + d := appvertline(MATBORCH, x, y - b, top, d) + d := appHorizLine(x + 1, x + w, top, d) + d := APP(u.2, 2 + x, y + a + lb + 1, d) + d := appHorizLine(x + 1, x + lw, y + a, d) + nil or + lw < w => d := appvertline(MATBORCH, x + lw + 1, y + a, top - 1, d) + d := APP(u.1, 2 + x, y, d) + d := appHorizLine(x + 1, x + w, y - b, top, d) + d := appvertline(MATBORCH, x + w + 1, y - b, top, d) + +boxSub(x) == + subspan x.1+1 + +boxSuper(x) == + null CDR x => 0 + hl := + null CDDR x => 0 + true => 2 + subspan x.2 + superspan x.2 + true => hl+1 + superspan x.1 + +boxWidth(x) == + null CDR x => 0 + wl := + null CDDR x => 0 + true => WIDTH x.2 + true => 4 + MAX(wl, WIDTH x.1) + +nothingWidth x == + 0 +nothingSuper x == + 0 +nothingSub x == + 0 +nothingApp(u, x, y, d) == + d + +zagApp(u, x, y, d) == + w := WIDTH u + denx := x + QUOTIENT(w - WIDTH CADR rest u, 2) + deny := y - superspan CADR rest u - 1 + d := APP(CADR rest u, denx, deny, d) + numx := x + QUOTIENT(w - WIDTH CADR u, 2) + numy := y+1 + subspan CADR u + d := APP(CADR u, numx, numy, d) + a := 1 + zagSuper u + b := 1 + zagSub u + d := appvertline(specialChar('vbar), x, y - b, y - 1, d) + d := appvertline(specialChar('vbar), x + w - 1, y + 1, y + a, d) + d := apphor(x, x + w - 2, y, d, specialChar('hbar)) + d := APP(specialChar('ulc), x, y, d) + d := APP(specialChar('lrc), x + w - 1, y, d) + +zagSub(u) == + height CADR rest u + +zagSuper(u) == + height CADR u + +zagWidth(x) == + #x = 1 => 0 + #x = 2 => 4 + WIDTH x.1 + 4 + MAX(WIDTH x.1, WIDTH x.2) + +rootWidth(x) == + #x <= 2 => 3 + WIDTH x.1 + 2 + WIDTH x.1 + WIDTH x.2 + +rootSub(x) == + subspan x.1 + +rootSuper(x) == + normal := 1 + superspan x.1 + #x <= 2 => normal + (radOver := height x.2 - height x.1) < 0 => normal + normal + radOver + +appmat(u, x, y, d) == + rows := CDDR u + p := matSuper u + q := matSub u + d := matrixBorder(x, y - q, y + p, d, 'left) + x := 1 + x + yc := 1 + y + p + w := CADR u + wl := CDAR w + subl := rest CADR w + superl := rest CADR rest w + repeat + null rows => return(matrixBorder(x + WIDTH u - 2, + y - q, + y + p, + d, + 'right)) + xc := x + yc := yc - 1 - first superl + w := wl + row := CDAR rows + repeat + if flag = '"ON" then + flag := '"OFF" + return(nil) + null row => + repeat + yc := yc - 1 - first subl + subl := rest subl + superl := rest superl + rows := rest rows + return(flag := '"ON"; nil) + d := APP(first row, + xc + QUOTIENT(first w - WIDTH first row, 2), + yc, + d) + xc := xc + 2 + first w + row := rest row + w := rest w + +matSuper(x) == + (x := x.1) => -1 + QUOTIENT(first x.1 + first x.2, 2) + true => ERROR('MAT) + +matSub(x) == + (x := x.1) => QUOTIENT(-1 + first x.1 + first x.2, 2) + true => ERROR('MAT) + +matWidth(x) == + y := CDDR x -- list of rows, each of form ((ROW . w) element element ...) + numOfColumns := LENGTH CDAR y + widthList := matLSum2 matWList(y, NLIST(numOfColumns, 0)) + --returns ["max width of entries in column i" for i in 1..numberOfRows] + subspanList := matLSum matSubList y + superspanList := matLSum matSuperList y + RPLAC(x.1,[widthList, subspanList, superspanList]) + CAAR x.1 + +matLSum(x) == + CONS(sumoverlist x + LENGTH x, x) + +matLSum2(x) == + CONS(sumoverlist x + 2*(LENGTH x), x) + +matWList(x, y) == + null x => y + true => matWList(rest x, matWList1(CDAR x, y) ) + +matWList1(x, y) == + null x => nil + true => CONS(MAX(WIDTH first x, first y), matWList1(rest x, rest y) ) + +matSubList(x) == --computes the max/[subspan(e) for e in "row named x"] + null x => nil + true => CONS(matSubList1(CDAR x, 0), matSubList(rest x) ) + +matSubList1(x, y) == + null x => y + true => matSubList1(rest x, MAX(y, subspan first x) ) + +matSuperList(x) == --computes the max/[superspan(e) for e in "row named x"] + null x => nil + true => CONS(matSuperList1(CDAR x, 0), matSuperList(rest x) ) + +matSuperList1(x, y) == + null x => y + true => matSuperList1(rest x, MAX(y, superspan first x) ) + +minusWidth(u) == + -1 + sumWidthA rest u + +-- opSrch(name, x) == +-- LASSOC(name, x) or '"," + +bracketagglist(u, start, linelength, tchr, open, close) == + u := CONS(LIST('CONCAT, open, first u), + [LIST('CONCAT, '" ", y) for y in rest u] ) + repeat + s := 0 + for x in tails u repeat + lastx := x + ((s := s + WIDTH first x + 1) >= linelength) => return(s) + null rest x => return(s := -1) + nil or + EQ(s, -1) => (nextu := nil) + EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) ) + true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil)) + for x in tails u repeat + RPLACA(x, LIST('CONCAT, first x, tchr)) + if null nextu then RPLACA(CDDR LAST u, close) + x := ASSOCIATER('CONCAT, CONS(ichr, u)) + charybdis(ASSOCIATER('CONCAT, u), start, linelength) + if $collectOutput then TERPRI $algebraOutputStream + ichr := '" " + u := nextu + null u => return(nil) + +prnd(start, op) == +--> + $testOutputLineFlag => + string := STRCONC(fillerSpaces MAX(0,start - 1),op) + $testOutputLineList := [string,:$testOutputLineList] + PRINTEXP(fillerSpaces MAX(0,start - 1),$algebraOutputStream) + $collectOutput => + string := STRCONC(fillerSpaces MAX(0,start - 1),op) + $outputLines := [string, :$outputLines] + PRINTEXP(op,$algebraOutputStream) + TERPRI $algebraOutputStream + +qTSub(u) == + subspan CADR u + +qTSuper(u) == + superspan CADR u + +qTWidth(u) == + 2 + WIDTH CADR u + +remWidth(x) == + atom x => x + true => CONS( (atom first x => first x; true => CAAR x), + MMAPCAR(remWidth, rest x) ) + +subSub(u) == + height CDDR u + +subSuper u == + superspan u.1 + +letWidth u == + 5 + WIDTH u.1 + WIDTH u.2 + +sumoverlist(u) == +/[x for x in u] + +sumWidth u == + WIDTH u.1 + sumWidthA CDDR u + +sumWidthA u == + ^u => 0 + ( member(keyp absym first u,'(_+ _-)) => 5; true => 3) + + WIDTH absym first u + + sumWidthA rest u + +superSubApp(u, x, y, di) == + a := first (u := rest u) + b := first (u := rest u) + c := first (u := KDR u) or '((NOTHING . 0)) + d := KAR (u := KDR u) or '((NOTHING . 0)) + e := KADR u or '((NOTHING . 0)) + aox := MAX(wd := WIDTH d, we := WIDTH e) + ar := superspan a + ab := subspan a + aw := WIDTH a + di := APP(d, x + (aox - wd), 1 + ar + y + subspan d, di) + di := APP(a, x + aox, y, di) + di := APP(c, aox + aw + x, 1 + y + ar + subspan c, di) + di := APP(e, x + (aox - we), y - 1 - MAX(superspan e, ab), di) + di := APP(b, aox + aw + x, y - 1 - MAX(ab, superspan b), di) + return di + +stringer x == + STRINGP x => x + EQ('_|, FETCHCHAR(s:= STRINGIMAGE x, 0)) => + RPLACSTR(s, 0, 1, "", nil, nil) + s + +superSubSub u == + a:= first (u:= rest u) + b:= KAR (u := KDR u) + e:= KAR KDR KDR KDR u + return subspan a + MAX(height b, height e) + +binomApp(u,x,y,d) == + [num,den] := rest u + ysub := y - 1 - superspan den + ysup := y + 1 + subspan num + wden := WIDTH den + wnum := WIDTH num + w := MAX(wden,wnum) + d := APP(den,x+1+ half(w - wden),ysub,d) + d := APP(num,x+1+ half(w - wnum),ysup,d) + hnum := height num + hden := height den + w := 1 + w + for j in 0..(hnum - 1) repeat + d := appChar(specialChar 'vbar,x,y + j,d) + d := appChar(specialChar 'vbar,x + w,y + j,d) + for j in 1..(hden - 1) repeat + d := appChar(specialChar 'vbar,x,y - j,d) + d := appChar(specialChar 'vbar,x + w,y - j,d) + d := appChar(specialChar 'ulc,x,y + hnum,d) + d := appChar(specialChar 'urc,x + w,y + hnum,d) + d := appChar(specialChar 'llc,x,y - hden,d) + d := appChar(specialChar 'lrc,x + w,y - hden,d) + +binomSub u == height CADDR u +binomSuper u == height CADR u +binomWidth u == 2 + MAX(WIDTH CADR u, WIDTH CADDR u) + +altSuperSubApp(u, x, y, di) == + a := first (u := rest u) + ar := superspan a + ab := subspan a + aw := WIDTH a + di := APP(a, x, y, di) + x := x + aw + + sublist := everyNth(u := rest u, 2) + suplist := everyNth(IFCDR u, 2) + + ysub := y - 1 - APPLY('MAX, [ab, :[superspan s for s in sublist]]) + ysup := y + 1 + APPLY('MAX, [ar, :[subspan s for s in sublist]]) + for sub in sublist for sup in suplist repeat + wsub := WIDTH sub + wsup := WIDTH sup + di := APP(sub, x, ysub, di) + di := APP(sup, x, ysup, di) + x := x + 1 + MAX(wsub, wsup) + di + +everyNth(l, n) == + [(e := l.0; for i in 1..n while l repeat l := rest l; e) while l] + + +altSuperSubSub u == + span := subspan CADR u + sublist := everyNth(CDDR u, 2) + for sub in sublist repeat + h := height sub + if h > span then span := h + span + +altSuperSubSuper u == + span := superspan CADR u + suplist := everyNth(IFCDR CDDR u, 2) + for sup in suplist repeat + h := height sup + if h > span then span := h + span + +altSuperSubWidth u == + w := WIDTH CADR u + suplist := everyNth(IFCDR CDDR u, 2) + sublist := everyNth(CDDR u, 2) + for sup in suplist for sub in sublist repeat + wsup := WIDTH sup + wsub := WIDTH sub + w := w + 1 + MAX(wsup, wsub) + w + +superSubWidth u == + a := first (u := rest u) + b := first (u := rest u) + c := first (u := KDR u) or '((NOTHING . 0)) + d := KAR (u := KDR u) or '((NOTHING . 0)) + e := KADR u or '((NOTHING . 0)) + return MAX(WIDTH d, WIDTH e) + MAX(WIDTH b, WIDTH c) + WIDTH a + +superSubSuper u == + a:= first (u := rest u) + c:= KAR (u := KDR KDR u) + d:= KADR u + return superspan a + MAX(height c, height d) + +suScWidth u == + WIDTH u.1 + aggwidth CDDR u + +transcomparg(x) == + y := first x + args := first _*NTH(STANDARGLIST, 1 + LENGTH y) + repeat + if true then + null y => return(nil) + (atom first y) and member(first y, FRLIS_*) => + conds := CONS(LIST('EQUAL1, first args, first y), conds) + y := SUBST(first args, first y, y) + x := SUBST(first args, first y, x) + (first y = first args) => nil + true => conds := CONS(LIST('EQUAL1, first args, first y), conds) + y := rest y + args := rest args + conds := + null conds => rest CADR x + ANDSIMP(CONS('AND, APPEND(REVERSEWOC conds, + LIST(rest CADR x) ) ) ) + LIST((conds => conds; true => 1), CADR rest x) + +vconcatapp(u, x, y, d) == + w := vConcatWidth u + y := y + superspan u.1 + 1 + for a in rest u repeat + y := y - superspan a - 1 + xoff := QUOTIENT(w - WIDTH a, 2) + d := APP(a, x + xoff, y, d) + y := y - subspan a + d + +binomialApp(u, x, y, d) == + [.,b,a] := u + w := vConcatWidth u + d := APP('"(",x,y,d) + x := x + 1 + y1 := y - height a + xoff := QUOTIENT(w - WIDTH a, 2) + d := APP(a, x + xoff, y1, d) + y2 := y + height b + xoff := QUOTIENT(w - WIDTH b, 2) + d := APP(b, x + xoff, y2, d) + x := x + w + APP('")",x,y,d) + +vConcatSub u == + subspan u.1 + +/[height a for a in CDDR u] +vConcatSuper u == + superspan u.1 +vConcatWidth u == + w := 0 + for a in rest u repeat if (wa := WIDTH a) > w then w := wa + w +binomialSub u == height u.2 + 1 + +binomialSuper u == height u.1 + 1 + +binomialWidth u == 2 + MAX(WIDTH u.1, WIDTH u.2) + +mathPrint u == + if ^$collectOutput then TERPRI $algebraOutputStream + (u := STRINGP mathPrint1(mathPrintTran u, nil) => + PSTRING u; nil) + +mathPrintTran u == + atom u => u + true => + for x in tails u repeat + RPLAC(first x, mathPrintTran first x) + u + +mathPrint1(x,fg) == + if fg and ^$collectOutput then TERPRI $algebraOutputStream + maPrin x + if fg and ^$collectOutput then TERPRI $algebraOutputStream + +maPrin u == + null u => nil +--> + if $runTestFlag or $mkTestFlag then + $mkTestOutputStack := [COPY u, :$mkTestOutputStack] + $highlightDelta := 0 + c := CATCH('outputFailure,charybdis(u, $MARGIN, $LINELENGTH)) + c ^= 'outputFailure => c + sayKeyedMsg("S2IX0009",NIL) + u is ['EQUATNUM,num,form] or u is [['EQUATNUM,:.],num,form] => + charybdis(['EQUATNUM,num], $MARGIN, $LINELENGTH) + if ^$collectOutput then + TERPRI $algebraOutputStream + PRETTYPRINT(form,$algebraOutputStream) + form + if ^$collectOutput then PRETTYPRINT(u,$algebraOutputStream) + nil diff --git a/src/interp/i-output.boot.pamphlet b/src/interp/i-output.boot.pamphlet deleted file mode 100644 index b21fe469..00000000 --- a/src/interp/i-output.boot.pamphlet +++ /dev/null @@ -1,2483 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/i-output.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{GCL\_log10\_bug} - -In some versions of GCL the LOG10 function returns improperly rounded values. -The symptom is: -\begin{verbatim} -(24) -> [1000] - (24) [100] -\end{verbatim} -The common lisp failure can be shown with: -\begin{verbatim} -(25) -> )lisp (log10 1000) -Value = 2.9999999999999996 -\end{verbatim} -This previous boot code was: -\begin{verbatim} - u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR LOG10 u -\end{verbatim} -and should be restored when the GCL bug is fixed. -<>= - u < MOST_-POSITIVE_-LONG_-FLOAT => 1+negative+FLOOR ((LOG10 u) + 0.0000001) -@ -\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" - ---Modified JHD February 1993: see files miscout.input for some tests of this --- General principle is that maprin0 is the top-level routine, --- which calls maprinChk to print the object (placing certain large --- matrices on a look-aside list), then calls maprinRows to print these. --- These prints call maprinChk recursively, and maprinChk has to ensure that --- we do not end up in an infinite recursion: matrix1 = matrix2 ... - ---% Output display routines - -$defaultSpecialCharacters == [ - EBCDIC( 28), -- upper left corner - EBCDIC( 27), -- upper right corner - EBCDIC( 30), -- lower left corner - EBCDIC( 31), -- lower right corner - EBCDIC( 79), -- vertical bar - EBCDIC( 45), -- horizontal bar - EBCDIC(144), -- APL quad - EBCDIC(173), -- left bracket - EBCDIC(189), -- right bracket - EBCDIC(192), -- left brace - EBCDIC(208), -- right brace - EBCDIC( 59), -- top box tee - EBCDIC( 62), -- bottom box tee - EBCDIC( 63), -- right box tee - EBCDIC( 61), -- left box tee - EBCDIC( 44), -- center box tee - EBCDIC(224) -- back slash - ] - -$plainSpecialCharacters0 == [ - EBCDIC( 78), -- upper left corner (+) - EBCDIC( 78), -- upper right corner (+) - EBCDIC( 78), -- lower left corner (+) - EBCDIC( 78), -- lower right corner (+) - EBCDIC( 79), -- vertical bar - EBCDIC( 96), -- horizontal bar (-) - EBCDIC(111), -- APL quad (?) - EBCDIC(173), -- left bracket - EBCDIC(189), -- right bracket - EBCDIC(192), -- left brace - EBCDIC(208), -- right brace - EBCDIC( 78), -- top box tee (+) - EBCDIC( 78), -- bottom box tee (+) - EBCDIC( 78), -- right box tee (+) - EBCDIC( 78), -- left box tee (+) - EBCDIC( 78), -- center box tee (+) - EBCDIC(224) -- back slash - ] - -$plainSpecialCharacters1 == [ - EBCDIC(107), -- upper left corner (,) - EBCDIC(107), -- upper right corner (,) - EBCDIC(125), -- lower left corner (') - EBCDIC(125), -- lower right corner (') - EBCDIC( 79), -- vertical bar - EBCDIC( 96), -- horizontal bar (-) - EBCDIC(111), -- APL quad (?) - EBCDIC(173), -- left bracket - EBCDIC(189), -- right bracket - EBCDIC(192), -- left brace - EBCDIC(208), -- right brace - EBCDIC( 78), -- top box tee (+) - EBCDIC( 78), -- bottom box tee (+) - EBCDIC( 78), -- right box tee (+) - EBCDIC( 78), -- left box tee (+) - EBCDIC( 78), -- center box tee (+) - EBCDIC(224) -- back slash - ] - -$plainSpecialCharacters2 == [ - EBCDIC( 79), -- upper left corner (|) - EBCDIC( 79), -- upper right corner (|) - EBCDIC( 79), -- lower left corner (|) - EBCDIC( 79), -- lower right corner (|) - EBCDIC( 79), -- vertical bar - EBCDIC( 96), -- horizontal bar (-) - EBCDIC(111), -- APL quad (?) - EBCDIC(173), -- left bracket - EBCDIC(189), -- right bracket - EBCDIC(192), -- left brace - EBCDIC(208), -- right brace - EBCDIC( 78), -- top box tee (+) - EBCDIC( 78), -- bottom box tee (+) - EBCDIC( 78), -- right box tee (+) - EBCDIC( 78), -- left box tee (+) - EBCDIC( 78), -- center box tee (+) - EBCDIC(224) -- back slash - ] - -$plainSpecialCharacters3 == [ - EBCDIC( 96), -- upper left corner (-) - EBCDIC( 96), -- upper right corner (-) - EBCDIC( 96), -- lower left corner (-) - EBCDIC( 96), -- lower right corner (-) - EBCDIC( 79), -- vertical bar - EBCDIC( 96), -- horizontal bar (-) - EBCDIC(111), -- APL quad (?) - EBCDIC(173), -- left bracket - EBCDIC(189), -- right bracket - EBCDIC(192), -- left brace - EBCDIC(208), -- right brace - EBCDIC( 78), -- top box tee (+) - EBCDIC( 78), -- bottom box tee (+) - EBCDIC( 78), -- right box tee (+) - EBCDIC( 78), -- left box tee (+) - EBCDIC( 78), -- center box tee (+) - EBCDIC(224) -- back slash - ] - -$plainRTspecialCharacters == [ - '_+, -- upper left corner (+) - '_+, -- upper right corner (+) - '_+, -- lower left corner (+) - '_+, -- lower right corner (+) - '_|, -- vertical bar - '_-, -- horizontal bar (-) - '_?, -- APL quad (?) - '_[, -- left bracket - '_], -- right bracket - '_{, -- left brace - '_}, -- right brace - '_+, -- top box tee (+) - '_+, -- bottom box tee (+) - '_+, -- right box tee (+) - '_+, -- left box tee (+) - '_+, -- center box tee (+) - '_\ -- back slash - ] - -makeCharacter n ==> INTERN(STRING(CODE_-CHAR n)) - -$RTspecialCharacters == [ - makeCharacter 218, -- upper left corner (+) - makeCharacter 191, -- upper right corner (+) - makeCharacter 192, -- lower left corner (+) - makeCharacter 217, -- lower right corner (+) - makeCharacter 179, -- vertical bar - makeCharacter 196, -- horizontal bar (-) - $quadSymbol, -- APL quad (?) - '_[, -- left bracket - '_], -- right bracket - '_{, -- left brace - '_}, -- right brace - makeCharacter 194, -- top box tee (+) - makeCharacter 193, -- bottom box tee (+) - makeCharacter 180, -- right box tee (+) - makeCharacter 195, -- left box tee (+) - makeCharacter 197, -- center box tee (+) - '_\ -- back slash - ] - -$specialCharacters := $RTspecialCharacters - -$specialCharacterAlist == '( - (ulc . 0)_ - (urc . 1)_ - (llc . 2)_ - (lrc . 3)_ - (vbar . 4)_ - (hbar . 5)_ - (quad . 6)_ - (lbrk . 7)_ - (rbrk . 8)_ - (lbrc . 9)_ - (rbrc . 10)_ - (ttee . 11)_ - (btee . 12)_ - (rtee . 13)_ - (ltee . 14)_ - (ctee . 15)_ - (bslash . 16)_ - ) - -$collectOutput := nil - -specialChar(symbol) == - -- looks up symbol in $specialCharacterAlist, gets the index - -- into the EBCDIC table, and returns the appropriate character - null (code := IFCDR ASSQ(symbol,$specialCharacterAlist)) => '"?" - ELT($specialCharacters,code) - -rbrkSch() == PNAME specialChar 'rbrk -lbrkSch() == PNAME specialChar 'lbrk -quadSch() == PNAME specialChar 'quad - -isBinaryInfix x == - x in '(_= _+ _- _* _/ _*_* _^ "=" "+" "-" "*" "/" "**" "^") - -stringApp([.,u],x,y,d) == - appChar(STRCONC($DoubleQuote,atom2String u,$DoubleQuote),x,y,d) - -stringWidth u == - u is [.,u] or THROW('outputFailure,'outputFailure) - 2+#u - -obj2String o == - atom o => - STRINGP o => o - o = " " => '" " - o = ")" => '")" - o = "(" => '"(" - STRINGIMAGE o - APPLY('STRCONC,[obj2String o' for o' in o]) - -APP(u,x,y,d) == - atom u => appChar(atom2String u,x,y,d) - u is [[op,:.],a] and (s:= GETL(op,'PREFIXOP)) => - GETL(op,'isSuffix) => appChar(s,x+WIDTH a,y,APP(a,x,y,d)) - APP(a,x+#s,y,appChar(s,x,y,d)) - u is [[id,:.],:.] => - fn := GETL(id,'APP) => FUNCALL(fn,u,x,y,d) - not NUMBERP id and (d':= appInfix(u,x,y,d))=> d' - appelse(u,x,y,d) - appelse(u,x,y,d) - -atom2String x == - IDENTP x => PNAME x - STRINGP x => x - stringer x - --- General convention in the "app..." functions: --- Added from an attempt to fix bugs by JHD: 2 Aug 89 --- the first argument is what has to be printed --- the second - x - is the horizontal distance along the page --- at which to start --- the third - y - is some vertical hacking control --- the foruth - d - is the "layout" so far --- these functions return an updated "layout so far" in general - -appChar(string,x,y,d) == - if CHARP string then string := PNAME string - line:= LASSOC(y,d) => - if MAXINDEX string = 1 and char(string.0) = "%" then - string.1="b" => - bumpDeltaIfTrue:= true - string.0:= EBCDIC 29 - string.1:= EBCDIC 200 - string.1="d" => - bumpDeltaIfTrue:= true - string.0:= EBCDIC 29 - string.1:= EBCDIC 65 - shiftedX:= (y=0 => x+$highlightDelta; x) - --shift x for brightening characters -- presently only if y=0 - RPLACSTR(line,shiftedX,n:=#string,string,0,n) - if bumpDeltaIfTrue=true then $highlightDelta:= $highlightDelta+1 - d - appChar(string,x,y,nconc(d,[[y,:GETFULLSTR(10+$LINELENGTH+$MARGIN," ")]])) - -print(x,domain) == - dom:= devaluate domain - $InteractiveMode: local:= true - $dontDisplayEquatnum: local:= true - output(x,dom) - -mathprintWithNumber x == - x:= outputTran x - maprin - $IOindex => ['EQUATNUM,$IOindex,x] - x - -mathprint x == - x := outputTran x - $saturn => texFormat1 x - maprin x - -sayMath u == - for x in u repeat acc:= concat(acc,linearFormatName x) - sayALGEBRA acc - ---% Output transformations - -outputTran x == - x in '("failed" "nil" "prime" "sqfr" "irred") => - STRCONC('"_"",x,'"_"") - STRINGP x => x - VECP x => - outputTran ['BRACKET,['AGGLST,:[x.i for i in 0..MAXINDEX x]]] - NUMBERP x => - MINUSP x => ["-",MINUS x] - x - atom x => - x=$EmptyMode => specialChar 'quad - x - x is [c,var,mode] and c in '(_pretend _: _:_: _@) => - var := outputTran var - if PAIRP var then var := ['PAREN,var] - ['CONCATB,var,c,obj2String prefix2String mode] - x is ['ADEF,vars,.,.,body] => - vars := - vars is [x] => x - ['Tuple,:vars] - outputTran ["+->", vars, body] - x is ['MATRIX,:m] => outputTranMatrix m - x is ['matrix,['construct,c]] and - c is ['COLLECT,:m,d] and d is ['construct,e] and e is ['COLLECT,:.] => - outputTran ['COLLECT,:m,e] - x is ['LIST,:l] => outputTran ['BRACKET,['AGGLST,:l]] - x is ['MAP,:l] => outputMapTran l - x is ['brace, :l] => - ['BRACE, ['AGGLST,:[outputTran y for y in l]]] - x is ['return,l] => ['return,outputTran l] - x is ['return,.,:l] => ['return,:outputTran l] - x is ['construct,:l] => - ['BRACKET,['AGGLST,:[outputTran y for y in l]]] - - x is [["$elt",domain,"float"], x, y, z] and (domain = $DoubleFloat or - domain is ['Float]) and INTEGERP x and INTEGERP y and INTEGERP z and - z > 0 and (float := getFunctionFromDomain("float",domain,[$Integer,$Integer,$PositiveInteger])) => - f := SPADCALL(x,y,z,float) - o := coerceInteractive(mkObjWrap(f, domain), '(OutputForm)) - objValUnwrap o - - [op,:l]:= flattenOps x - --needed since "op" is string in some spad code - if STRINGP op then (op := INTERN op; x:= [op,:l]) - op = 'LAMBDA_-CLOSURE => 'Closure - x is ['break,:.] => 'break - x is ['SEGMENT,a] => - a' := outputTran a - if LISTP a' then a' := ['PAREN,a'] - ['SEGMENT,a'] - x is ['SEGMENT,a,b] => - a' := outputTran a - b' := outputTran b - if LISTP a' then a' := ['PAREN,a'] - if LISTP b' then b' := ['PAREN,b'] - ['SEGMENT,a',b'] - - op is ["$elt",targ,fun] or not $InteractiveMode and op is ["elt",targ,fun] => - -- l has the args - targ' := obj2String prefix2String targ - if 2 = #targ then targ' := ['PAREN,targ'] - ['CONCAT,outputTran [fun,:l],'"$",targ'] - x is ["$elt",targ,c] or not $InteractiveMode and x is ["elt",targ,c] => - targ' := obj2String prefix2String targ - if 2 = #targ then targ' := ['PAREN,targ'] - ['CONCAT,outputTran c,'"$",targ'] - x is ["-",a,b] => - a := outputTran a - b := outputTran b - INTEGERP b => - b < 0 => ["+",a,-b] - ["+",a,["-",b]] - b is ["-",c] => ["+",a,c] - ["+",a,["-",b]] - - -- next stuff translates exp(log(foo4)/foo3) into ROOT(foo4,foo3) - (x is ["**", ='"%e",foo1]) and (foo1 is [ ='"/",foo2, foo3]) and - INTEGERP(foo3) and (foo2 is ['log,foo4]) => - foo3 = 2 => ['ROOT,outputTran foo4] - ['ROOT,outputTran foo4,outputTran foo3] - (x is ["**", ='"%e",foo1]) and (foo1 is [op',foo2, foo3]) and - (op' = '"*") and ((foo3 is ['log,foo4]) or (foo2 is ['log,foo4])) => - foo3 is ['log,foo4] => - ["**", outputTran foo4, outputTran foo2] - foo4 := CADR foo2 - ["**", outputTran foo4, outputTran foo3] - op = 'IF => outputTranIf x - op = 'COLLECT => outputTranCollect x - op = 'REDUCE => outputTranReduce x - op = 'REPEAT => outputTranRepeat x - op = 'SEQ => outputTranSEQ x - op in '(cons nconc) => outputConstructTran x - l:= [outputTran y for y in l] - op = "*" => - l is [a] => outputTran a - l is [["-",a],:b] => - -- now this is tricky because we've already outputTran the list - -- expect trouble when outputTran hits b again - -- some things object to being outputTran twice ,e.g.matrices - -- same thing a bit lower down for "/" - a=1 => outputTran ["-",[op,:b]] - outputTran ["-",[op,a,:b]] - [op,:"append"/[(ss is ["*",:ll] => ll; [ss]) for ss in l]] - op = "+" => - l is [a] => outputTran a - [op,:"append"/[(ss is ["+",:ll] => ll; [ss]) for ss in l]] - op = "/" => - if $fractionDisplayType = 'horizontal then op := 'SLASH - else op := 'OVER - l is [["-",a],:b] => outputTran ["-",[op,a,:b]] - [outputTran op,:l] - op="|" and l is [["Tuple",:u],pred] => - ['PAREN,["|",['AGGLST,:l],pred]] - op='Tuple => ['PAREN,['AGGLST,:l]] - op='LISTOF => ['AGGLST,:l] - IDENTP op and ^(op in '(_* _*_*) ) and char("*") = (PNAME op).0 => - mkSuperSub(op,l) - [outputTran op,:l] - --- The next two functions are designed to replace successive instances of --- binary functions with the n-ary equivalent, cutting down on recursion --- in outputTran and in partciular allowing big polynomials to be printed --- without stack overflow. MCD. -flattenOps l == - [op, :args ] := l - op in ['"+",'"*","+","*"] => - [op,:checkArgs(op,args)] - l - -checkArgs(op,tail) == - head := [] - while tail repeat - term := first tail - atom term => - head := [term,:head] - tail := rest tail - not LISTP term => -- never happens? - head := [term,:head] - tail := rest tail - op=first term => - tail := [:rest term,:rest tail] - head := [term,:head] - tail := rest tail - REVERSE head - -outputTranSEQ ['SEQ,:l,exitform] == - if exitform is ['exit,.,a] then exitform := a - ['SC,:[outputTran x for x in l],outputTran exitform] - -outputTranIf ['IF,x,y,z] == - y = 'noBranch => - ['CONCATB,'if,['CONCATB,'not,outputTran x],'then,outputTran z] - z = 'noBranch => - ['CONCATB,'if,outputTran x,'then,outputTran y] - y' := outputTran y - z' := outputTran z ---y' is ['SC,:.] or z' is ['SC,:.] => --- ['CONCATB,'if,outputTran x, --- ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] ---['CONCATB,'if,outputTran x,'then,outputTran y,'else,outputTran z] - ['CONCATB,'if,outputTran x, - ['SC,['CONCATB,'then,y'],['CONCATB,'else,z']]] - -outputMapTran l == - null l => NIL -- should not happen - - -- display subscripts linearly - $linearFormatScripts : local := true - - -- get the real names of the parameters - alias := get($op,'alias,$InteractiveFrame) - - rest l => -- if multiple forms, call repeatedly - ['SC,:[outputMapTran0(ll,alias) for ll in l]] - outputMapTran0(first l,alias) - -outputMapTran0(argDef,alias) == - arg := first argDef - def := rest argDef - [arg',:def'] := simplifyMapPattern(argDef,alias) - arg' := outputTran arg' - if null arg' then arg' := '"()" - ['CONCATB,$op,outputTran arg',"==",outputTran def'] - -outputTranReduce ['REDUCE,op,.,body] == - ['CONCAT,op,"/",outputTran body] - -outputTranRepeat ["REPEAT",:itl,body] == - body' := outputTran body - itl => - itlist:= outputTranIteration itl - ['CONCATB,itlist,'repeat,body'] - ['CONCATB,'repeat,body'] - -outputTranCollect [.,:itl,body] == - itlist:= outputTranIteration itl - ['BRACKET,['CONCATB,outputTran body,itlist]] - -outputTranIteration itl == - null rest itl => outputTranIterate first itl - ['CONCATB,outputTranIterate first itl,outputTranIteration rest itl] - -outputTranIterate x == - x is ['STEP,n,init,step,:final] => - init' := outputTran init - if LISTP init then init' := ['PAREN,init'] - final' := - final => - LISTP first final => [['PAREN,outputTran first final]] - [outputTran first final] - NIL - ['STEP,outputTran n,init',outputTran step,:final'] - x is ["IN",n,s] => ["IN",outputTran n,outputTran s] - x is [op,p] and op in '(_| UNTIL WHILE) => - op:= DOWNCASE op - ['CONCATB,op,outputTran p] - throwKeyedMsg("S2IX0008",['outputTranIterate,['"illegal iterate: ",x]]) - -outputConstructTran x == - x is [op,a,b] => - a:= outputTran a - b:= outputTran b - op="cons" => - b is ['construct,:l] => ['construct,a,:l] - ['BRACKET,['AGGLST,:[a,[":",b]]]] - op="nconc" => - aPart := - a is ['construct,c] and c is ['SEGMENT,:.] => c - [":",a] - b is ['construct,:l] => ['construct,aPart,:l] - ['BRACKET,['AGGLST,aPart,[":",b]]] - [op,a,b] - atom x => x - [outputTran first x,:outputConstructTran rest x] - -outputTranMatrix x == - not VECP x => - -- assume that the only reason is that we've been done before - ["MATRIX",:x] - --keyedSystemError("S2GE0016",['"outputTranMatrix", - -- '"improper internal form for matrix found in output routines"]) - ["MATRIX",nil,:[outtranRow x.i for i in 0..MAXINDEX x]] where - outtranRow x == - not VECP x => - keyedSystemError("S2GE0016",['"outputTranMatrix", - '"improper internal form for matrix found in output routines"]) - ["ROW",:[outputTran x.i for i in 0..MAXINDEX x]] - -mkSuperSub(op,argl) == - $linearFormatScripts => linearFormatForm(op,argl) --- l := [(STRINGP f => f; STRINGIMAGE f) --- for f in linearFormatForm(op,argl)] --- "STRCONC"/l - 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]) - -- if there is just a subscript use the SUB special form - #indexList=2 => - subPart:= ['SUB,cleanOp,:take(indexList.1,argl)] - l:= drop(indexList.1,argl) => [subPart,:l] - subPart - -- otherwise use the SUPERSUB form - superSubPart := NIL - for i in rest indexList repeat - scripts := - this:= take(i,argl) - argl:= drop(i,argl) - i=0 => ['AGGLST] - i=1 => first this - ['AGGLST,:this] - superSubPart := cons(scripts,superSubPart) - superSub := ['SUPERSUB,cleanOp,:reverse superSubPart] - argl => [superSub,:argl] - superSub - -timesApp(u,x,y,d) == - rightPrec:= getOpBindingPower("*","Led","right") - firstTime:= true - for arg in rest u repeat - op:= keyp arg - if ^firstTime and (needBlankForRoot(lastOp,op,arg) or - needStar(wasSimple,wasQuotient,wasNumber,arg,op) or - wasNumber and op = 'ROOT and subspan arg = 1) then - d:= APP(BLANK,x,y,d) - x:= x+1 - [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg - wasSimple:= atom arg and not NUMBERP arg or isRationalNumber arg - wasQuotient:= isQuotient op - wasNumber:= NUMBERP arg - lastOp := op - firstTime:= nil - d - -needBlankForRoot(lastOp,op,arg) == - lastOp ^= "^" and lastOp ^= "**" and not(subspan(arg)>0) => false - op = "**" and keyp CADR arg = 'ROOT => true - op = "^" and keyp CADR arg = 'ROOT => true - op = 'ROOT and CDDR arg => true - false - -stepApp([.,a,init,one,:optFinal],x,y,d) == - d:= appChar('"for ",x,y,d) - d:= APP(a,w:=x+4,y,d) - d:= appChar('" in ",w:=w+WIDTH a,y,d) - d:= APP(init,w:=w+4,y,d) - d:= APP('"..",w:=w+WIDTH init,y,d) - if optFinal then d:= APP(first optFinal,w+2,y,d) - d - -stepSub [.,a,init,one,:optFinal] == - m:= MAX(subspan a,subspan init) - optFinal => MAX(m,subspan first optFinal) - m - -stepSuper [.,a,init,one,:optFinal] == - m:= MAX(superspan a,superspan init) - optFinal => MAX(m,superspan first optFinal) - m - -stepWidth [.,a,init,one,:optFinal] == - 10+WIDTH a+WIDTH init+(optFinal => WIDTH first optFinal; 0) - -inApp([.,a,s],x,y,d) == --for [IN,a,s] - d:= appChar('"for ",x,y,d) - d:= APP(a,x+4,y,d) - d:= appChar('" in ",x+WIDTH a+4,y,d) - APP(s,x+WIDTH a+8,y,d) - -inSub [.,a,s] == MAX(subspan a,subspan s) - -inSuper [.,a,s] == MAX(superspan a,superspan s) - -inWidth [.,a,s] == 8+WIDTH a+WIDTH s - -centerApp([.,u],x,y,d) == - d := APP(u,x,y,d) - -concatApp([.,:l],x,y,d) == concatApp1(l,x,y,d,0) - -concatbApp([.,:l],x,y,d) == concatApp1(l,x,y,d,1) - -concatApp1(l,x,y,d,n) == - for u in l repeat - d:= APP(u,x,y,d) - x:=x+WIDTH u+n - d - -concatSub [.,:l] == "MAX"/[subspan x for x in l] - -concatSuper [.,:l] == "MAX"/[superspan x for x in l] - -concatWidth [.,:l] == +/[WIDTH x for x in l] - -concatbWidth [.,:l] == +/[1+WIDTH x for x in l]-1 - -exptApp([.,a,b],x,y,d) == - pren:= exptNeedsPren a - d:= - pren => appparu(a,x,y,d) - APP(a,x,y,d) - x':= x+WIDTH a+(pren => 2;0) - y':= 1+y+superspan a+subspan b + (0=superspan a => 0; -1) - APP(b,x',y',d) - -exptNeedsPren a == - atom a and null (INTEGERP a and a < 0) => false - key:= keyp a - key = "OVER" => true -- added JHD 2/Aug/90 - (key="SUB") or (null GETL(key,"Nud") and null GETL(key,"Led")) => false - true - -exptSub u == subspan CADR u - -exptSuper [.,a,b] == superspan a+height b+(superspan a=0 => 0;-1) - -exptWidth [.,a,b] == WIDTH a+WIDTH b+(exptNeedsPren a => 2;0) - -needStar(wasSimple,wasQuotient,wasNumber,cur,op) == - wasQuotient or isQuotient op => true - wasSimple => - atom cur or keyp cur="SUB" or isRationalNumber cur or op="**" or op = "^" or - (atom op and ^NUMBERP op and ^GETL(op,"APP")) - wasNumber => - NUMBERP(cur) or isRationalNumber cur or - ((op="**" or op ="^") and NUMBERP(CADR cur)) - -isQuotient op == - op="/" or op="OVER" - -timesWidth u == - rightPrec:= getOpBindingPower("*","Led","right") - firstTime:= true - w:= 0 - for arg in rest u repeat - op:= keyp arg - if ^firstTime and needStar(wasSimple,wasQuotient,wasNumber,arg,op) then - w:= w+1 - if infixArgNeedsParens(arg, rightPrec, "left") then w:= w+2 - w:= w+WIDTH arg - wasSimple:= atom arg and not NUMBERP arg --or isRationalNumber arg - wasQuotient:= isQuotient op - wasNumber:= NUMBERP arg - firstTime:= nil - w - -plusApp([.,frst,:rst],x,y,d) == - appSum(rst,x+WIDTH frst,y,APP(frst,x,y,d)) - -appSum(u,x,y,d) == - for arg in u repeat - infixOp:= - syminusp arg => "-" - "+" - opString:= GETL(infixOp,"INFIXOP") or '"," - d:= APP(opString,x,y,d) - x:= x+WIDTH opString - arg:= absym arg --negate a neg. number or remove leading "-" - rightPrec:= getOpBindingPower(infixOp,"Led","right") - if infixOp = "-" then rightPrec:=rightPrec +1 - -- that +1 added JHD 2 Aug 89 to prevent x-(y+z) printing as x-y+z - -- Sutor found the example: - -- )cl all - -- p : P[x] P I := x - y - z - -- p :: P[x] FR P I - -- trailingCoef % - [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",nil) --app in a right arg - d - -appInfix(e,x,y,d) == - op := keyp e - leftPrec:= getOpBindingPower(op,"Led","left") - leftPrec = 1000 => return nil --no infix operator is allowed default value - rightPrec:= getOpBindingPower(op,"Led","right") - #e < 2 => throwKeyedMsg("S2IX0008",['appInfix, - '"fewer than 2 arguments to an infix function"]) - opString:= GETL(op,"INFIXOP") or '"," - opWidth:= WIDTH opString - [.,frst,:rst]:= e - null rst => - GETL(op,"isSuffix") => - [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) - d:= appChar(opString,x,y,d) - THROW('outputFailure,'outputFailure) - [d,x]:= appInfixArg(frst,x,y,d,leftPrec,"right",opString) --app in left arg - for arg in rst repeat - d:= appChar(opString,x,y,d) --app in the infix operator - x:= x+opWidth - [d,x]:= appInfixArg(arg,x,y,d,rightPrec,"left",opString) --app in right arg - d - -appconc(d,x,y,w) == NCONC(d,[[[x,:y],:w]]) - -infixArgNeedsParens(arg, prec, leftOrRight) == - prec > getBindingPowerOf(leftOrRight, arg) + 1 - -appInfixArg(u,x,y,d,prec,leftOrRight,string) == - insertPrensIfTrue:= infixArgNeedsParens(u,prec,leftOrRight) - d:= - insertPrensIfTrue => appparu(u,x,y,d) - APP(u,x,y,d) - x:= x+WIDTH u - if string then d:= appconc(d,x,y,string) - [d,(insertPrensIfTrue => x+2; x)] - -leftBindingPowerOf(x, ind) == - y := GETL(x, ind) - y => ELEMN(y, 3, 0) - 0 - -rightBindingPowerOf(x, ind) == - y := GETL(x, ind) - y => ELEMN(y, 4, 105) - 105 - -getBindingPowerOf(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 => getBindingPowerOf(key,["/",:argl]) - 1 - op = 'OVER => getBindingPowerOf(key,["/",:argl]) - (n:= #argl)=1 => - key="left" and (m:= getOpBindingPower(op,"Nud","left")) => m - key="right" and (m:= getOpBindingPower(op,"Nud","right")) => m - 1000 - n>1 => - key="left" and (m:= getOpBindingPower(op,"Led","left")) => m - key="right" and (m:= getOpBindingPower(op,"Led","right")) => m - op="ELT" => 1002 - 1000 - 1000 - 1002 - -getOpBindingPower(op,LedOrNud,leftOrRight) == - if op in '(SLASH OVER) then op := "/" - exception:= - leftOrRight="left" => 0 - 105 - bp:= - leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) - rightBindingPowerOf(op,LedOrNud) - bp^=exception => bp - 1000 - ---% Brackets -bracketApp(u,x,y,d) == - u is [.,u] or THROW('outputFailure,'outputFailure) - d:= appChar(specialChar 'lbrk,x,y,d) - d:=APP(u,x+1,y,d) - appChar(specialChar 'rbrk,x+1+WIDTH u,y,d) - ---% Braces -braceApp(u,x,y,d) == - u is [.,u] or THROW('outputFailure,'outputFailure) - d:= appChar(specialChar 'lbrc,x,y,d) - d:=APP(u,x+1,y,d) - appChar(specialChar 'rbrc,x+1+WIDTH u,y,d) - ---% Aggregates -aggWidth u == - rest u is [a,:l] => WIDTH a + +/[1+WIDTH x for x in l] - 0 - -aggSub u == subspan rest u - -aggSuper u == superspan rest u - -aggApp(u,x,y,d) == aggregateApp(rest u,x,y,d,",") - -aggregateApp(u,x,y,d,s) == - if u is [a,:l] then - d:= APP(a,x,y,d) - x:= x+WIDTH a - for b in l repeat - d:= APP(s,x,y,d) - d:= APP(b,x+1,y,d) - x:= x+1+WIDTH b - d - ---% Function to compute Width - -outformWidth u == --WIDTH as called from OUTFORM to do a COPY - STRINGP u => - u = $EmptyString => 0 - u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1 - #u - atom u => # atom2String u - WIDTH COPY u - -WIDTH u == - STRINGP u => - u = $EmptyString => 0 - u.0="%" and ((u.1 = char 'b) or (u.1 = char 'd)) => 1 - #u - INTEGERP u => - if (u < 1) then - negative := 1 - u := -u - else - negative := 0 - -- Try and be fairly exact for smallish integers: - u = 0 => 1 -<> - -- Rough guess: integer-length returns log2 rounded up, so divide it by - -- roughly log2(10). This should return an over-estimate, but for objects - -- this big does it matter? - FLOOR(INTEGER_-LENGTH(u)/3.3) - atom u => # atom2String u - putWidth u is [[.,:n],:.] => n - THROW('outputFailure,'outputFailure) - -putWidth u == - atom u or u is [[.,:n],:.] and NUMBERP n => u - op:= keyp u ---NUMBERP op => nil - leftPrec:= getBindingPowerOf("left",u) - rightPrec:= getBindingPowerOf("right",u) - [firstEl,:l] := u - interSpace:= - SYMBOLP firstEl and GETL(firstEl,"INFIXOP") => 0 - 1 - argsWidth:= - l is [firstArg,:restArg] => - RPLACA(rest u,putWidth firstArg) - for y in tails restArg repeat RPLACA(y,putWidth first y) - widthFirstArg:= - 0=interSpace and infixArgNeedsParens(firstArg,leftPrec,"right")=> - 2+WIDTH firstArg - WIDTH firstArg - widthFirstArg + +/[interSpace+w for x in restArg] where w() == - 0=interSpace and infixArgNeedsParens(x, rightPrec, "left") => - 2+WIDTH x - WIDTH x - 0 - newFirst:= - atom (oldFirst:= first u) => - fn:= GETL(oldFirst,"WIDTH") => - [oldFirst,:FUNCALL(fn,[oldFirst,:l])] - if l then ll := rest l else ll := nil - [oldFirst,:opWidth(oldFirst,ll)+argsWidth] - [putWidth oldFirst,:2+WIDTH oldFirst+argsWidth] - RPLACA(u,newFirst) - u - -opWidth(op,has2Arguments) == - op = "EQUATNUM" => 4 - NUMBERP op => 2+SIZE STRINGIMAGE op - null has2Arguments => - a:= GETL(op,"PREFIXOP") => SIZE a - 2+SIZE PNAME op - a:= GETL(op,"INFIXOP") => SIZE a - 2+SIZE PNAME op - -matrixBorder(x,y1,y2,d,leftOrRight) == - y1 = y2 => - c := - leftOrRight = 'left => specialChar('lbrk) - specialChar('rbrk) - APP(c,x,y1,d) - for y in y1..y2 repeat - c := - y = y1 => - leftOrRight = 'left => specialChar('llc) - specialChar('lrc) - y = y2 => - leftOrRight = 'left => specialChar('ulc) - specialChar('urc) - specialChar('vbar) - d := APP(c,x,y,d) - d - -isRationalNumber x == nil - -widthSC u == 10000 - ---% The over-large matrix package - -maprinSpecial(x,$MARGIN,$LINELENGTH) == maprin0 x --- above line changed JHD 13/2/93 since it used to call maPrin - -maprin x == - if $demoFlag=true then recordOrCompareDemoResult x - CATCH('output,maprin0 x) - nil - -maprin0 x == - $MatrixCount:local :=0 - $MatrixList:local :=nil - maprinChk x - if $MatrixList then maprinRows $MatrixList - -- above line moved JHD 28/2/93 to catch all routes through maprinChk - -maprinChk x == - null $MatrixList => maPrin x - ATOM x and (u:= ASSOC(x,$MatrixList)) => - $MatrixList := delete(u,$MatrixList) - maPrin deMatrix CDR u - x is ["=",arg,y] => --case for tracing with )math and printing matrices - u:=ASSOC(y,$MatrixList) => - -- we don't want to print matrix1 = matrix2 ... - $MatrixList := delete(u,$MatrixList) - maPrin ["=",arg, deMatrix CDR u] - maPrin x - x is ['EQUATNUM,n,y] => - $MatrixList is [[name,:value]] and y=name => - $MatrixList:=[] -- we are pulling this one off - maPrin ['EQUATNUM,n, deMatrix value] - IDENTP y => --------this part is never called - -- Not true: JHD 28/2/93 - -- m:=[[1,2,3],[4,5,6],[7,8,9]] - -- mm:=[[m,1,0],[0,m,1],[0,1,m]] - -- and try to print mm**5 - u := ASSOC(y,$MatrixList) - --$MatrixList := deleteAssoc(first u,$MatrixList) - -- deleteAssoc no longer exists - $MatrixList := delete(u,$MatrixList) - maPrin ['EQUATNUM,n,rest u] - if ^$collectOutput then TERPRI $algebraOutputStream - maPrin x - maPrin x - -- above line added JHD 13/2/93 since otherwise x gets lost - -maprinRows matrixList == - if ^$collectOutput then TERPRI($algebraOutputStream) - while matrixList repeat - y:=NREVERSE matrixList - --Makes the matrices come out in order, since CONSed on backwards - matrixList:=nil - firstName := first first y - for [name,:m] in y for n in 0.. repeat - if ^$collectOutput then TERPRI($algebraOutputStream) - andWhere := (name = firstName => '"where "; '"and ") - line := STRCONC(andWhere, PNAME name) - maprinChk ["=",line,m] - -- note that this could place a new element on $MatrixList, hence the loop - -deMatrix m == - ['BRACKET,['AGGLST, - :[['BRACKET,['AGGLST,:rest row]] for row in CDDR m]]] - -LargeMatrixp(u,width, dist) == - -- sees if there is a matrix wider than 'width' in the next 'dist' - -- part of u, a sized charybdis structure. - -- NIL if not, first such matrix if there is one - ATOM u => nil - CDAR u <= width => nil - --CDAR is the width of a charybdis structure - op:=CAAR u - op = 'MATRIX => largeMatrixAlist u - --We already know the structure is more than 'width' wide - MEMQ(op,'(LET RARROW SEGMENT _- CONCAT CONCATB PAREN BRACKET BRACE)) => - --Each of these prints the arguments in a width 3 smaller - dist:=dist-3 - width:=width-3 - ans:= - for v in CDR u repeat - (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans - dist:=dist - WIDTH v - dist<0 => return nil - ans - --Relying that falling out of a loop gives nil - MEMQ(op,'(_+ _* )) => - --Each of these prints the first argument in a width 3 smaller - (ans:=LargeMatrixp(CADR u,width-3,dist)) => largeMatrixAlist ans - n:=3+WIDTH CADR u - dist:=dist-n - ans:= - for v in CDDR u repeat - (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans - dist:=dist - WIDTH v - dist<0 => return nil - ans - --Relying that falling out of a loop gives nil - ans:= - for v in CDR u repeat - (ans:=LargeMatrixp(v,width,dist)) => return largeMatrixAlist ans - dist:=dist - WIDTH v - dist<0 => return nil - ans - --Relying that falling out of a loop gives nil - -largeMatrixAlist u == - u is [op,:r] => - op is ['MATRIX,:.] => deMatrix u - largeMatrixAlist op or largeMatrixAlist r - nil - -PushMatrix m == - --Adds the matrix to the look-aside list, and returns a name for it - name:= - for v in $MatrixList repeat - EQUAL(m,CDR v) => return CAR v - name => name - name:=INTERNL('"matrix",STRINGIMAGE($MatrixCount:=$MatrixCount+1)) - $MatrixList:=[[name,:m],:$MatrixList] - name - -quoteApp([.,a],x,y,d) == APP(a,x+1,y,appChar(PNAME "'",x,y,d)) - -quoteSub [.,a] == subspan a - -quoteSuper [.,a] == superspan a - -quoteWidth [.,a] == 1 + WIDTH a - -SubstWhileDesizing(u,m) == - -- arg. m is always nil (historical: EU directive to increase argument lists 1991/XGII) - --Replaces all occurrences of matrix m by name in u - --Taking out any outdated size information as it goes - ATOM u => u - [[op,:n],:l]:=u - --name := RASSOC(u,$MatrixList) => name - -- doesn't work since RASSOC seems to use an EQ test, and returns the - -- pair anyway. JHD 28/2/93 - op = 'MATRIX => - l':=SubstWhileDesizingList(CDR l,m) - u := - -- CDR l=l' => u - -- this was a CONS-saving optimisation, but it doesn't work JHD 28/2/93 - [op,nil,:l'] - PushMatrix u - l':=SubstWhileDesizingList(l,m) - -- [op,:l'] - ATOM op => [op,:l'] - [SubstWhileDesizing(op,m),:l'] - ---;SubstWhileDesizingList(u,m) == ---; -- m is always nil (historical) ---; u is [a,:b] => ---; a':=SubstWhileDesizing(a,m) ---; b':=SubstWhileDesizingList(b,m) ---;-- MCD & TTT think that this test is unnecessary and expensive ---;-- a=a' and b=b' => u ---; [a',:b'] ---; u - -SubstWhileDesizingList(u,m) == - u is [a,:b] => - res:= - ATOM a => [a] - [SubstWhileDesizing(a,m)] - tail:=res - for i in b repeat - if ATOM i then RPLACD(tail,[i]) else RPLACD(tail,[SubstWhileDesizing(i,m)]) - tail:=CDR tail - res - u - ---% Printing of Sigmas , Pis and Intsigns - -sigmaSub u == - --The depth function for sigmas with lower limit only - MAX(1 + height CADR u, subspan CADDR u) - -sigmaSup u == - --The height function for sigmas with lower limit only - MAX(1, superspan CADDR u) - -sigmaApp(u,x,y,d) == - u is [.,bot,arg] or THROW('outputFailure,'outputFailure) - bigopAppAux(bot,nil,arg,x,y,d,'sigma) - -sigma2App(u,x,y,d) == - [.,bot,top,arg]:=u - bigopAppAux(bot,top,arg,x,y,d,'sigma) - -bigopWidth(bot,top,arg,kind) == - kindWidth := (kind = 'pi => 5; 3) - MAX(kindWidth,WIDTH bot,(top => WIDTH top; 0)) + 2 + WIDTH arg - -half x ==> - QUOTIENT(x, 2) - -bigopAppAux(bot,top,arg,x,y,d,kind) == - botWidth := (bot => WIDTH bot; 0) - topWidth := WIDTH top - opWidth := - kind = 'pi => 5 - 3 - maxWidth := MAX(opWidth,botWidth,topWidth) - xCenter := half(maxWidth-1) + x - d:=APP(arg,x+2+maxWidth,y,d) - d:= - atom bot and SIZE atom2String bot = 1 => APP(bot,xCenter,y-2,d) - APP(bot,x + half(maxWidth - botWidth),y-2-superspan bot,d) - if top then - d:= - atom top and SIZE atom2String top = 1 => APP(top,xCenter,y+2,d) - APP(top,x + half(maxWidth - topWidth),y+2+subspan top,d) - delta := (kind = 'pi => 2; 1) - opCode := - kind = 'sigma => - [['(0 . 0),:'">"],_ - ['(0 . 1),:specialChar('hbar)],_ - ['(0 . -1),:specialChar('hbar)],_ - ['(1 . 1),:specialChar('hbar)],_ - ['(1 . -1),:specialChar('hbar)],_ - ['(2 . 1),:specialChar('urc )],_ - ['(2 . -1),:specialChar('lrc )]] - kind = 'pi => - [['(0 . 1),:specialChar('ulc )],_ - ['(1 . 0),:specialChar('vbar)],_ - ['(1 . 1),:specialChar('ttee)],_ - ['(1 . -1),:specialChar('vbar)],_ - ['(2 . 1),:specialChar('hbar)],_ - ['(3 . 0),:specialChar('vbar)],_ - ['(3 . 1),:specialChar('ttee)],_ - ['(3 . -1),:specialChar('vbar)],_ - ['(4 . 1),:specialChar('urc )]] - THROW('outputFailure,'outputFailure) - xLate(opCode,xCenter - delta,y,d) - -sigmaWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'sigma) -sigma2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'sigma) - -sigma2Sub u == - --The depth function for sigmas with 2 limits - MAX(1 + height CADR u, subspan CADDDR u) - -sigma2Sup u == - --The depth function for sigmas with 2 limits - MAX(1 + height CADDR u, superspan CADDDR u) - -piSub u == - --The depth function for pi's (products) - MAX(1 + height CADR u, subspan CADDR u) - -piSup u == - --The height function for pi's (products) - MAX(1, superspan CADDR u) - -piApp(u,x,y,d) == - u is [.,bot,arg] or THROW('outputFailure,'outputFailure) - bigopAppAux(bot,nil,arg,x,y,d,'pi) - -piWidth [.,bot,arg] == bigopWidth(bot,nil,arg,'pi) -pi2Width [.,bot,top,arg] == bigopWidth(bot,top,arg,'pi) - -pi2Sub u == - --The depth function for pi's with 2 limits - MAX(1 + height CADR u, subspan CADDDR u) - -pi2Sup u == - --The depth function for pi's with 2 limits - MAX(1 + height CADDR u, superspan CADDDR u) - -pi2App(u,x,y,d) == - [.,bot,top,arg]:=u - bigopAppAux(bot,top,arg,x,y,d,'pi) - -overlabelSuper [.,a,b] == 1 + height a + superspan b - -overlabelWidth [.,a,b] == WIDTH b - -overlabelApp([.,a,b], x, y, d) == - underApp:= APP(b,x,y,d) - endPoint := x + WIDTH b - 1 - middle := QUOTIENT(x + endPoint,2) - h := y + superspan b + 1 - d := APP(a,middle,h + 1,d) - apphor(x,x+WIDTH b-1,y+superspan b+1,d,"|") - -overbarSuper u == 1 + superspan u.1 - -overbarWidth u == WIDTH u.1 - -overbarApp(u,x,y,d) == - underApp:= APP(u.1,x,y,d) - apphor(x,x+WIDTH u.1-1,y+superspan u.1+1,d,UNDERBAR) - -indefIntegralSub u == - -- form is INDEFINTEGRAL(expr,dx) - MAX(1,subspan u.1,subspan u.2) - -indefIntegralSup u == - -- form is INDEFINTEGRAL(expr,dx) - MAX(1,superspan u.1,superspan u.2) - -indefIntegralApp(u,x,y,d) == - -- form is INDEFINTEGRAL(expr,dx) - [.,expr,dx]:=u - d := APP(expr,x+4,y,d) - d := APP(dx,x+5+WIDTH expr,y,d) - xLate( [['(0 . -1),:specialChar('llc) ],_ - ['(1 . -1),:specialChar('lrc) ],_ - ['(1 . 0),:specialChar('vbar)],_ - ['(1 . 1),:specialChar('ulc) ],_ - ['(2 . 1),:specialChar('urc) ]], x,y,d) - -indefIntegralWidth u == - -- form is INDEFINTEGRAL(expr,dx) - # u ^= 3 => THROW('outputFailure,'outputFailure) - 5 + WIDTH u.1 + WIDTH u.2 - -intSub u == - MAX(1 + height u.1, subspan u.3) - -intSup u == - MAX(1 + height u.2, superspan u.3) - -intApp(u,x,y,d) == - [.,bot,top,arg]:=u - d:=APP(arg,x+4+MAX(-4 + WIDTH bot, WIDTH top),y,d) - d:=APP(bot,x,y-2-superspan bot,d) - d:=APP(top,x+3,y+2+subspan top,d) - xLate( [['(0 . -1),:specialChar('llc) ],_ - ['(1 . -1),:specialChar('lrc) ],_ - ['(1 . 0),:specialChar('vbar)],_ - ['(1 . 1),:specialChar('ulc) ],_ - ['(2 . 1),:specialChar('urc) ]], x,y,d) - -intWidth u == - # u < 4 => THROW('outputFailure,'outputFailure) - MAX(-4 + WIDTH u.1, WIDTH u.2) + WIDTH u.3 + 5 - -xLate(l,x,y,d) == - for [[a,:b],:c] in l repeat - d:= appChar(c,x+a,y+b,d) - d - -concatTrouble(u,d,start,lineLength,$addBlankIfTrue) == - [x,:l] := splitConcat(u,lineLength,true) - null l => - sayALGEBRA ['%l,'%b,'" Too wide to Print",'%d] - THROW('output,nil) - charybdis(fixUp x,start,lineLength) - for y in l repeat - if d then prnd(start,d) - if lineLength > 2 then - charybdis(fixUp y,start+2,lineLength-2) -- JHD needs this to avoid lunacy - else charybdis(fixUp y,start,1) -- JHD needs this to avoid lunacy - BLANK - where - fixUp x == - rest x => - $addBlankIfTrue => ['CONCATB,:x] - ["CONCAT",:x] - first x - -splitConcat(list,maxWidth,firstTimeIfTrue) == - null list => nil - -- split list l into a list of n lists, each of which - -- has width < maxWidth - totalWidth:= 0 - oneOrZero := ($addBlankIfTrue => 1; 0) - l := list - maxW:= (firstTimeIfTrue => maxWidth; maxWidth-2) - maxW < 1 => [[x] for x in l] -- JHD 22.8.95, otherwise things can break - for x in tails l - while (width := oneOrZero + WIDTH first x + totalWidth) < maxW repeat - l:= x - totalWidth:= width - x:= rest l - RPLAC(rest l,nil) - [list,:splitConcat(x,maxWidth,nil)] - -spadPrint(x,m) == - m = $NoValueMode => x - if ^$collectOutput then TERPRI $algebraOutputStream - output(x,m) - if ^$collectOutput then TERPRI $algebraOutputStream - -formulaFormat expr == - sff := '(ScriptFormulaFormat) - formatFn := getFunctionFromDomain("coerce",sff,[$OutputForm]) - displayFn := getFunctionFromDomain("display",sff,[sff]) - SPADCALL(SPADCALL(expr,formatFn),displayFn) - if ^$collectOutput then - TERPRI $algebraOutputStream - FORCE_-OUTPUT $formulaOutputStream - NIL - -texFormat expr == - tf := '(TexFormat) - formatFn := - getFunctionFromDomain("convert",tf,[$OutputForm,$Integer]) - displayFn := getFunctionFromDomain("display",tf,[tf]) - SPADCALL(SPADCALL(expr,$IOindex,formatFn),displayFn) - TERPRI $texOutputStream - FORCE_-OUTPUT $texOutputStream - NIL - -texFormat1 expr == - tf := '(TexFormat) - formatFn := getFunctionFromDomain("coerce",tf, [$OutputForm]) - displayFn := getFunctionFromDomain("display",tf,[tf]) - SPADCALL(SPADCALL(expr,formatFn),displayFn) - TERPRI $texOutputStream - FORCE_-OUTPUT $texOutputStream - NIL - -output(expr,domain) == - if isWrapped expr then expr := unwrap expr - isMapExpr expr => - if $formulaFormat then formulaFormat expr - if $texFormat then texFormat expr - if $algebraFormat then mathprintWithNumber expr - categoryForm? domain or domain in '((Mode) (Domain) (SubDomain (Domain))) => - if $algebraFormat then - mathprintWithNumber outputDomainConstructor expr - if $texFormat then - texFormat outputDomainConstructor expr - T := coerceInteractive(objNewWrap(expr,domain),$OutputForm) => - x := objValUnwrap T - if $formulaFormat then formulaFormat x - if $fortranFormat then - dispfortexp x - if ^$collectOutput then TERPRI $fortranOutputStream - FORCE_-OUTPUT $fortranOutputStream - if $algebraFormat then - mathprintWithNumber x - if $texFormat then texFormat x - (FUNCTIONP(opOf domain)) and - (printfun := compiledLookup("<<",'(TextWriter TextWriter $), evalDomain domain)) - and (textwrit := compiledLookup("print", '($), TextWriter())) => - sayMSGNT [:bright '"AXIOM-XL",'"output: "] - SPADCALL(SPADCALL textwrit, expr, printfun) - sayMSGNT '%l - - -- big hack for tuples for new compiler - domain is ['Tuple, S] => output(asTupleAsList expr, ['List, S]) - - sayALGEBRA [:bright '"LISP",'"output:",'%l,expr or '"NIL"] - -outputNumber(start,linelength,num) == - if start > 1 then blnks := fillerSpaces(start-1,'" ") - else blnks := '"" - under:='"__" - firsttime:=(linelength>3) - if linelength>2 then - linelength:=linelength-1 - while SIZE(num) > linelength repeat - if $collectOutput then - $outputLines := [CONCAT(blnks, SUBSTRING(num,0,linelength),under), - :$outputLines] - else - sayALGEBRA [blnks, - SUBSTRING(num,0,linelength),under] - num := SUBSTRING(num,linelength,NIL) - if firsttime then - blnks:=CONCAT(blnks,'" ") - linelength:=linelength-1 - firsttime:=NIL - if $collectOutput then - $outputLines := [CONCAT(blnks, num), :$outputLines] - else - sayALGEBRA [blnks, num] - -outputString(start,linelength,str) == - if start > 1 then blnks := fillerSpaces(start-1,'" ") - else blnks := '"" - while SIZE(str) > linelength repeat - if $collectOutput then - $outputLines := [CONCAT(blnks, SUBSTRING(str,0,linelength)), - :$outputLines] - else - sayALGEBRA [blnks, SUBSTRING(str,0,linelength)] - str := SUBSTRING(str,linelength,NIL) - if $collectOutput then - $outputLines := [CONCAT(blnks, str), :$outputLines] - else - sayALGEBRA [blnks, str] - -outputDomainConstructor form == - if VECTORP form then form := devaluate form - atom (u:= prefix2String form) => u - v:= [object2String(x) for x in u] - return INTERNL eval ['STRCONC,:v] - -getOutputAbbreviatedForm form == - form is [op,:argl] => - op in '(Union Record) => outputDomainConstructor form - op is "Mapping" => formatMapping argl - u:= constructor? op or op - null argl => u - ml:= getPartialConstructorModemapSig(op) - argl:= [fn for x in argl for m in ml] where fn() == - categoryForm?(m) => outputDomainConstructor x - x' := coerceInteractive(objNewWrap(x,m),$OutputForm) - x' => objValUnwrap x' - '"unprintableObject" - [u,:argl] - form - -outputOp x == - x is [op,:args] and (GETL(op,"LED") or GETL(op,"NUD")) => - n:= - GETL(op,"NARY") => 2 - #args - newop:= INTERN STRCONC("*",STRINGIMAGE n,PNAME op) - [newop,:[outputOp y for y in args]] - x - ---% MAP PRINTER (FROM EV BOOT) - -printMap u == - printBasic specialChar 'lbrk - initialFlag:= isInitialMap u - if u is [x,:l] then - printMap1(x,initialFlag and x is [[n],:.] and n=1) - for y in l repeat (printBasic " , "; printMap1(y,initialFlag)) - printBasic specialChar 'rbrk - if ^$collectOutput then TERPRI $algebraOutputStream - -isInitialMap u == - u is [[[n],.],:l] and INTEGERP n and - (and/[x is [[ =i],.] for x in l for i in n+1..]) - -printMap1(x,initialFlag) == - initialFlag => printBasic CADR x - if CDAR x then printBasic first x else printBasic CAAR x - printBasic " E " - printBasic CADR x - -printBasic x == - x='(One) => PRIN1(1,$algebraOutputStream) - x='(Zero) => PRIN1(0,$algebraOutputStream) - IDENTP x => PRINTEXP(PNAME x,$algebraOutputStream) - atom x => PRIN1(x,$algebraOutputStream) - PRIN0(x,$algebraOutputStream) - -charybdis(u,start,linelength) == - EQ(keyp u,'EQUATNUM) and ^(CDDR u) => - charybdis(['PAREN,u.1],start,linelength) - charyTop(u,start,linelength) - -charyTop(u,start,linelength) == - u is ['SC,:l] or u is [['SC,:.],:l] => - for a in l repeat charyTop(a,start,linelength) - '" " - u is [['CONCATB,:.],:m,[['SC,:.],:l]] => - charyTop(['CONCATB,:m],start,linelength) - charyTop(['SC,:l],start+2,linelength-2) - u is ['CENTER,a] => - b := charyTopWidth a - (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength) - charyTop(b,half(linelength-start-w),linelength) - v := charyTopWidth u - EQ(keyp u,'ELSE) => charyElse(u,v,start,linelength) - WIDTH(v) > linelength => charyTrouble(u,v,start,linelength) - d := APP(v,start,0,nil) - n := superspan v - m := - subspan v ---> - $testOutputLineFlag => - $testOutputLineList := - [:ASSOCRIGHT SORTBY('CAR,d),:$testOutputLineList] - until n < m repeat - scylla(n,d) - n := n - 1 - '" " - -charyTopWidth u == - atom u => u - atom first u => putWidth u - NUMBERP CDAR u => u - putWidth u - -charyTrouble(u,v,start,linelength) == - al:= LargeMatrixp(u,linelength,2*linelength) => - --$MatrixList => - --[[m,:m1]] := al - --maPrin sublisMatAlist(m,m1,u) - --above three lines commented out JHD 25/2/93 since don't work - --u := SubstWhileDesizing(u,first first al) - u := SubstWhileDesizing(u,nil) - maprinChk u - charyTrouble1(u,v,start,linelength) - -sublisMatAlist(m,m1,u) == - u is [op,:r] => - op is ['MATRIX,:.] and u=m => m1 - op1 := sublisMatAlist(m,m1,op) - r1 := [sublisMatAlist(m,m1,s) for s in r] - op = op1 and r1 = r => u - [op1,:r1] - u - -charyTrouble1(u,v,start,linelength) == - NUMBERP u => outputNumber(start,linelength,atom2String u) - atom u => outputString(start,linelength,atom2String u) - EQ(x:= keyp u,'_-) => charyMinus(u,v,start,linelength) - MEMQ(x,'(_+ _* AGGLST)) => charySplit(u,v,start,linelength) - EQ(x,'EQUATNUM) => charyEquatnum(u,v,start,linelength) - d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) - x = 'OVER => - charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) - EQ(3,LENGTH u) and GET(x,'Led) => - d:= PNAME first GET(x,'Led) - charyBinary(d,u,v,start,linelength) - EQ(x,'CONCAT) => - concatTrouble(rest v,d,start,linelength,nil) - EQ(x,'CONCATB) => - (rest v) is [loop, 'repeat, body] => - charyTop(['CONCATB,loop,'repeat],start,linelength) - charyTop(body,start+2,linelength-2) - (rest v) is [wu, loop, 'repeat, body] and - (keyp wu) is ['CONCATB,wu',.] and wu' in '(while until) => - charyTop(['CONCATB,wu,loop,'repeat],start,linelength) - charyTop(body,start+2,linelength-2) - concatTrouble(rest v,d,start,linelength,true) - GETL(x,'INFIXOP) => charySplit(u,v,start,linelength) - EQ(x,'PAREN) and - (EQ(keyp u.1,'AGGLST) and (v:= ",") or EQ(keyp u.1,'AGGSET) and - (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)") - EQ(x,'PAREN) and EQ(keyp u.1,'CONCATB) => - bracketagglist(rest u.1,start,linelength," ","_(","_)") - EQ(x,'BRACKET) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => - bracketagglist(rest u.1,start,linelength,v, - specialChar 'lbrk, specialChar 'rbrk) - EQ(x,'BRACE) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => - bracketagglist(rest u.1,start,linelength,v, - specialChar 'lbrc, specialChar 'rbrc) - EQ(x,'EXT) => longext(u,start,linelength) - EQ(x,'MATRIX) => MATUNWND() - EQ(x,'ELSE) => charyElse(u,v,start,linelength) - EQ(x,'SC) => charySemiColon(u,v,start,linelength) - charybdis(x,start,linelength) - if rest u then charybdis(['ELSE,:rest u],start,linelength) - -- changed from charybdis(...) by JHD 2 Aug 89, since rest u might be null - '" " - -charySemiColon(u,v,start,linelength) == - for a in rest u repeat - charyTop(a,start,linelength) - nil - -charyMinus(u,v,start,linelength) == - charybdis('"-",start,linelength) - charybdis(v.1,start+3,linelength-3) - '" " - -charyBinary(d,u,v,start,linelength) == - d in '(" := " "= ") => - charybdis(['CONCATB,v.1,d],start,linelength) - charybdis(v.2,start+2,linelength-2) - '" " - charybdis(v.1,start+2,linelength-2) - if d then prnd(start,d) - charybdis(v.2,start+2,linelength-2) - '" " - -charyEquatnum(u,v,start,linelength) == - charybdis(['PAREN,u.1],start,linelength) - charybdis(u.2,start,linelength) - '" " - -charySplit(u,v,start,linelength) == - v:= [first v.0,:rest v] - m:= rest v - WIDTH v.1 > linelength-2 => - charybdis(v.1,start+2,linelength-2) - ^(CDDR v) => '" " - dm:= CDDR v - ddm:= rest dm - split2(u,dm,ddm,start,linelength) - for i in 0.. repeat - dm := rest m - ddm := rest dm - RPLACD(dm,nil) - WIDTH v > linelength - 2 => return nil - RPLAC(first v, first v.0) - RPLACD(dm,ddm) - m := rest m - RPLAC(first v,first v.0) - RPLACD(m,nil) - charybdis(v,start + 2,linelength - 2) - split2(u,dm,ddm,start,linelength) - -split2(u,dm,ddm,start,linelength) == ---prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; opSrch(keyp u,OPLIST))) - prnd(start,(d:= GETL(keyp u,'INFIXOP) => d; '",")) - RPLACD(dm,ddm) - m:= WIDTH [keyp u,:dm] start+2; start),(m => linelength-2; linelength)) - '" " - -charyElse(u,v,start,linelength) == - charybdis(v.1,start+3,linelength-3) - ^(CDDR u) => '" " - prnd(start,'",") - charybdis(['ELSE,:CDDR v],start,linelength) - '" " - -scylla(n,v) == - y := LASSOC(n,v) - null y => nil - if STRINGP(y) then y := DROPTRAILINGBLANKS COPY y - if $collectOutput then - $outputLines := [y, :$outputLines] - else - PRINTEXP(y,$algebraOutputStream) - TERPRI $algebraOutputStream - nil - -keyp(u) == - atom u => nil - atom first u => first u - CAAR u - -absym x == - (NUMBERP x) and (MINUSP x) => -x - ^(atom x) and (keyp(x) = '_-) => CADR x - x - -agg(n,u) == - (n = 1) => CADR u - agg(n - 1, rest u) - -aggwidth u == - null u => 0 - null rest u => WIDTH first u - 1 + (WIDTH first u) + (aggwidth rest u) - -argsapp(u,x,y,d) == appargs(rest u,x,y,d) - -subspan u == - atom u => 0 - NUMBERP rest u => subspan first u - (not atom first u and_ - atom CAAR u and_ - not NUMBERP CAAR u and_ - GETL(CAAR u, 'SUBSPAN) ) => - APPLX(GETL(CAAR u, 'SUBSPAN), LIST u) - MAX(subspan first u, subspan rest u) - -agggsub u == subspan rest u - -superspan u == - atom u => 0 - NUMBERP rest u => superspan first u - (not atom first u and_ - atom CAAR u and_ - not NUMBERP CAAR u and_ - GETL(CAAR u, 'SUPERSPAN) ) => - APPLX(GETL(CAAR u, 'SUPERSPAN), LIST u) - MAX(superspan first u, superspan rest u) - -agggsuper u == superspan rest u - -agggwidth u == aggwidth rest u - -appagg(u,x,y,d) == appagg1(u,x,y,d,'",") - -appagg1(u,x,y,d,s) == - null u => d - null rest u => APP(first u,x,y,d) - temp := x + WIDTH first u - temparg1 := APP(first u,x,y,d) - temparg2 := APP(s,temp,y,temparg1) - appagg1(rest u, 1 + temp, y, temparg2,s) - ---Note the similarity between the definition below of appargs and above ---of appagg. (why?) - -appargs(u,x,y,d) == appargs1(u,x,y,d,'";") - ---Note that the definition of appargs1 below is identical to that of ---appagg1 above except that the former calls appargs and the latter ---calls appagg. - -appargs1(u,x,y,d,s) == - null u => d - null rest u => APP(first u,x,y,d) - temp := x + WIDTH first u - temparg1 := APP(first u,x,y,d) - temparg2 := APP(s,temp,y,temparg1) - true => appargs(rest u, 1 + temp, y, temparg2) - -apprpar(x, y, y1, y2, d) == - (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('")", x, y, d) - true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) - -apprpar1(x, y, y1, y2, d) == - (y1 = y2) => APP('")", x, y2, d) - true => APP('")", x, y2, apprpar1(x, y, y1, y2 - 1, d)) - -applpar(x, y, y1, y2, d) == - (^(_*TALLPAR) or (y2 - y1 < 2)) => APP('"(", x, y, d) - true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) - -applpar1(x, y, y1, y2, d) == - (y1 = y2) => APP('"(", x, y2, d) - true => APP('"(", x, y2, applpar1(x, y, y1, y2 - 1, d)) - ---The body of the function appelse assigns 6 local variables. ---It then finishes by calling apprpar. - -appelse(u,x,y,d) == - w := WIDTH CAAR u - b := y - subspan rest u - p := y + superspan rest u - temparg1 := APP(keyp u, x, y, d) - temparg2 := applpar(x + w, y, b, p, temparg1) - temparg3 := appagg(rest u, x + 1 + w, y, temparg2) - apprpar(x + 1 + w + aggwidth rest u, y, b, p, temparg3) - -appext(u,x,y,d) == - xptr := x - yptr := y - (subspan CADR u + superspan agg(3,u) + 1) - d := APP(CADR u,x,y,d) - d := APP(agg(2,u),xptr,yptr,d) - xptr := xptr + WIDTH agg(2,u) - d := APP('"=", xptr, yptr,d) - d := APP(agg(3,u), 1 + xptr, yptr, d) - yptr := y + 1 + superspan CADR u + SUBSPAD agg(4,u) - d := APP(agg(4,u), x, yptr, d) - temp := 1 + WIDTH agg(2,u) + WIDTH agg(3,u) - n := MAX(WIDTH CADR u, WIDTH agg(4,u), temp) - if EQCAR(first(z := agg(5,u)), 'EXT) and - (EQ(n,3) or (n > 3 and ^(atom z)) ) then - n := 1 + n - d := APP(z, x + n, y, d) - -apphor(x1,x2,y,d,char) == - temp := (x1 = x2 => d; apphor(x1, x2 - 1, y, d,char)) - APP(char, x2, y, temp) - -syminusp x == - NUMBERP x => MINUSP x - ^(atom x) and EQ(keyp x,'_-) - -appsum(u, x, y, d) == - null u => d - ac := absym first u - sc := - syminusp first u => '"-" - true => '"+" - dp := member(keyp absym first u, '(_+ _-)) - tempx := x + WIDTH ac + (dp => 5; true => 3) - tempdblock := - temparg1 := APP(sc, x + 1, y, d) - dp => - bot := y - subspan ac - top := y + superspan ac - temparg2 := applpar(x + 3, y, bot, top, temparg1) - temparg3 := APP(ac, x + 4, y, temparg2) - apprpar(x + 4 + WIDTH ac, y, bot, top, temparg3) - true => APP(ac, x + 3, y, temparg1) - appsum(rest u, tempx, y, tempdblock) - -appneg(u, x, y, d) == - appsum(LIST u, x - 1, y, d) - -appparu(u, x, y, d) == - bot := y - subspan u - top := y + superspan u - temparg1 := applpar(x, y, bot, top, d) - temparg2 := APP(u, x + 1, y, temparg1) - apprpar(x + 1 + WIDTH u, y, bot, top, temparg2) - -appparu1(u, x, y, d) == - appparu(CADR u, x, y, d) - -appsc(u, x, y, d) == - appagg1(rest u, x, y, d, '";") - -appsetq(u, x, y, d) == - w := WIDTH first u - temparg1 := APP(CADR u, x, y, d) - temparg2 := APP('":", x + w, y, temparg1) - APP(CADR rest u, x + 2 + w, y, temparg2) - -appsub(u, x, y, d) == - temparg1 := x + WIDTH CADR u - temparg2 := y - 1 - superspan CDDR u - temparg3 := APP(CADR u, x, y, d) - appagg(CDDR u, temparg1, temparg2, temparg3) - -starstarcond(l, iforwhen) == - null l => l - EQ((a := CAAR l), 1) => - LIST('CONCAT, CADR first l, '" OTHERWISE") - EQCAR(a, 'COMPARG) => - starstarcond(CONS(transcomparg(CADR a), rest l), iforwhen) - null rest l => - LIST('CONCAT, CADR first l, - LIST('CONCAT, iforwhen, CAAR l)) - true => LIST('VCONCAT, - starstarcond(CONS(first l, nil), iforwhen), - LIST('VCONCAT, '" ", - starstarcond(rest l, iforwhen))) - -eq0(u) == 0 - -height(u) == - superspan(u) + 1 + subspan(u) - -extsub(u) == - MAX(subspan agg(5, u), height(agg(3, u)), subspan CADR u ) - -extsuper(u) == - MAX(superspan CADR u + height agg(4, u), superspan agg(5, u) ) - -extwidth(u) == - n := MAX(WIDTH CADR u, - WIDTH agg(4, u), - 1 + WIDTH agg(2, u) + WIDTH agg(3, u) ) - nil or - (EQCAR(first(z := agg(5, u)), 'EXT) and _ - (EQ(n, 3) or ((n > 3) and null atom z) ) => - n := 1 + n) - true => n + WIDTH agg(5, u) - -appfrac(u, x, y, d) == - -- Added "1+" to both QUOTIENT statements so that when exact centering is - -- not possible, expressions are offset to the right rather than left. - -- MCD 16-8-95 - w := WIDTH u - tempx := x + QUOTIENT(1+w - WIDTH CADR rest u, 2) - tempy := y - superspan CADR rest u - 1 - temparg3 := APP(CADR rest u, tempx, tempy, d) - temparg4 := apphor(x, x + w - 1, y, temparg3,specialChar('hbar)) - APP(CADR u, - x + QUOTIENT(1+w - WIDTH CADR u, 2), - y + 1 + subspan CADR u, - temparg4) - -fracsub(u) == height CADR rest u - -fracsuper(u) == height CADR u - -fracwidth(u) == - numw := WIDTH (num := CADR u) - denw := WIDTH (den := CADDR u) - if num is [[op,:.],:.] and op = 'OVER then numw := numw + 2 - if den is [[op,:.],:.] and op = 'OVER then denw := denw + 2 - MAX(numw,denw) - -slashSub u == - MAX(1,subspan(CADR u),subspan(CADR rest u)) - -slashSuper u == - MAX(1,superspan(CADR u),superspan(CADR rest u)) - -slashApp(u, x, y, d) == - -- to print things as a/b as opposed to - -- a - -- - - -- b - temparg1 := APP(CADR u, x, y, d) - temparg2 := APP('"/", x + WIDTH CADR u, y, temparg1) - APP(CADR rest u, - x + 1 + WIDTH CADR u, y, temparg2) - -slashWidth(u) == - -- to print things as a/b as opposed to - -- a - -- - - -- b - 1 + WIDTH CADR u + WIDTH CADR rest u - -longext(u, i, n) == - x := REVERSE u - y := first x - u := remWidth(REVERSEWOC(CONS('" ", rest x))) - charybdis(u, i, n) - if ^$collectOutput then TERPRI $algebraOutputStream - charybdis(CONS('ELSE, LIST y), i, n) - '" " - -appvertline(char, x, yl, yu, d) == - yu < yl => d - temparg := appvertline(char, x, yl, yu - 1, d) - true => APP(char, x, yu, temparg) - -appHorizLine(xl, xu, y, d) == - xu < xl => d - temparg := appHorizLine(xl, xu - 1, y, d) - true => APP(MATBORCH, xu, y, temparg) - -rootApp(u, x, y, d) == - widB := WIDTH u.1 - supB := superspan u.1 - subB := subspan u.1 - if #u > 2 then - widR := WIDTH u.2 - subR := subspan u.2 - d := APP(u.2, x, y - subB + 1 + subR, d) - else - widR := 1 - d := APP(u.1, x + widR + 1, y, d) - d := apphor(x+widR+1, x+widR+widB, y+supB+1, d, specialChar('hbar)) - d := appvertline(specialChar('vbar), x+widR, y - subB, y + supB, d) - d := APP(specialChar('ulc), x+widR, y + supB+1, d) - d := APP(specialChar('urc), x + widR + widB + 1, y + supB+1, d) - d := APP(specialChar('bslash), x + widR - 1, y - subB, d) - -boxApp(u, x, y, d) == - CDDR u => boxLApp(u, x, y, d) - a := 1 + superspan u.1 - b := 1 + subspan u.1 - w := 2 + WIDTH u.1 - d := appvertline(specialChar('vbar), x,y - b + 1, y + a - 1, d) - d := appvertline(specialChar('vbar), x + w + 1, y - b,y + a,d) - d := apphor(x + 1, x + w, y - b, d, specialChar('hbar)) - d := apphor(x + 1, x + w, y + a, d, specialChar('hbar)) - d := APP(specialChar('ulc), x, y + a, d) - d := APP(specialChar('urc), x + w + 1, y + a, d) - d := APP(specialChar('llc), x, y - b, d) - d := APP(specialChar('lrc), x + w + 1, y - b, d) - d := APP(u.1, 2 + x, y, d) - -boxLApp(u, x, y, d) == - la := superspan u.2 - lb := subspan u.2 - lw := 2 + WIDTH u.2 - lh := 2 + la + lb - a := superspan u.1+1 - b := subspan u.1+1 - w := MAX(lw, 2 + WIDTH u.1) - -- next line used to have h instead of lh - top := y + a + lh - d := appvertline(MATBORCH, x, y - b, top, d) - d := appHorizLine(x + 1, x + w, top, d) - d := APP(u.2, 2 + x, y + a + lb + 1, d) - d := appHorizLine(x + 1, x + lw, y + a, d) - nil or - lw < w => d := appvertline(MATBORCH, x + lw + 1, y + a, top - 1, d) - d := APP(u.1, 2 + x, y, d) - d := appHorizLine(x + 1, x + w, y - b, top, d) - d := appvertline(MATBORCH, x + w + 1, y - b, top, d) - -boxSub(x) == - subspan x.1+1 - -boxSuper(x) == - null CDR x => 0 - hl := - null CDDR x => 0 - true => 2 + subspan x.2 + superspan x.2 - true => hl+1 + superspan x.1 - -boxWidth(x) == - null CDR x => 0 - wl := - null CDDR x => 0 - true => WIDTH x.2 - true => 4 + MAX(wl, WIDTH x.1) - -nothingWidth x == - 0 -nothingSuper x == - 0 -nothingSub x == - 0 -nothingApp(u, x, y, d) == - d - -zagApp(u, x, y, d) == - w := WIDTH u - denx := x + QUOTIENT(w - WIDTH CADR rest u, 2) - deny := y - superspan CADR rest u - 1 - d := APP(CADR rest u, denx, deny, d) - numx := x + QUOTIENT(w - WIDTH CADR u, 2) - numy := y+1 + subspan CADR u - d := APP(CADR u, numx, numy, d) - a := 1 + zagSuper u - b := 1 + zagSub u - d := appvertline(specialChar('vbar), x, y - b, y - 1, d) - d := appvertline(specialChar('vbar), x + w - 1, y + 1, y + a, d) - d := apphor(x, x + w - 2, y, d, specialChar('hbar)) - d := APP(specialChar('ulc), x, y, d) - d := APP(specialChar('lrc), x + w - 1, y, d) - -zagSub(u) == - height CADR rest u - -zagSuper(u) == - height CADR u - -zagWidth(x) == - #x = 1 => 0 - #x = 2 => 4 + WIDTH x.1 - 4 + MAX(WIDTH x.1, WIDTH x.2) - -rootWidth(x) == - #x <= 2 => 3 + WIDTH x.1 - 2 + WIDTH x.1 + WIDTH x.2 - -rootSub(x) == - subspan x.1 - -rootSuper(x) == - normal := 1 + superspan x.1 - #x <= 2 => normal - (radOver := height x.2 - height x.1) < 0 => normal - normal + radOver - -appmat(u, x, y, d) == - rows := CDDR u - p := matSuper u - q := matSub u - d := matrixBorder(x, y - q, y + p, d, 'left) - x := 1 + x - yc := 1 + y + p - w := CADR u - wl := CDAR w - subl := rest CADR w - superl := rest CADR rest w - repeat - null rows => return(matrixBorder(x + WIDTH u - 2, - y - q, - y + p, - d, - 'right)) - xc := x - yc := yc - 1 - first superl - w := wl - row := CDAR rows - repeat - if flag = '"ON" then - flag := '"OFF" - return(nil) - null row => - repeat - yc := yc - 1 - first subl - subl := rest subl - superl := rest superl - rows := rest rows - return(flag := '"ON"; nil) - d := APP(first row, - xc + QUOTIENT(first w - WIDTH first row, 2), - yc, - d) - xc := xc + 2 + first w - row := rest row - w := rest w - -matSuper(x) == - (x := x.1) => -1 + QUOTIENT(first x.1 + first x.2, 2) - true => ERROR('MAT) - -matSub(x) == - (x := x.1) => QUOTIENT(-1 + first x.1 + first x.2, 2) - true => ERROR('MAT) - -matWidth(x) == - y := CDDR x -- list of rows, each of form ((ROW . w) element element ...) - numOfColumns := LENGTH CDAR y - widthList := matLSum2 matWList(y, NLIST(numOfColumns, 0)) - --returns ["max width of entries in column i" for i in 1..numberOfRows] - subspanList := matLSum matSubList y - superspanList := matLSum matSuperList y - RPLAC(x.1,[widthList, subspanList, superspanList]) - CAAR x.1 - -matLSum(x) == - CONS(sumoverlist x + LENGTH x, x) - -matLSum2(x) == - CONS(sumoverlist x + 2*(LENGTH x), x) - -matWList(x, y) == - null x => y - true => matWList(rest x, matWList1(CDAR x, y) ) - -matWList1(x, y) == - null x => nil - true => CONS(MAX(WIDTH first x, first y), matWList1(rest x, rest y) ) - -matSubList(x) == --computes the max/[subspan(e) for e in "row named x"] - null x => nil - true => CONS(matSubList1(CDAR x, 0), matSubList(rest x) ) - -matSubList1(x, y) == - null x => y - true => matSubList1(rest x, MAX(y, subspan first x) ) - -matSuperList(x) == --computes the max/[superspan(e) for e in "row named x"] - null x => nil - true => CONS(matSuperList1(CDAR x, 0), matSuperList(rest x) ) - -matSuperList1(x, y) == - null x => y - true => matSuperList1(rest x, MAX(y, superspan first x) ) - -minusWidth(u) == - -1 + sumWidthA rest u - --- opSrch(name, x) == --- LASSOC(name, x) or '"," - -bracketagglist(u, start, linelength, tchr, open, close) == - u := CONS(LIST('CONCAT, open, first u), - [LIST('CONCAT, '" ", y) for y in rest u] ) - repeat - s := 0 - for x in tails u repeat - lastx := x - ((s := s + WIDTH first x + 1) >= linelength) => return(s) - null rest x => return(s := -1) - nil or - EQ(s, -1) => (nextu := nil) - EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) ) - true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil)) - for x in tails u repeat - RPLACA(x, LIST('CONCAT, first x, tchr)) - if null nextu then RPLACA(CDDR LAST u, close) - x := ASSOCIATER('CONCAT, CONS(ichr, u)) - charybdis(ASSOCIATER('CONCAT, u), start, linelength) - if $collectOutput then TERPRI $algebraOutputStream - ichr := '" " - u := nextu - null u => return(nil) - -prnd(start, op) == ---> - $testOutputLineFlag => - string := STRCONC(fillerSpaces MAX(0,start - 1),op) - $testOutputLineList := [string,:$testOutputLineList] - PRINTEXP(fillerSpaces MAX(0,start - 1),$algebraOutputStream) - $collectOutput => - string := STRCONC(fillerSpaces MAX(0,start - 1),op) - $outputLines := [string, :$outputLines] - PRINTEXP(op,$algebraOutputStream) - TERPRI $algebraOutputStream - -qTSub(u) == - subspan CADR u - -qTSuper(u) == - superspan CADR u - -qTWidth(u) == - 2 + WIDTH CADR u - -remWidth(x) == - atom x => x - true => CONS( (atom first x => first x; true => CAAR x), - MMAPCAR(remWidth, rest x) ) - -subSub(u) == - height CDDR u - -subSuper u == - superspan u.1 - -letWidth u == - 5 + WIDTH u.1 + WIDTH u.2 - -sumoverlist(u) == +/[x for x in u] - -sumWidth u == - WIDTH u.1 + sumWidthA CDDR u - -sumWidthA u == - ^u => 0 - ( member(keyp absym first u,'(_+ _-)) => 5; true => 3) + - WIDTH absym first u + - sumWidthA rest u - -superSubApp(u, x, y, di) == - a := first (u := rest u) - b := first (u := rest u) - c := first (u := KDR u) or '((NOTHING . 0)) - d := KAR (u := KDR u) or '((NOTHING . 0)) - e := KADR u or '((NOTHING . 0)) - aox := MAX(wd := WIDTH d, we := WIDTH e) - ar := superspan a - ab := subspan a - aw := WIDTH a - di := APP(d, x + (aox - wd), 1 + ar + y + subspan d, di) - di := APP(a, x + aox, y, di) - di := APP(c, aox + aw + x, 1 + y + ar + subspan c, di) - di := APP(e, x + (aox - we), y - 1 - MAX(superspan e, ab), di) - di := APP(b, aox + aw + x, y - 1 - MAX(ab, superspan b), di) - return di - -stringer x == - STRINGP x => x - EQ('_|, FETCHCHAR(s:= STRINGIMAGE x, 0)) => - RPLACSTR(s, 0, 1, "", nil, nil) - s - -superSubSub u == - a:= first (u:= rest u) - b:= KAR (u := KDR u) - e:= KAR KDR KDR KDR u - return subspan a + MAX(height b, height e) - -binomApp(u,x,y,d) == - [num,den] := rest u - ysub := y - 1 - superspan den - ysup := y + 1 + subspan num - wden := WIDTH den - wnum := WIDTH num - w := MAX(wden,wnum) - d := APP(den,x+1+ half(w - wden),ysub,d) - d := APP(num,x+1+ half(w - wnum),ysup,d) - hnum := height num - hden := height den - w := 1 + w - for j in 0..(hnum - 1) repeat - d := appChar(specialChar 'vbar,x,y + j,d) - d := appChar(specialChar 'vbar,x + w,y + j,d) - for j in 1..(hden - 1) repeat - d := appChar(specialChar 'vbar,x,y - j,d) - d := appChar(specialChar 'vbar,x + w,y - j,d) - d := appChar(specialChar 'ulc,x,y + hnum,d) - d := appChar(specialChar 'urc,x + w,y + hnum,d) - d := appChar(specialChar 'llc,x,y - hden,d) - d := appChar(specialChar 'lrc,x + w,y - hden,d) - -binomSub u == height CADDR u -binomSuper u == height CADR u -binomWidth u == 2 + MAX(WIDTH CADR u, WIDTH CADDR u) - -altSuperSubApp(u, x, y, di) == - a := first (u := rest u) - ar := superspan a - ab := subspan a - aw := WIDTH a - di := APP(a, x, y, di) - x := x + aw - - sublist := everyNth(u := rest u, 2) - suplist := everyNth(IFCDR u, 2) - - ysub := y - 1 - APPLY('MAX, [ab, :[superspan s for s in sublist]]) - ysup := y + 1 + APPLY('MAX, [ar, :[subspan s for s in sublist]]) - for sub in sublist for sup in suplist repeat - wsub := WIDTH sub - wsup := WIDTH sup - di := APP(sub, x, ysub, di) - di := APP(sup, x, ysup, di) - x := x + 1 + MAX(wsub, wsup) - di - -everyNth(l, n) == - [(e := l.0; for i in 1..n while l repeat l := rest l; e) while l] - - -altSuperSubSub u == - span := subspan CADR u - sublist := everyNth(CDDR u, 2) - for sub in sublist repeat - h := height sub - if h > span then span := h - span - -altSuperSubSuper u == - span := superspan CADR u - suplist := everyNth(IFCDR CDDR u, 2) - for sup in suplist repeat - h := height sup - if h > span then span := h - span - -altSuperSubWidth u == - w := WIDTH CADR u - suplist := everyNth(IFCDR CDDR u, 2) - sublist := everyNth(CDDR u, 2) - for sup in suplist for sub in sublist repeat - wsup := WIDTH sup - wsub := WIDTH sub - w := w + 1 + MAX(wsup, wsub) - w - -superSubWidth u == - a := first (u := rest u) - b := first (u := rest u) - c := first (u := KDR u) or '((NOTHING . 0)) - d := KAR (u := KDR u) or '((NOTHING . 0)) - e := KADR u or '((NOTHING . 0)) - return MAX(WIDTH d, WIDTH e) + MAX(WIDTH b, WIDTH c) + WIDTH a - -superSubSuper u == - a:= first (u := rest u) - c:= KAR (u := KDR KDR u) - d:= KADR u - return superspan a + MAX(height c, height d) - -suScWidth u == - WIDTH u.1 + aggwidth CDDR u - -transcomparg(x) == - y := first x - args := first _*NTH(STANDARGLIST, 1 + LENGTH y) - repeat - if true then - null y => return(nil) - (atom first y) and member(first y, FRLIS_*) => - conds := CONS(LIST('EQUAL1, first args, first y), conds) - y := SUBST(first args, first y, y) - x := SUBST(first args, first y, x) - (first y = first args) => nil - true => conds := CONS(LIST('EQUAL1, first args, first y), conds) - y := rest y - args := rest args - conds := - null conds => rest CADR x - ANDSIMP(CONS('AND, APPEND(REVERSEWOC conds, - LIST(rest CADR x) ) ) ) - LIST((conds => conds; true => 1), CADR rest x) - -vconcatapp(u, x, y, d) == - w := vConcatWidth u - y := y + superspan u.1 + 1 - for a in rest u repeat - y := y - superspan a - 1 - xoff := QUOTIENT(w - WIDTH a, 2) - d := APP(a, x + xoff, y, d) - y := y - subspan a - d - -binomialApp(u, x, y, d) == - [.,b,a] := u - w := vConcatWidth u - d := APP('"(",x,y,d) - x := x + 1 - y1 := y - height a - xoff := QUOTIENT(w - WIDTH a, 2) - d := APP(a, x + xoff, y1, d) - y2 := y + height b - xoff := QUOTIENT(w - WIDTH b, 2) - d := APP(b, x + xoff, y2, d) - x := x + w - APP('")",x,y,d) - -vConcatSub u == - subspan u.1 + +/[height a for a in CDDR u] -vConcatSuper u == - superspan u.1 -vConcatWidth u == - w := 0 - for a in rest u repeat if (wa := WIDTH a) > w then w := wa - w -binomialSub u == height u.2 + 1 - -binomialSuper u == height u.1 + 1 - -binomialWidth u == 2 + MAX(WIDTH u.1, WIDTH u.2) - -mathPrint u == - if ^$collectOutput then TERPRI $algebraOutputStream - (u := STRINGP mathPrint1(mathPrintTran u, nil) => - PSTRING u; nil) - -mathPrintTran u == - atom u => u - true => - for x in tails u repeat - RPLAC(first x, mathPrintTran first x) - u - -mathPrint1(x,fg) == - if fg and ^$collectOutput then TERPRI $algebraOutputStream - maPrin x - if fg and ^$collectOutput then TERPRI $algebraOutputStream - -maPrin u == - null u => nil ---> - if $runTestFlag or $mkTestFlag then - $mkTestOutputStack := [COPY u, :$mkTestOutputStack] - $highlightDelta := 0 - c := CATCH('outputFailure,charybdis(u, $MARGIN, $LINELENGTH)) - c ^= 'outputFailure => c - sayKeyedMsg("S2IX0009",NIL) - u is ['EQUATNUM,num,form] or u is [['EQUATNUM,:.],num,form] => - charybdis(['EQUATNUM,num], $MARGIN, $LINELENGTH) - if ^$collectOutput then - TERPRI $algebraOutputStream - PRETTYPRINT(form,$algebraOutputStream) - form - if ^$collectOutput then PRETTYPRINT(u,$algebraOutputStream) - nil -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/interop.boot b/src/interp/interop.boot new file mode 100644 index 00000000..99543049 --- /dev/null +++ b/src/interp/interop.boot @@ -0,0 +1,607 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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) + +$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]) + +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) + +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 + +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 + +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 + +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)) + diff --git a/src/interp/interop.boot.pamphlet b/src/interp/interop.boot.pamphlet deleted file mode 100644 index 3e44127c..00000000 --- a/src/interp/interop.boot.pamphlet +++ /dev/null @@ -1,632 +0,0 @@ -\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) - -$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]) - -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) - -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 - -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 - -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 - -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)) - -@ - -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3