From abb39687b93318d9bbbc594a7907e4a6e8e5bc23 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 5 Nov 2007 02:03:38 +0000 Subject: remove more pamphlets --- src/interp/info.boot | 285 ++++++++++ src/interp/info.boot.pamphlet | 308 ----------- src/interp/iterator.boot | 298 ++++++++++ src/interp/iterator.boot.pamphlet | 322 ----------- src/interp/modemap.boot | 375 +++++++++++++ src/interp/modemap.boot.pamphlet | 399 -------------- src/interp/msgdb.boot | 1055 ++++++++++++++++++++++++++++++++++++ src/interp/msgdb.boot.pamphlet | 1079 ------------------------------------- 8 files changed, 2013 insertions(+), 2108 deletions(-) create mode 100644 src/interp/info.boot delete mode 100644 src/interp/info.boot.pamphlet create mode 100644 src/interp/iterator.boot delete mode 100644 src/interp/iterator.boot.pamphlet create mode 100644 src/interp/modemap.boot delete mode 100644 src/interp/modemap.boot.pamphlet create mode 100644 src/interp/msgdb.boot delete mode 100644 src/interp/msgdb.boot.pamphlet (limited to 'src') diff --git a/src/interp/info.boot b/src/interp/info.boot new file mode 100644 index 00000000..4506c676 --- /dev/null +++ b/src/interp/info.boot @@ -0,0 +1,285 @@ +-- 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. + + + +--% ADDINFORMATION CODE +--% This code adds various items to the special value of $Information, +--% in order to keep track of all the compiler's information about +--% various categories and similar objects +--% An actual piece of (unconditional) information can have one of 3 forms: +--% (ATTRIBUTE domainname attribute) +--% --These are only stored here +--% (SIGNATURE domainname operator signature) +--% --These are also stored as 'modemap' properties +--% (has domainname categoryexpression) +--% --These are also stored as 'value' properties +--% Conditional attributes are of the form +--% (COND +--% (condition info info ...) +--% ... ) +--% where the condition looks like a 'has' clause, or the 'and' of several +--% 'has' clauses: +--% (has name categoryexpression) +--% (has name (ATTRIBUTE attribute)) +--% (has name (SIGNATURE operator signature)) +--% The use of two representations is admitted to be clumsy + + +import '"g-util" +)package "BOOT" + +printInfo $e == + for u in get("$Information","special",$e) repeat PRETTYPRINT u + nil + +addInformation(m,$e) == + $Information: local + --$Information:= nil: done by previous statement anyway + info m where + info m == + --Processes information from a mode declaration in compCapsule + atom m => nil + m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u + m is ["Join",:stuff] => for u in stuff repeat info u + nil + $e:= + put("$Information","special",[:$Information,: + get("$Information","special",$e)],$e) + $e + +addInfo u == $Information:= [formatInfo u,:$Information] + +formatInfo u == + atom u => u + u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] + --u is ("CATEGORY",junk,:l) => ("PROGN",:(formatInfo v for v in l)) + u is ["PROGN",:l] => ["PROGN",:[formatInfo v for v in l]] + u is ["ATTRIBUTE",v] => + + -- The parser can't tell between those attributes that really + -- are attributes, and those that are category names + atom v and isCategoryForm([v],$e) => ["has","$",[v]] + atom v => ["ATTRIBUTE","$",v] + isCategoryForm(v,$e) => ["has","$",v] + ["ATTRIBUTE","$",v] + u is ["IF",a,b,c] => + c="noBranch" => ["COND",:liftCond [formatPred a,formatInfo b]] + b="noBranch" => ["COND",:liftCond [["not",formatPred a],formatInfo c]] + ["COND",:liftCond [formatPred a,formatInfo b],: + liftCond [["not",formatPred a],formatInfo c]] + systemError '"formatInfo" + +liftCond (clause is [ante,conseq]) == + conseq is ["COND",:l] => + [[lcAnd(ante,a),:b] for [a,:b] in l] where + lcAnd(pred,conj) == + conj is ["and",:ll] => ["and",pred,:ll] + ["and",pred,conj] + [clause] + +formatPred u == + --Assumes that $e is set up to point to an environment + u is ["has",a,b] => + atom b and isCategoryForm([b],$e) => ["has",a,[b]] + atom b => ["has",a,["ATTRIBUTE",b]] + isCategoryForm(b,$e) => u + b is ["ATTRIBUTE",.] => u + b is ["SIGNATURE",:.] => u + ["has",a,["ATTRIBUTE",b]] + atom u => u + u is ["and",:v] => ["and",:[formatPred w for w in v]] + systemError '"formatPred" + +chaseInferences(pred,$e) == + foo hasToInfo pred where + foo pred == + knownInfo pred => nil + $e:= actOnInfo(pred,$e) + pred:= infoToHas pred + for u in get("$Information","special",$e) repeat + u is ["COND",:l] => + for [ante,:conseq] in l repeat + ante=pred => [foo w for w in conseq] + ante is ["and",:ante'] and member(pred,ante') => + ante':= delete(pred,ante') + v':= + LENGTH ante'=1 => first ante' + ["and",:ante'] + v':= ["COND",[v',:conseq]] + member(v',get("$Information","special",$e)) => nil + $e:= + put("$Information","special",[v',: + get("$Information","special",$e)],$e) + nil + $e + +hasToInfo (pred is ["has",a,b]) == + b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] + b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c] + pred + +infoToHas a == + a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]] + a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]] + a + +knownInfo pred == + --true %if the information is already known + pred=true => true + --pred = "true" => true + member(pred,get("$Information","special",$e)) => true + pred is ["OR",:l] => or/[knownInfo u for u in l] + pred is ["AND",:l] => and/[knownInfo u for u in l] + pred is ["or",:l] => or/[knownInfo u for u in l] + pred is ["and",:l] => and/[knownInfo u for u in l] + pred is ["ATTRIBUTE",name,attr] => + v:= compForMode(name,$EmptyMode,$e) + null v => stackSemanticError(["can't find category of ",name],nil) + [vv,.,.]:= compMakeCategoryObject(CADR v,$e) + null vv => stackSemanticError(["can't make category of ",name],nil) + member(attr,vv.2) => true + x:= assoc(attr,vv.2) => knownInfo CADR x + --format is a list of two elements: information, predicate + false + pred is ["has",name,cat] => + cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] + cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] + name is ['Union,:.] => false + v:= compForMode(name,$EmptyMode,$e) + null v => stackSemanticError(["can't find category of ",name],nil) + vmode := CADR v + cat = vmode => true + vmode is ["Join",:l] and member(cat,l) => true + [vv,.,.]:= compMakeCategoryObject(vmode,$e) + catlist := vv.4 + --catlist := SUBST(name,'$,vv.4) + null vv => stackSemanticError(["can't make category of ",name],nil) + member(cat,first catlist) => true --checks princ. ancestors + (u:=assoc(cat,CADR catlist)) and knownInfo(CADR u) => true + -- previous line checks fundamental anscestors, we should check their + -- principal anscestors but this requires instantiating categories + + -- This line caused recursion on predicates which are no use in deciding + -- whether a category was present. +-- this is correct TPD feb, 19, 2003 + or/[AncestorP(cat,LIST CAR u) for u in CADR catlist | knownInfo CADR u] => true +-- this is wrong TPD feb, 19, 2003 + -- or/[AncestorP(cat,LIST CAR u) and knownInfo CADR u for u in CADR catlist] => true + false + pred is ["SIGNATURE",name,op,sig,:.] => + v:= get(op,"modemap",$e) + for w in v repeat + ww:= CDAR w + --the actual signature part + LENGTH ww=LENGTH sig and SourceLevelSubsume(ww,sig) => + --NULL CAADR w => return false + CAADR w = true => return true + --return false + --error '"knownInfo" + false + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +actOnInfo(u,$e) == + null u => $e + u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) + $e:= + put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e + ) + u is ["COND",:l] => + --there is nowhere %else that this sort of thing exists + for [ante,:conseq] in l repeat + if member(hasToInfo ante,Info) then for v in conseq repeat + $e:= actOnInfo(v,$e) + $e + u is ["ATTRIBUTE",name,att] => + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["ATTRIBUTE",att]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + --there is nowhere %else that this sort of thing exists + u is ["SIGNATURE",name,operator,modemap] => + implem:= + (implem:=assoc([name,:modemap],get(operator,'modemap,$e))) => + CADADR implem + ['ELT,name,nil] + $e:= addModemap(operator,name,modemap,true,implem,$e) + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + u is ["has",name,cat] => + [vval,vmode,venv]:= GetValue name + cat=vmode => $e --stating the already known + u:= compMakeCategoryObject(cat,$e) => + --we are adding information about a category + [catvec,.,$e]:= u + [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) + -- member(vmode,CAR catvec.4) => + -- JHD 82/08/08 01:40 This does not mean that we can ignore the + -- extension, since this may not be compatible with the view we + -- were passed + + --we are adding a principal descendant of what was already known + -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) + -- SAY("augmenting ",name,": ",cat) + -- put(name, "value", (vval, cat, venv), $e) + member(cat,first ocatvec.4) or + assoc(cat,CADR ocatvec.4) is [.,'T,.] => $e + --SAY("Category extension error: + --cat shouldn't be a join + --what was being asserted is an ancestor of what was known + if name="$" + then $e:= augModemapsFromCategory(name,name,name,cat,$e) + else + viewName:=genDomainViewName(name,cat) + genDomainView(viewName,name,cat,"HasCategory") + if not MEMQ(viewName,$functorLocalParameters) then + $functorLocalParameters:=[:$functorLocalParameters,viewName] + SAY("augmenting ",name,": ",cat) + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + SAY("extension of ",vval," to ",cat," ignored") + $e + systemError '"knownInfo" + +mkJoin(cat,mode) == + mode is ['Join,:cats] => ['Join,cat,:cats] + ['Join,cat,mode] + +GetValue name == + u:= get(name,"value",$e) => u + u:= comp(name,$EmptyMode,$e) => u --name may be a form + systemError [name,'" is not bound in the current environment"] + diff --git a/src/interp/info.boot.pamphlet b/src/interp/info.boot.pamphlet deleted file mode 100644 index ba2ef824..00000000 --- a/src/interp/info.boot.pamphlet +++ /dev/null @@ -1,308 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/info.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -ADDINFORMATION CODE -This code adds various items to the special value of $Information, -in order to keep track of all the compiler's information about -various categories and similar objects -An actual piece of (unconditional) information can have one of 3 forms: - (ATTRIBUTE domainname attribute) - --These are only stored here - (SIGNATURE domainname operator signature) - --These are also stored as 'modemap' properties - (has domainname categoryexpression) - --These are also stored as 'value' properties -Conditional attributes are of the form - (COND - (condition info info ...) - ... ) -where the condition looks like a 'has' clause, or the 'and' of several -'has' clauses: - (has name categoryexpression) - (has name (ATTRIBUTE attribute)) - (has name (SIGNATURE operator signature)) -The use of two representations is admitted to be clumsy - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"g-util" -)package "BOOT" - -printInfo $e == - for u in get("$Information","special",$e) repeat PRETTYPRINT u - nil - -addInformation(m,$e) == - $Information: local - --$Information:= nil: done by previous statement anyway - info m where - info m == - --Processes information from a mode declaration in compCapsule - atom m => nil - m is ["CATEGORY",.,:stuff] => for u in stuff repeat addInfo u - m is ["Join",:stuff] => for u in stuff repeat info u - nil - $e:= - put("$Information","special",[:$Information,: - get("$Information","special",$e)],$e) - $e - -addInfo u == $Information:= [formatInfo u,:$Information] - -formatInfo u == - atom u => u - u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v] - --u is ("CATEGORY",junk,:l) => ("PROGN",:(formatInfo v for v in l)) - u is ["PROGN",:l] => ["PROGN",:[formatInfo v for v in l]] - u is ["ATTRIBUTE",v] => - - -- The parser can't tell between those attributes that really - -- are attributes, and those that are category names - atom v and isCategoryForm([v],$e) => ["has","$",[v]] - atom v => ["ATTRIBUTE","$",v] - isCategoryForm(v,$e) => ["has","$",v] - ["ATTRIBUTE","$",v] - u is ["IF",a,b,c] => - c="noBranch" => ["COND",:liftCond [formatPred a,formatInfo b]] - b="noBranch" => ["COND",:liftCond [["not",formatPred a],formatInfo c]] - ["COND",:liftCond [formatPred a,formatInfo b],: - liftCond [["not",formatPred a],formatInfo c]] - systemError '"formatInfo" - -liftCond (clause is [ante,conseq]) == - conseq is ["COND",:l] => - [[lcAnd(ante,a),:b] for [a,:b] in l] where - lcAnd(pred,conj) == - conj is ["and",:ll] => ["and",pred,:ll] - ["and",pred,conj] - [clause] - -formatPred u == - --Assumes that $e is set up to point to an environment - u is ["has",a,b] => - atom b and isCategoryForm([b],$e) => ["has",a,[b]] - atom b => ["has",a,["ATTRIBUTE",b]] - isCategoryForm(b,$e) => u - b is ["ATTRIBUTE",.] => u - b is ["SIGNATURE",:.] => u - ["has",a,["ATTRIBUTE",b]] - atom u => u - u is ["and",:v] => ["and",:[formatPred w for w in v]] - systemError '"formatPred" - -chaseInferences(pred,$e) == - foo hasToInfo pred where - foo pred == - knownInfo pred => nil - $e:= actOnInfo(pred,$e) - pred:= infoToHas pred - for u in get("$Information","special",$e) repeat - u is ["COND",:l] => - for [ante,:conseq] in l repeat - ante=pred => [foo w for w in conseq] - ante is ["and",:ante'] and member(pred,ante') => - ante':= delete(pred,ante') - v':= - LENGTH ante'=1 => first ante' - ["and",:ante'] - v':= ["COND",[v',:conseq]] - member(v',get("$Information","special",$e)) => nil - $e:= - put("$Information","special",[v',: - get("$Information","special",$e)],$e) - nil - $e - -hasToInfo (pred is ["has",a,b]) == - b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data] - b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c] - pred - -infoToHas a == - a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]] - a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]] - a - -knownInfo pred == - --true %if the information is already known - pred=true => true - --pred = "true" => true - member(pred,get("$Information","special",$e)) => true - pred is ["OR",:l] => or/[knownInfo u for u in l] - pred is ["AND",:l] => and/[knownInfo u for u in l] - pred is ["or",:l] => or/[knownInfo u for u in l] - pred is ["and",:l] => and/[knownInfo u for u in l] - pred is ["ATTRIBUTE",name,attr] => - v:= compForMode(name,$EmptyMode,$e) - null v => stackSemanticError(["can't find category of ",name],nil) - [vv,.,.]:= compMakeCategoryObject(CADR v,$e) - null vv => stackSemanticError(["can't make category of ",name],nil) - member(attr,vv.2) => true - x:= assoc(attr,vv.2) => knownInfo CADR x - --format is a list of two elements: information, predicate - false - pred is ["has",name,cat] => - cat is ["ATTRIBUTE",:a] => knownInfo ["ATTRIBUTE",name,:a] - cat is ["SIGNATURE",:a] => knownInfo ["SIGNATURE",name,:a] - name is ['Union,:.] => false - v:= compForMode(name,$EmptyMode,$e) - null v => stackSemanticError(["can't find category of ",name],nil) - vmode := CADR v - cat = vmode => true - vmode is ["Join",:l] and member(cat,l) => true - [vv,.,.]:= compMakeCategoryObject(vmode,$e) - catlist := vv.4 - --catlist := SUBST(name,'$,vv.4) - null vv => stackSemanticError(["can't make category of ",name],nil) - member(cat,first catlist) => true --checks princ. ancestors - (u:=assoc(cat,CADR catlist)) and knownInfo(CADR u) => true - -- previous line checks fundamental anscestors, we should check their - -- principal anscestors but this requires instantiating categories - - -- This line caused recursion on predicates which are no use in deciding - -- whether a category was present. --- this is correct TPD feb, 19, 2003 - or/[AncestorP(cat,LIST CAR u) for u in CADR catlist | knownInfo CADR u] => true --- this is wrong TPD feb, 19, 2003 - -- or/[AncestorP(cat,LIST CAR u) and knownInfo CADR u for u in CADR catlist] => true - false - pred is ["SIGNATURE",name,op,sig,:.] => - v:= get(op,"modemap",$e) - for w in v repeat - ww:= CDAR w - --the actual signature part - LENGTH ww=LENGTH sig and SourceLevelSubsume(ww,sig) => - --NULL CAADR w => return false - CAADR w = true => return true - --return false - --error '"knownInfo" - false - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -actOnInfo(u,$e) == - null u => $e - u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) - $e:= - put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e - ) - u is ["COND",:l] => - --there is nowhere %else that this sort of thing exists - for [ante,:conseq] in l repeat - if member(hasToInfo ante,Info) then for v in conseq repeat - $e:= actOnInfo(v,$e) - $e - u is ["ATTRIBUTE",name,att] => - [vval,vmode,venv]:= GetValue name - SAY("augmenting ",name,": ",u) - key:= if CONTAINED("$",vmode) then "domain" else name - cat:= ["CATEGORY",key,["ATTRIBUTE",att]] - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - --there is nowhere %else that this sort of thing exists - u is ["SIGNATURE",name,operator,modemap] => - implem:= - (implem:=assoc([name,:modemap],get(operator,'modemap,$e))) => - CADADR implem - ['ELT,name,nil] - $e:= addModemap(operator,name,modemap,true,implem,$e) - [vval,vmode,venv]:= GetValue name - SAY("augmenting ",name,": ",u) - key:= if CONTAINED("$",vmode) then "domain" else name - cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - u is ["has",name,cat] => - [vval,vmode,venv]:= GetValue name - cat=vmode => $e --stating the already known - u:= compMakeCategoryObject(cat,$e) => - --we are adding information about a category - [catvec,.,$e]:= u - [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) - -- member(vmode,CAR catvec.4) => - -- JHD 82/08/08 01:40 This does not mean that we can ignore the - -- extension, since this may not be compatible with the view we - -- were passed - - --we are adding a principal descendant of what was already known - -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) - -- SAY("augmenting ",name,": ",cat) - -- put(name, "value", (vval, cat, venv), $e) - member(cat,first ocatvec.4) or - assoc(cat,CADR ocatvec.4) is [.,'T,.] => $e - --SAY("Category extension error: - --cat shouldn't be a join - --what was being asserted is an ancestor of what was known - if name="$" - then $e:= augModemapsFromCategory(name,name,name,cat,$e) - else - viewName:=genDomainViewName(name,cat) - genDomainView(viewName,name,cat,"HasCategory") - if not MEMQ(viewName,$functorLocalParameters) then - $functorLocalParameters:=[:$functorLocalParameters,viewName] - SAY("augmenting ",name,": ",cat) - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - SAY("extension of ",vval," to ",cat," ignored") - $e - systemError '"knownInfo" - -mkJoin(cat,mode) == - mode is ['Join,:cats] => ['Join,cat,:cats] - ['Join,cat,mode] - -GetValue name == - u:= get(name,"value",$e) => u - u:= comp(name,$EmptyMode,$e) => u --name may be a form - systemError [name,'" is not bound in the current environment"] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/iterator.boot b/src/interp/iterator.boot new file mode 100644 index 00000000..af6d6c37 --- /dev/null +++ b/src/interp/iterator.boot @@ -0,0 +1,298 @@ +-- 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 '"g-util" +)package "BOOT" + +--% ITERATORS + +compReduce(form,m,e) == + compReduce1(form,m,e,$formalArgList) + +compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == + [collectOp,:itl,body]:= collectForm + if STRINGP op then op:= INTERN op + ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => + systemError ["illegal reduction form:",form] + $sideEffectsList: local + $until: local + $initList: local + $endTestList: local + $e:= e + itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] + itl="failed" => return nil + e:= $e + acc:= GENSYM() + afterFirst:= GENSYM() + bodyVal:= GENSYM() + [part1,m,e]:= comp(["LET",bodyVal,body],m,e) or return nil + [part2,.,e]:= comp(["LET",acc,bodyVal],m,e) or return nil + [part3,.,e]:= comp(["LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil + identityCode:= + id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil + ["IdentityError",MKQ op] + finalCode:= + ["PROGN", + ["LET",afterFirst,nil], + ["REPEAT",:itl, + ["PROGN",part1, + ["IF", afterFirst,part3, + ["PROGN",part2,["LET",afterFirst,MKQ true]]]]], + ["IF",afterFirst,acc,identityCode]] + if $until then + [untilCode,.,e]:= comp($until,$Boolean,e) + finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode) + [finalCode,m,e] + +getIdentity(x,e) == + GETL(x,"THETA") is [y] => y + +numberize x == + x=$Zero => 0 + x=$One => 1 + atom x => x + [numberize first x,:numberize rest x] + +compRepeatOrCollect(form,m,e) == + fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList + ,e) where + fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == + $until: local + [repeatOrCollect,:itl,body]:= form + itl':= + [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] + itl'="failed" => nil + targetMode:= first $exitModeStack + bodyMode:= + repeatOrCollect="COLLECT" => + targetMode = '$EmptyMode => '$EmptyMode + (u:=modeIsAggregateOf('List,targetMode,e)) => + CADR u + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => + repeatOrCollect:='COLLECTV + CADR u + (u:=modeIsAggregateOf('Vector,targetMode,e)) => + repeatOrCollect:='COLLECTVEC + CADR u + stackMessage('"Invalid collect bodytype") + return nil + -- If we're doing a collect, and the type isn't conformable + -- then we've boobed. JHD 26.July.1990 + $NoValueMode + [body',m',e']:= + -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or + compOrCroak(body,bodyMode,e) or return nil + if $until then + [untilCode,.,e']:= comp($until,$Boolean,e') + itl':= substitute(["UNTIL",untilCode],'$until,itl') + form':= [repeatOrCollect,:itl',body'] + m'':= + repeatOrCollect="COLLECT" => + (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u + ["List",m'] + repeatOrCollect="COLLECTV" => + (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u + ["PrimitiveArray",m'] + repeatOrCollect="COLLECTVEC" => + (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u + ["Vector",m'] + m' + coerceExit([form',m'',e'],targetMode) + +--constructByModemap([x,source,e],target) == +-- u:= +-- [cexpr +-- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [ +-- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil +-- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil +-- [["call",fn,x],target,e] + +listOrVectorElementMode x == + x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b + +compIterator(it,e) == + it is ["IN",x,y] => + --these two lines must be in this order, to get "for f in list f" + --to give an error message if f is undefined + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + $formalArgList:= [x,:$formalArgList] + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of some mode"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),mUnder,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["IN",x,y''],e] + it is ["ON",x,y] => + $formalArgList:= [x,:$formalArgList] + [y',m,e]:= comp(y,$EmptyMode,e) or return nil + [mOver,mUnder]:= + modeIsAggregateOf("List",m,e) or return + stackMessage ["mode: ",m," must be a list of other modes"] + if null get(x,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil + e:= put(x,"value",[genSomeVariable(),m,e],e) + [y'',m'',e] := coerce([y',m,e], mOver) or return nil + [["ON",x,y''],e] + it is ["STEP",index,start,inc,:optFinal] => + $formalArgList:= [index,:$formalArgList] + --if all start/inc/end compile as small integers, then loop + --is compiled as a small integer loop + final':= nil + (start':= comp(start,$SmallInteger,e)) and + (inc':= comp(inc,$NonNegativeInteger,start'.env)) and + (not (optFinal is [final]) or + (final':= comp(final,$SmallInteger,inc'.env))) => + indexmode:= + comp(start,$NonNegativeInteger,e) => + $NonNegativeInteger + $SmallInteger + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode, + (final' => final'.env; inc'.env)) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + if final' then optFinal:= [final'.expr] + [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] + [start,.,e]:= + comp(start,$Integer,e) or return + stackMessage ["start value of index: ",start," must be an integer"] + [inc,.,e]:= + comp(inc,$Integer,e) or return + stackMessage ["index increment:",inc," must be an integer"] + if optFinal is [final] then + [final,.,e]:= + comp(final,$Integer,e) or return + stackMessage ["final value of index: ",final," must be an integer"] + optFinal:= [final] + indexmode:= + comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger + $Integer + if null get(index,"mode",e) then [.,.,e]:= + compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil + e:= put(index,"value",[genSomeVariable(),indexmode,e],e) + [["STEP",index,start,inc,:optFinal],e] + it is ["WHILE",p] => + [p',m,e]:= + comp(p,$Boolean,e) or return + stackMessage ["WHILE operand: ",p," is not Boolean valued"] + [["WHILE",p'],e] + it is ["UNTIL",p] => ($until:= p; ['$until,e]) + it is ["|",x] => + u:= + comp(x,$Boolean,e) or return + stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] + [["|",u.expr],u.env] + nil + +--isAggregateMode(m,e) == +-- m is [c,R] and MEMQ(c,'(Vector List)) => R +-- name:= +-- m is [fn,:.] => fn +-- m="$" => "Rep" +-- m +-- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R + +modeIsAggregateOf(ListOrVector,m,e) == + m is [ =ListOrVector,R] => [m,R] +--m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + + m is ["Union",:l] => + mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] + 1=#mList => first mList + name:= + m is [fn,:.] => fn + m="$" => "Rep" + m + get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] + +--% VECTOR ITERATORS + +--the following 4 functions are not currently used + +--compCollectV(form,m,e) == +-- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where +-- fn(form,$exitModeStack,$leaveLevelStack,e) == +-- [repeatOrCollect,it,body]:= form +-- [it',e]:= compIteratorV(it,e) or return nil +-- m:= first $exitModeStack +-- [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode +-- [body',m',e']:= compOrCroak(body,mUnder,e) or return nil +-- form':= ["COLLECTV",it',body'] +-- {n:= +-- it' is ("STEP",.,s,i,f) or it' is ("ISTEP",.,s,i,f) => +-- computeMaxIndex(s,f,i); +-- return nil} +-- coerce([form',mOver,e'],m) +-- +--compIteratorV(it,e) == +-- it is ["STEP",index,start,inc,final] => +-- (start':= comp(start,$Integer,e)) and +-- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and +-- (final':= comp(final,$Integer,inc'.env)) => +-- indexmode:= +-- comp(start,$NonNegativeInteger,e) => $NonNegativeInteger +-- $Integer +-- if null get(index,"mode",e) then [.,.,e]:= +-- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or +-- return nil +-- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +-- [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] +-- [start,.,e]:= +-- comp(start,$Integer,e) or return +-- stackMessage ["start value of index: ",start," is not an integer"] +-- [inc,.,e]:= +-- comp(inc,$NonNegativeInteger,e) or return +-- stackMessage ["index increment: ",inc," must be a non-negative integer"] +-- [final,.,e]:= +-- comp(final,$Integer,e) or return +-- stackMessage ["final value of index: ",final," is not an integer"] +-- indexmode:= +-- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger +-- $Integer +-- if null get(index,"mode",e) then [.,.,e]:= +-- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil +-- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) +-- [["STEP",index,start,inc,final],e] +-- nil +-- +--computeMaxIndex(s,f,i) == +-- i^=1 => cannotDo() +-- s=1 => f +-- exprDifference(f,exprDifference(s,1)) +-- +--exprDifference(x,y) == +-- y=0 => x +-- FIXP x and FIXP y => DIFFERENCE(x,y) +-- ["DIFFERENCE",x,y] + diff --git a/src/interp/iterator.boot.pamphlet b/src/interp/iterator.boot.pamphlet deleted file mode 100644 index 74eccf2e..00000000 --- a/src/interp/iterator.boot.pamphlet +++ /dev/null @@ -1,322 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/iterator.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"g-util" -)package "BOOT" - ---% ITERATORS - -compReduce(form,m,e) == - compReduce1(form,m,e,$formalArgList) - -compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == - [collectOp,:itl,body]:= collectForm - if STRINGP op then op:= INTERN op - ^MEMQ(collectOp,'(COLLECT COLLECTV COLLECTVEC)) => - systemError ["illegal reduction form:",form] - $sideEffectsList: local - $until: local - $initList: local - $endTestList: local - $e:= e - itl:= [([.,$e]:= compIterator(x,$e) or return "failed").(0) for x in itl] - itl="failed" => return nil - e:= $e - acc:= GENSYM() - afterFirst:= GENSYM() - bodyVal:= GENSYM() - [part1,m,e]:= comp(["LET",bodyVal,body],m,e) or return nil - [part2,.,e]:= comp(["LET",acc,bodyVal],m,e) or return nil - [part3,.,e]:= comp(["LET",acc,parseTran [op,acc,bodyVal]],m,e) or return nil - identityCode:= - id:= getIdentity(op,e) => u.expr where u() == comp(id,m,e) or return nil - ["IdentityError",MKQ op] - finalCode:= - ["PROGN", - ["LET",afterFirst,nil], - ["REPEAT",:itl, - ["PROGN",part1, - ["IF", afterFirst,part3, - ["PROGN",part2,["LET",afterFirst,MKQ true]]]]], - ["IF",afterFirst,acc,identityCode]] - if $until then - [untilCode,.,e]:= comp($until,$Boolean,e) - finalCode:= substitute(["UNTIL",untilCode],'$until,finalCode) - [finalCode,m,e] - -getIdentity(x,e) == - GETL(x,"THETA") is [y] => y - -numberize x == - x=$Zero => 0 - x=$One => 1 - atom x => x - [numberize first x,:numberize rest x] - -compRepeatOrCollect(form,m,e) == - fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],$formalArgList - ,e) where - fn(form,$exitModeStack,$leaveLevelStack,$formalArgList,e) == - $until: local - [repeatOrCollect,:itl,body]:= form - itl':= - [([x',e]:= compIterator(x,e) or return "failed"; x') for x in itl] - itl'="failed" => nil - targetMode:= first $exitModeStack - bodyMode:= - repeatOrCollect="COLLECT" => - targetMode = '$EmptyMode => '$EmptyMode - (u:=modeIsAggregateOf('List,targetMode,e)) => - CADR u - (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => - repeatOrCollect:='COLLECTV - CADR u - (u:=modeIsAggregateOf('Vector,targetMode,e)) => - repeatOrCollect:='COLLECTVEC - CADR u - stackMessage('"Invalid collect bodytype") - return nil - -- If we're doing a collect, and the type isn't conformable - -- then we've boobed. JHD 26.July.1990 - $NoValueMode - [body',m',e']:= - -- (m1:= listOrVectorElementMode targetMode) and comp(body,m1,e) or - compOrCroak(body,bodyMode,e) or return nil - if $until then - [untilCode,.,e']:= comp($until,$Boolean,e') - itl':= substitute(["UNTIL",untilCode],'$until,itl') - form':= [repeatOrCollect,:itl',body'] - m'':= - repeatOrCollect="COLLECT" => - (u:=modeIsAggregateOf('List,targetMode,e)) => CAR u - ["List",m'] - repeatOrCollect="COLLECTV" => - (u:=modeIsAggregateOf('PrimitiveArray,targetMode,e)) => CAR u - ["PrimitiveArray",m'] - repeatOrCollect="COLLECTVEC" => - (u:=modeIsAggregateOf('Vector,targetMode,e)) => CAR u - ["Vector",m'] - m' - coerceExit([form',m'',e'],targetMode) - ---constructByModemap([x,source,e],target) == --- u:= --- [cexpr --- for (modemap:= [map,cexpr]) in getModemapList("construct",1,e) | map is [ --- .,t,s] and modeEqual(t,target) and modeEqual(s,source)] or return nil --- fn:= (or/[selfn for [cond,selfn] in u | cond=true]) or return nil --- [["call",fn,x],target,e] - -listOrVectorElementMode x == - x is [a,b,:.] and member(a,'(PrimitiveArray Vector List)) => b - -compIterator(it,e) == - it is ["IN",x,y] => - --these two lines must be in this order, to get "for f in list f" - --to give an error message if f is undefined - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - $formalArgList:= [x,:$formalArgList] - [mOver,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of some mode"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,mUnder],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),mUnder,e],e) - [y'',m'',e] := coerce([y',m,e], mOver) or return nil - [["IN",x,y''],e] - it is ["ON",x,y] => - $formalArgList:= [x,:$formalArgList] - [y',m,e]:= comp(y,$EmptyMode,e) or return nil - [mOver,mUnder]:= - modeIsAggregateOf("List",m,e) or return - stackMessage ["mode: ",m," must be a list of other modes"] - if null get(x,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",x,m],$EmptyMode,e) or return nil - e:= put(x,"value",[genSomeVariable(),m,e],e) - [y'',m'',e] := coerce([y',m,e], mOver) or return nil - [["ON",x,y''],e] - it is ["STEP",index,start,inc,:optFinal] => - $formalArgList:= [index,:$formalArgList] - --if all start/inc/end compile as small integers, then loop - --is compiled as a small integer loop - final':= nil - (start':= comp(start,$SmallInteger,e)) and - (inc':= comp(inc,$NonNegativeInteger,start'.env)) and - (not (optFinal is [final]) or - (final':= comp(final,$SmallInteger,inc'.env))) => - indexmode:= - comp(start,$NonNegativeInteger,e) => - $NonNegativeInteger - $SmallInteger - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode, - (final' => final'.env; inc'.env)) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - if final' then optFinal:= [final'.expr] - [["ISTEP",index,start'.expr,inc'.expr,:optFinal],e] - [start,.,e]:= - comp(start,$Integer,e) or return - stackMessage ["start value of index: ",start," must be an integer"] - [inc,.,e]:= - comp(inc,$Integer,e) or return - stackMessage ["index increment:",inc," must be an integer"] - if optFinal is [final] then - [final,.,e]:= - comp(final,$Integer,e) or return - stackMessage ["final value of index: ",final," must be an integer"] - optFinal:= [final] - indexmode:= - comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger - $Integer - if null get(index,"mode",e) then [.,.,e]:= - compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil - e:= put(index,"value",[genSomeVariable(),indexmode,e],e) - [["STEP",index,start,inc,:optFinal],e] - it is ["WHILE",p] => - [p',m,e]:= - comp(p,$Boolean,e) or return - stackMessage ["WHILE operand: ",p," is not Boolean valued"] - [["WHILE",p'],e] - it is ["UNTIL",p] => ($until:= p; ['$until,e]) - it is ["|",x] => - u:= - comp(x,$Boolean,e) or return - stackMessage ["SUCHTHAT operand: ",x," is not Boolean value"] - [["|",u.expr],u.env] - nil - ---isAggregateMode(m,e) == --- m is [c,R] and MEMQ(c,'(Vector List)) => R --- name:= --- m is [fn,:.] => fn --- m="$" => "Rep" --- m --- get(name,"value",e) is [c,R] and MEMQ(c,'(Vector List)) => R - -modeIsAggregateOf(ListOrVector,m,e) == - m is [ =ListOrVector,R] => [m,R] ---m = '$EmptyMode => [m,m] I don't think this is correct, breaks POLY + - m is ["Union",:l] => - mList:= [pair for m' in l | (pair:= modeIsAggregateOf(ListOrVector,m',e))] - 1=#mList => first mList - name:= - m is [fn,:.] => fn - m="$" => "Rep" - m - get(name,"value",e) is [[ =ListOrVector,R],:.] => [m,R] - ---% VECTOR ITERATORS - ---the following 4 functions are not currently used - ---compCollectV(form,m,e) == --- fn(form,[m,:$exitModeStack],[#$exitModeStack,:$leaveLevelStack],e) where --- fn(form,$exitModeStack,$leaveLevelStack,e) == --- [repeatOrCollect,it,body]:= form --- [it',e]:= compIteratorV(it,e) or return nil --- m:= first $exitModeStack --- [mOver,mUnder]:= modeIsAggregateOf("Vector",m,e) or $EmptyMode --- [body',m',e']:= compOrCroak(body,mUnder,e) or return nil --- form':= ["COLLECTV",it',body'] --- {n:= --- it' is ("STEP",.,s,i,f) or it' is ("ISTEP",.,s,i,f) => --- computeMaxIndex(s,f,i); --- return nil} --- coerce([form',mOver,e'],m) --- ---compIteratorV(it,e) == --- it is ["STEP",index,start,inc,final] => --- (start':= comp(start,$Integer,e)) and --- (inc':= comp(inc,$NonNegativeInteger,start'.env)) and --- (final':= comp(final,$Integer,inc'.env)) => --- indexmode:= --- comp(start,$NonNegativeInteger,e) => $NonNegativeInteger --- $Integer --- if null get(index,"mode",e) then [.,.,e]:= --- compMakeDeclaration([":",index,indexmode],$EmptyMode,final'.env) or --- return nil --- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) --- [["ISTEP",index,start'.expr,inc'.expr,final'.expr],e] --- [start,.,e]:= --- comp(start,$Integer,e) or return --- stackMessage ["start value of index: ",start," is not an integer"] --- [inc,.,e]:= --- comp(inc,$NonNegativeInteger,e) or return --- stackMessage ["index increment: ",inc," must be a non-negative integer"] --- [final,.,e]:= --- comp(final,$Integer,e) or return --- stackMessage ["final value of index: ",final," is not an integer"] --- indexmode:= --- comp(CADDR it,$NonNegativeInteger,e) => $NonNegativeInteger --- $Integer --- if null get(index,"mode",e) then [.,.,e]:= --- compMakeDeclaration([":",index,indexmode],$EmptyMode,e) or return nil --- e:= put(index,"value",[genSomeVariable(),indexmode,e],e) --- [["STEP",index,start,inc,final],e] --- nil --- ---computeMaxIndex(s,f,i) == --- i^=1 => cannotDo() --- s=1 => f --- exprDifference(f,exprDifference(s,1)) --- ---exprDifference(x,y) == --- y=0 => x --- FIXP x and FIXP y => DIFFERENCE(x,y) --- ["DIFFERENCE",x,y] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot new file mode 100644 index 00000000..02c93677 --- /dev/null +++ b/src/interp/modemap.boot @@ -0,0 +1,375 @@ +-- 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 '"c-util" +import '"info" +)package "BOOT" + +--% EXTERNAL ROUTINES + +--These functions are called from outside this file to add a domain +-- or to get the current domains in scope; + +addDomain(domain,e) == + atom domain => + EQ(domain,"$EmptyMode") => e + EQ(domain,"$NoValueMode") => e + not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and + EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e + MEMQ(domain,getDomainsInScope e) => e + isLiteral(domain,e) => e + addNewDomain(domain,e) + (name:= first domain)='Category => e + domainMember(domain,getDomainsInScope e) => e + getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> + addNewDomain(domain,e) + -- constructor? test needed for domains compiled with $bootStrapMode=true + isFunctor name or constructor? name => addNewDomain(domain,e) + if not isCategoryForm(domain,e) and + not member(name,'(Mapping CATEGORY)) then + unknownTypeError name + e --is not a functor + +domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] + +--% MODEMAP FUNCTIONS + +--getTargetMode(x is [op,:argl],e) == +-- CASES(#(mml:= getModemapList(op,#argl,e)), +-- (1 => +-- ([[.,target,:.],:.]:= first mml; substituteForFormalArguments(argl,target)) +-- ; 0 => MOAN(x," has no modemap"); systemError [x," has duplicate modemaps"])) + +getModemap(x is [op,:.],e) == + for modemap in get(op,'modemap,e) repeat + if u:= compApplyModemap(x,modemap,e,nil) then return + ([.,.,sl]:= u; SUBLIS(sl,modemap)) + +getUniqueSignature(form,e) == + [[.,:sig],:.]:= getUniqueModemap(first form,#rest form,e) or return nil + sig + +getUniqueModemap(op,numOfArgs,e) == + 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml + 1<#mml => + stackWarning [numOfArgs,'" argument form of: ",op, + '" has more than one modemap"] + first mml + nil + +getModemapList(op,numOfArgs,e) == + op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) + [mm for + (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] + +getModemapListFromDomain(op,numOfArgs,D,e) == + [mm + for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= + numOfArgs] + + +insertModemap(new,mmList) == + null mmList => [new] +--isMoreSpecific(new,old:= first mmList) => [new,:mmList] +--[old,:insertModemap(new,rest mmList)] + [new,:mmList] + +addModemap(op,mc,sig,pred,fn,$e) == + $InteractiveMode => $e + if knownInfo pred then pred:=true + $insideCapsuleFunctionIfTrue=true => + $CapsuleModemapFrame := + addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) + $e + addModemap0(op,mc,sig,pred,fn,$e) + +addModemapKnown(op,mc,sig,pred,fn,$e) == +-- if knownInfo pred then pred:=true +-- that line is handled elsewhere + $insideCapsuleFunctionIfTrue=true => + $CapsuleModemapFrame := + addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) + $e + addModemap0(op,mc,sig,pred,fn,$e) + +addModemap0(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + $functorForm is ['CategoryDefaults,:.] and mc="$" => e + --don't put CD modemaps into environment + --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps + -- breaks -:($,$)->U($,failed) in DP + op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) + addModemap1(op,mc,sig,pred,fn,e) + +addEltModemap(op,mc,sig,pred,fn,e) == + --hack to change selectors from strings to identifiers; and to + --add flag identifiers as literals in the envir + op='elt and sig is [:lt,sel] => + STRINGP sel => + id:= INTERN sel + if $insideCapsuleFunctionIfTrue=true + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id],pred,fn,e) + -- atom sel => systemErrorHere '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + op='setelt and sig is [:lt,sel,v] => + STRINGP sel => + id:= INTERN sel + if $insideCapsuleFunctionIfTrue=true + then $e:= makeLiteral(id,$e) + else e:= makeLiteral(id,e) + addModemap1(op,mc,[:lt,id,v],pred,fn,e) + -- atom sel => systemError '"addEltModemap" + addModemap1(op,mc,sig,pred,fn,e) + systemErrorHere '"addEltModemap" + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +addModemap1(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + if mc='Rep then + if fn is [kind,'Rep,.] and + -- save old sig for NRUNTIME + (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] + sig:= substitute("$",'Rep,sig) + currentProplist:= getProplist(op,e) or nil + newModemapList:= + mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) + newProplist:= augProplist(currentProplist,'modemap,newModemapList) + newProplist':= augProplist(newProplist,"FLUID",true) + unErrorRef op + --There may have been a warning about op having no value + addBinding(op,newProplist',e) + +mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == + entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] + member(entry,curModemapList) => curModemapList + (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => + $forceAdd => mergeModemap(entry,curModemapList,e) + opred=true => curModemapList + if pred^=true and pred^=opred then pred:= ["OR",pred,opred] + [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x + + --if new modemap less general, put at end; otherwise, at front + for x in curModemapList] + $InteractiveMode => insertModemap(entry,curModemapList) + mergeModemap(entry,curModemapList,e) + +mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == + for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat + mc=mc' or isSuperDomain(mc',mc,e) => + newmm:= nil + mm:= modemapList + while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) + if (mc=mc') and (sig=sig') then + --We only need one of these, unless the conditions are hairy + not $forceAdd and TruthP pred' => + entry:=nil + --the new predicate buys us nothing + return modemapList + TruthP pred => mmtail:=rest mmtail + --the thing we matched against is useless, by comparison + modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail]) + entry:= nil + return modemapList + if entry then [:modemapList,entry] else modemapList + +-- next definition RPLACs, and hence causes problems. +-- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled +--mergeModemap(entry:=((mc,:sig),:.),modemapList,e) == +-- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do +-- mc=mc' or isSuperDomain(mc',mc,e) => +-- RPLACD(mmtail,(first mmtail,: rest mmtail)) +-- RPLACA(mmtail,entry) +-- entry := nil +-- return modemapList +-- if entry then (:modemapList,entry) else modemapList + +isSuperDomain(domainForm,domainForm',e) == + isSubset(domainForm',domainForm,e) => true + domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep + LASSOC(opOf domainForm',get(domainForm,"SubDomain",e)) + +--substituteForRep(entry is [[mc,:sig],:.],curModemapList) == +-- --change 'Rep to "$" unless the resulting signature is already in $ +-- member(entry':= substitute("$",'Rep,entry),curModemapList) => +-- [entry,:curModemapList] +-- [entry,entry',:curModemapList] + +addNewDomain(domain,e) == + augModemapsFromDomain(domain,domain,e) + +augModemapsFromDomain(name,functorForm,e) == + member(KAR name or name,$DummyFunctorNames) => e + name=$Category or isCategoryForm(name,e) => e + member(name,curDomainsInScope:= getDomainsInScope e) => e + if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then + e:= addNewDomain(first u,e) + --need code to handle parameterized SuperDomains + if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e) + if name is ["Union",:dl] then for d in stripUnionTags dl + repeat e:= addDomain(d,e) + augModemapsFromDomain1(name,functorForm,e) + --see LISPLIB BOOT + +substituteCategoryArguments(argl,catform) == + argl:= substitute("$$","$",argl) + arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] + SUBLIS(arglAssoc,catform) + + --Called, by compDefineFunctor, to add modemaps for $ that may + --be equivalent to those of Rep. We must check that these + --operations are not being redefined. +augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) + [repFnAlist,e]:= evalAndSub('Rep,'Rep,repDefn,getmode(repDefn,e),e) + catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) + compilerMessage ["Adding ",domainName," modemaps"] + e:= putDomainsInScope(domainName,e) + $base:= 4 + for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat + u:=assoc(SUBST('Rep,domainName,lhs),repFnAlist) + u and not AMFCR_,redefinedList(op,functorBody) => + fnsel':=CADDR u + e:= addModemap(op,domainName,sig,cond,fnsel',e) + e:= addModemap(op,domainName,sig,cond,fnsel,e) + e + +AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] + +AMFCR_,redefined(opname,u) == + not(u is [op,:l]) => nil + op = 'DEF => opname = CAAR l + MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l) + op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l] + +augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == + [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) + -- catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) + -- catform appears not to be used, so why set it? + --if ^$InteractiveMode then + compilerMessage ["Adding ",domainName," modemaps"] + e:= putDomainsInScope(domainName,e) + $base:= 4 + condlist:=[] + for [[op,sig,:.],cond,fnsel] in fnAlist repeat +-- e:= addModemap(op,domainName,sig,cond,fnsel,e) +---------next 5 lines commented out to avoid wasting time checking knownInfo on +---------conditions attached to each modemap being added, takes a very long time +---------instead conditions will be checked when maps are actually used + --v:=ASSOC(cond,condlist) => + -- e:= addModemapKnown(op,domainName,sig,CDR v,fnsel,e) + --$e:local := e -- $e is used by knownInfo + --if knownInfo cond then cond1:=true else cond1:=cond + --condlist:=[[cond,:cond1],:condlist] + e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 +-- for u in sig | (not member(u,$DomainsInScope)) and +-- (not atom u) and +-- (not isCategoryForm(u,e)) do +-- e:= addNewDomain(u,e) + e + +--subCatParametersInto(domainForm,catForm,e) == +-- -- JHD 08/08/84 perhaps we are fortunate that it is not used +-- --this is particularly dirty and should be cleaned up, say, by wrapping +-- -- an appropriate lambda expression around mapping forms +-- domainForm is [op,:l] and l => +-- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) +-- catForm + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +evalAndSub(domainName,viewName,functorForm,form,$e) == + $lhsOfColon: local:= domainName + isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] + --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 + if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) + opAlist:= getOperationAlist(domainName,functorForm,form) + substAlist:= substNames(domainName,viewName,functorForm,opAlist) + [substitute("$","$$",substAlist),$e] + +getOperationAlist(name,functorForm,form) == + if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] +-- (null isConstructorForm functorForm) and (u:= isFunctor functorForm) + (u:= isFunctor functorForm) and not + ($insideFunctorIfTrue and first functorForm=first $functorForm) => u + $insideFunctorIfTrue and name="$" => + ($domainShell => $domainShell.(1); systemError '"$ has no shell now") + T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) + stackMessage ["not a category form: ",form] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +substNames(domainName,viewName,functorForm,catForm) == + EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, + -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred, + -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm]) + -- following calls to SUBSTQ must copy to save RPLAC's in + -- putInLocalDomainReferences + [[:SUBSTQ(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)] + for [:modemapform,fnsel] in catForm]) + +compCat(form is [functorName,:argl],m,e) == + fn:= GETL(functorName,"makeFunctionList") or return nil + [funList,e]:= FUNCALL(fn,form,form,e) + catForm:= + ["Join",'(SetCategory),["CATEGORY","domain",: + [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]] + --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not + --sure if it uses any of the other signatures(see extendsCategoryForm) + [form,catForm,e] + +--------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) +addConstructorModemaps(name,form is [functorName,:.],e) == + $InteractiveMode: local:= nil + e:= putDomainsInScope(name,e) --frame + fn := GETL(functorName,"makeFunctionList") + [funList,e]:= FUNCALL(fn,name,form,e) + for [op,sig,opcode] in funList repeat + e:= addModemap(op,name,sig,true,opcode,e) + e + + +--The way XLAMs work: +-- ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) + +getDomainsInScope e == + $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope + get("$DomainsInScope","special",e) + +putDomainsInScope(x,e) == + l:= getDomainsInScope e + if member(x,l) then SAY("****** Domain: ",x," already in scope") + newValue:= [x,:delete(x,l)] + $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) + put("$DomainsInScope","special",newValue,e) + diff --git a/src/interp/modemap.boot.pamphlet b/src/interp/modemap.boot.pamphlet deleted file mode 100644 index a493a61f..00000000 --- a/src/interp/modemap.boot.pamphlet +++ /dev/null @@ -1,399 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\$SPAD/src/interp modemap.boot} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"c-util" -import '"info" -)package "BOOT" - ---% EXTERNAL ROUTINES - ---These functions are called from outside this file to add a domain --- or to get the current domains in scope; - -addDomain(domain,e) == - atom domain => - EQ(domain,"$EmptyMode") => e - EQ(domain,"$NoValueMode") => e - not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and - EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e - MEMQ(domain,getDomainsInScope e) => e - isLiteral(domain,e) => e - addNewDomain(domain,e) - (name:= first domain)='Category => e - domainMember(domain,getDomainsInScope e) => e - getmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e)=> - addNewDomain(domain,e) - -- constructor? test needed for domains compiled with $bootStrapMode=true - isFunctor name or constructor? name => addNewDomain(domain,e) - if not isCategoryForm(domain,e) and - not member(name,'(Mapping CATEGORY)) then - unknownTypeError name - e --is not a functor - -domainMember(dom,domList) == or/[modeEqual(dom,d) for d in domList] - ---% MODEMAP FUNCTIONS - ---getTargetMode(x is [op,:argl],e) == --- CASES(#(mml:= getModemapList(op,#argl,e)), --- (1 => --- ([[.,target,:.],:.]:= first mml; substituteForFormalArguments(argl,target)) --- ; 0 => MOAN(x," has no modemap"); systemError [x," has duplicate modemaps"])) - -getModemap(x is [op,:.],e) == - for modemap in get(op,'modemap,e) repeat - if u:= compApplyModemap(x,modemap,e,nil) then return - ([.,.,sl]:= u; SUBLIS(sl,modemap)) - -getUniqueSignature(form,e) == - [[.,:sig],:.]:= getUniqueModemap(first form,#rest form,e) or return nil - sig - -getUniqueModemap(op,numOfArgs,e) == - 1=#(mml:= getModemapList(op,numOfArgs,e)) => first mml - 1<#mml => - stackWarning [numOfArgs,'" argument form of: ",op, - '" has more than one modemap"] - first mml - nil - -getModemapList(op,numOfArgs,e) == - op is ['elt,D,op'] => getModemapListFromDomain(op',numOfArgs,D,e) - [mm for - (mm:= [[.,.,:sigl],:.]) in get(op,'modemap,e) | numOfArgs=#sigl] - -getModemapListFromDomain(op,numOfArgs,D,e) == - [mm - for (mm:= [[dc,:sig],:.]) in get(op,'modemap,e) | dc=D and #rest sig= - numOfArgs] - - -insertModemap(new,mmList) == - null mmList => [new] ---isMoreSpecific(new,old:= first mmList) => [new,:mmList] ---[old,:insertModemap(new,rest mmList)] - [new,:mmList] - -addModemap(op,mc,sig,pred,fn,$e) == - $InteractiveMode => $e - if knownInfo pred then pred:=true - $insideCapsuleFunctionIfTrue=true => - $CapsuleModemapFrame := - addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) - $e - addModemap0(op,mc,sig,pred,fn,$e) - -addModemapKnown(op,mc,sig,pred,fn,$e) == --- if knownInfo pred then pred:=true --- that line is handled elsewhere - $insideCapsuleFunctionIfTrue=true => - $CapsuleModemapFrame := - addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame) - $e - addModemap0(op,mc,sig,pred,fn,$e) - -addModemap0(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - $functorForm is ['CategoryDefaults,:.] and mc="$" => e - --don't put CD modemaps into environment - --fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps - -- breaks -:($,$)->U($,failed) in DP - op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e) - addModemap1(op,mc,sig,pred,fn,e) - -addEltModemap(op,mc,sig,pred,fn,e) == - --hack to change selectors from strings to identifiers; and to - --add flag identifiers as literals in the envir - op='elt and sig is [:lt,sel] => - STRINGP sel => - id:= INTERN sel - if $insideCapsuleFunctionIfTrue=true - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id],pred,fn,e) - -- atom sel => systemErrorHere '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - op='setelt and sig is [:lt,sel,v] => - STRINGP sel => - id:= INTERN sel - if $insideCapsuleFunctionIfTrue=true - then $e:= makeLiteral(id,$e) - else e:= makeLiteral(id,e) - addModemap1(op,mc,[:lt,id,v],pred,fn,e) - -- atom sel => systemError '"addEltModemap" - addModemap1(op,mc,sig,pred,fn,e) - systemErrorHere '"addEltModemap" - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -addModemap1(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - if mc='Rep then - if fn is [kind,'Rep,.] and - -- save old sig for NRUNTIME - (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] - sig:= substitute("$",'Rep,sig) - currentProplist:= getProplist(op,e) or nil - newModemapList:= - mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) - newProplist:= augProplist(currentProplist,'modemap,newModemapList) - newProplist':= augProplist(newProplist,"FLUID",true) - unErrorRef op - --There may have been a warning about op having no value - addBinding(op,newProplist',e) - -mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == - entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil] - member(entry,curModemapList) => curModemapList - (oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] => - $forceAdd => mergeModemap(entry,curModemapList,e) - opred=true => curModemapList - if pred^=true and pred^=opred then pred:= ["OR",pred,opred] - [if x=oldMap then [map,[pred,fn],:filenameOrNil] else x - - --if new modemap less general, put at end; otherwise, at front - for x in curModemapList] - $InteractiveMode => insertModemap(entry,curModemapList) - mergeModemap(entry,curModemapList,e) - -mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == - for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat - mc=mc' or isSuperDomain(mc',mc,e) => - newmm:= nil - mm:= modemapList - while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) - if (mc=mc') and (sig=sig') then - --We only need one of these, unless the conditions are hairy - not $forceAdd and TruthP pred' => - entry:=nil - --the new predicate buys us nothing - return modemapList - TruthP pred => mmtail:=rest mmtail - --the thing we matched against is useless, by comparison - modemapList:= NCONC(NREVERSE newmm,[entry,:mmtail]) - entry:= nil - return modemapList - if entry then [:modemapList,entry] else modemapList - --- next definition RPLACs, and hence causes problems. --- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled ---mergeModemap(entry:=((mc,:sig),:.),modemapList,e) == --- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do --- mc=mc' or isSuperDomain(mc',mc,e) => --- RPLACD(mmtail,(first mmtail,: rest mmtail)) --- RPLACA(mmtail,entry) --- entry := nil --- return modemapList --- if entry then (:modemapList,entry) else modemapList - -isSuperDomain(domainForm,domainForm',e) == - isSubset(domainForm',domainForm,e) => true - domainForm='Rep and domainForm'="$" => true --regard $ as a subdomain of Rep - LASSOC(opOf domainForm',get(domainForm,"SubDomain",e)) - ---substituteForRep(entry is [[mc,:sig],:.],curModemapList) == --- --change 'Rep to "$" unless the resulting signature is already in $ --- member(entry':= substitute("$",'Rep,entry),curModemapList) => --- [entry,:curModemapList] --- [entry,entry',:curModemapList] - -addNewDomain(domain,e) == - augModemapsFromDomain(domain,domain,e) - -augModemapsFromDomain(name,functorForm,e) == - member(KAR name or name,$DummyFunctorNames) => e - name=$Category or isCategoryForm(name,e) => e - member(name,curDomainsInScope:= getDomainsInScope e) => e - if u:= GETDATABASE(opOf functorForm,'SUPERDOMAIN) then - e:= addNewDomain(first u,e) - --need code to handle parameterized SuperDomains - if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e) - if name is ["Union",:dl] then for d in stripUnionTags dl - repeat e:= addDomain(d,e) - augModemapsFromDomain1(name,functorForm,e) - --see LISPLIB BOOT - -substituteCategoryArguments(argl,catform) == - argl:= substitute("$$","$",argl) - arglAssoc:= [[INTERNL("#",STRINGIMAGE i),:a] for i in 1.. for a in argl] - SUBLIS(arglAssoc,catform) - - --Called, by compDefineFunctor, to add modemaps for $ that may - --be equivalent to those of Rep. We must check that these - --operations are not being redefined. -augModemapsFromCategoryRep(domainName,repDefn,functorBody,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainName,domainName,categoryForm,e) - [repFnAlist,e]:= evalAndSub('Rep,'Rep,repDefn,getmode(repDefn,e),e) - catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) - compilerMessage ["Adding ",domainName," modemaps"] - e:= putDomainsInScope(domainName,e) - $base:= 4 - for [lhs:=[op,sig,:.],cond,fnsel] in fnAlist repeat - u:=assoc(SUBST('Rep,domainName,lhs),repFnAlist) - u and not AMFCR_,redefinedList(op,functorBody) => - fnsel':=CADDR u - e:= addModemap(op,domainName,sig,cond,fnsel',e) - e:= addModemap(op,domainName,sig,cond,fnsel,e) - e - -AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l] - -AMFCR_,redefined(opname,u) == - not(u is [op,:l]) => nil - op = 'DEF => opname = CAAR l - MEMQ(op,'(PROGN SEQ)) => AMFCR_,redefinedList(opname,l) - op = 'COND => "OR"/[AMFCR_,redefinedList(opname,CDR u) for u in l] - -augModemapsFromCategory(domainName,domainView,functorForm,categoryForm,e) == - [fnAlist,e]:= evalAndSub(domainName,domainView,functorForm,categoryForm,e) - -- catform:= (isCategory categoryForm => categoryForm.(0); categoryForm) - -- catform appears not to be used, so why set it? - --if ^$InteractiveMode then - compilerMessage ["Adding ",domainName," modemaps"] - e:= putDomainsInScope(domainName,e) - $base:= 4 - condlist:=[] - for [[op,sig,:.],cond,fnsel] in fnAlist repeat --- e:= addModemap(op,domainName,sig,cond,fnsel,e) ----------next 5 lines commented out to avoid wasting time checking knownInfo on ----------conditions attached to each modemap being added, takes a very long time ----------instead conditions will be checked when maps are actually used - --v:=ASSOC(cond,condlist) => - -- e:= addModemapKnown(op,domainName,sig,CDR v,fnsel,e) - --$e:local := e -- $e is used by knownInfo - --if knownInfo cond then cond1:=true else cond1:=cond - --condlist:=[[cond,:cond1],:condlist] - e:= addModemapKnown(op,domainName,sig,cond,fnsel,e) -- cond was cond1 --- for u in sig | (not member(u,$DomainsInScope)) and --- (not atom u) and --- (not isCategoryForm(u,e)) do --- e:= addNewDomain(u,e) - e - ---subCatParametersInto(domainForm,catForm,e) == --- -- JHD 08/08/84 perhaps we are fortunate that it is not used --- --this is particularly dirty and should be cleaned up, say, by wrapping --- -- an appropriate lambda expression around mapping forms --- domainForm is [op,:l] and l => --- get(op,'modemap,e) is [[[mc,:.],:.]] => SUBLIS(PAIR(rest mc,l),catForm) --- catForm - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -evalAndSub(domainName,viewName,functorForm,form,$e) == - $lhsOfColon: local:= domainName - isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] - --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 - if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) - opAlist:= getOperationAlist(domainName,functorForm,form) - substAlist:= substNames(domainName,viewName,functorForm,opAlist) - [substitute("$","$$",substAlist),$e] - -getOperationAlist(name,functorForm,form) == - if atom name and GETDATABASE(name,'NILADIC) then functorForm:= [functorForm] --- (null isConstructorForm functorForm) and (u:= isFunctor functorForm) - (u:= isFunctor functorForm) and not - ($insideFunctorIfTrue and first functorForm=first $functorForm) => u - $insideFunctorIfTrue and name="$" => - ($domainShell => $domainShell.(1); systemError '"$ has no shell now") - T:= compMakeCategoryObject(form,$e) => ([.,.,$e]:= T; T.expr.(1)) - stackMessage ["not a category form: ",form] - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -substNames(domainName,viewName,functorForm,catForm) == - EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, - -- [[[op,if KAR fnsel="PAC" then sig else SUBSTQ(domainName,"$",sig),:x],pred, - -- SUBSTQ(viewName,"$",fnsel)] for [[op,sig,:x],pred,fnsel] in catForm]) - -- following calls to SUBSTQ must copy to save RPLAC's in - -- putInLocalDomainReferences - [[:SUBSTQ(domainName,"$",modemapform),SUBSTQ(viewName,"$",fnsel)] - for [:modemapform,fnsel] in catForm]) - -compCat(form is [functorName,:argl],m,e) == - fn:= GETL(functorName,"makeFunctionList") or return nil - [funList,e]:= FUNCALL(fn,form,form,e) - catForm:= - ["Join",'(SetCategory),["CATEGORY","domain",: - [["SIGNATURE",op,sig] for [op,sig,.] in funList | op^="="]]] - --RDJ: for coercion purposes, it necessary to know it's a Set; I'm not - --sure if it uses any of the other signatures(see extendsCategoryForm) - [form,catForm,e] - ---------------------> NEW DEFINITION (override in xruncomp.boot.pamphlet) -addConstructorModemaps(name,form is [functorName,:.],e) == - $InteractiveMode: local:= nil - e:= putDomainsInScope(name,e) --frame - fn := GETL(functorName,"makeFunctionList") - [funList,e]:= FUNCALL(fn,name,form,e) - for [op,sig,opcode] in funList repeat - e:= addModemap(op,name,sig,true,opcode,e) - e - - ---The way XLAMs work: --- ((XLAM ($1 $2 $3) (SETELT $1 0 $3)) X "c" V) ==> (SETELT X 0 V) - -getDomainsInScope e == - $insideCapsuleFunctionIfTrue=true => $CapsuleDomainsInScope - get("$DomainsInScope","special",e) - -putDomainsInScope(x,e) == - l:= getDomainsInScope e - if member(x,l) then SAY("****** Domain: ",x," already in scope") - newValue:= [x,:delete(x,l)] - $insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e) - put("$DomainsInScope","special",newValue,e) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/msgdb.boot b/src/interp/msgdb.boot new file mode 100644 index 00000000..8c38b9d1 --- /dev/null +++ b/src/interp/msgdb.boot @@ -0,0 +1,1055 @@ +-- 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. + + +--% Description of Messages + +--% Axiom messages are read from a flat file database and returned +--% as one long string. They are preceded in the database by a key and +--% this is how they are referenced from code. For example, one key is +--% S2IL0001 which means: +--% S2 Scratchpad II designation +--% I from the interpreter +--% L originally from LISPLIB BOOT +--% 0001 a sequence number + +--% Each message may contain formatting codes and and parameter codes. +--% The formatting codes are: +--% %b turn on bright printing +--% %ceoff turn off centering +--% %ceon turn on centering +--% %d turn off bright printing +--% %f user defined printing +--% %i start indentation of 3 more spaces +--% %l start a new line +--% %m math-print an expression +--% %rjoff turn off right justification (actually ragged left) +--% %rjon turn on right justification (actually ragged left) +--% %s pretty-print as an S-expression +--% %u unindent 3 spaces +--% %x# insert # spaces + +--% The parameter codes look like %1, %2b, %3p, %4m, %5bp, %6s where the +--% digit is the parameter number ans the letters following indicate +--% additional formatting. You can indicate as many additional formatting +--% qualifiers as you like, to the degree they make sense. The "p" code +--% means to call prefix2String on the parameter, a standard way of +--% printing abbreviated types. The "P" operator maps prefix2String over +--% its arguments. The "o" operation formats the argument as an operation +--% name. "b" means to print that parameter in +--% a bold (bright) font. "c" means to center that parameter on a +--% new line. "f" means that the parameter is a list [fn, :args] +--% and that "fn" is to be called on "args" to get the text. "r" means +--% to right justify (ragged left) the argument. + +--% Look in the file with the name defined in $defaultMsgDatabaseName +--% above for examples. + + +import '"g-util" +)package "BOOT" + +--% Message Database Code and Message Utility Functions + +$msgDatabase := NIL +$cacheMessages := 'T -- for debugging purposes +$msgAlist := NIL +$msgDatabaseName := NIL +$testingErrorPrefix := '"Daly Bug" + +$texFormatting := false + +--% Accessing the Database + +string2Words l == + i := 0 + [w while wordFrom(l,i) is [w,i]] + +wordFrom(l,i) == + maxIndex := MAXINDEX l + k := or/[j for j in i..maxIndex | l.j ^= char ('_ ) ] or return nil + buf := '"" + while k < maxIndex and (c := l.k) ^= char ('_ ) repeat + ch := + c = char '__ => l.(k := 1+k) --this may exceed bounds + c + buf := STRCONC(buf,ch) + k := k + 1 + if k = maxIndex and (c := l.k) ^= char ('_ ) then buf := STRCONC(buf,c) + [buf,k+1] + +getKeyedMsg key == fetchKeyedMsg(key,false) + +--% Formatting and Printing Keyed Messages + +segmentKeyedMsg(msg) == string2Words msg + +segmentedMsgPreprocess x == + ATOM x => x + [head,:tail] := x + center := rightJust := NIL + if head in '(%ceon "%ceon") then center := true + if head in '(%rjon "%rjon") then rightJust := true + center or rightJust => + -- start collecting terms + y := NIL + ok := true + while tail and ok repeat + [t,:tail] := tail + t in '(%ceoff "%ceoff" %rjoff "%rjoff") => ok := NIL + y := CONS(segmentedMsgPreprocess t,y) + head1 := [(center => '"%ce"; '"%rj"),:NREVERSE y] + NULL tail => [head1] + [head1,:segmentedMsgPreprocess tail] + head1 := segmentedMsgPreprocess head + tail1 := segmentedMsgPreprocess tail + EQ(head,head1) and EQ(tail,tail1) => x + [head1,:tail1] + +removeAttributes msg == + --takes a segmented message and returns it with the attributes + --separted. + first msg ^= '"%atbeg" => + [msg,NIL] + attList := [] + until item = '"%atend" repeat + msg := rest msg + item := first msg + attList := [INTERN item,:attList] + msg := rest msg + attList := rest attList + [msg,attList] + +substituteSegmentedMsg(msg,args) == + -- this does substitution of the parameters + l := NIL + nargs := #args + for x in segmentedMsgPreprocess msg repeat + -- x is a list + PAIRP x => + l := cons(substituteSegmentedMsg(x,args),l) + c := x.0 + n := STRINGLENGTH x + + -- x is a special case + (n > 2) and (c = "%") and (x.1 = "k") => + l := NCONC(NREVERSE pkey SUBSTRING(x,2,NIL),l) + + -- ?name gets replaced by '"Push PF10" or '"Type >b (enter)" + (x.0 = char "?") and n > 1 and (v := pushOrTypeFuture(INTERN x,nil)) => + l := NCONC(NREVERSE v,l) + + -- x requires parameter substitution + (x.0 = char "%") and (n > 1) and (DIGITP x.1) => + a := DIG2FIX x.1 + arg := + a <= nargs => args.(a-1) + '"???" + -- now pull out qualifiers + q := NIL + for i in 2..(n-1) repeat q := cons(x.i,q) + -- Note 'f processing must come first. + if MEMQ(char 'f,q) then + arg := + PAIRP arg => APPLY(first arg, rest arg) + arg + if MEMQ(char 'm,q) then arg := [['"%m",:arg]] + if MEMQ(char 's,q) then arg := [['"%s",:arg]] + if MEMQ(char 'p,q) then + $texFormatting => arg := prefix2StringAsTeX arg + arg := prefix2String arg + if MEMQ(char 'P,q) then + $texFormatting => arg := [prefix2StringAsTeX x for x in arg] + arg := [prefix2String x for x in arg] + if MEMQ(char 'o, q) and $texFormatting then arg := operationLink(arg) + + if MEMQ(char 'c,q) then arg := [['"%ce",:arg]] + if MEMQ(char 'r,q) then arg := [['"%rj",:arg]] + + if MEMQ(char 'l,q) then l := cons('"%l",l) + if MEMQ(char 'b,q) then l := cons('"%b",l) + --we splice in arguments that are lists + --if y is not specified, then the adding of blanks is + --stifled after the first item in the list until the + --end of the list. (using %n and %y) + l := + PAIRP(arg) => + MEMQ(char 'y,q) or (CAR arg = '"%y") or ((LENGTH arg) = 1) => + APPEND(REVERSE arg, l) + head := first arg + tail := rest arg + ['"%y",:APPEND(REVERSE tail, ['"%n",head,:l ]) ] + cons(arg,l) + if MEMQ(char 'b,q) then l := cons('"%d",l) + for ch in '(_. _, _! _: _; _?) repeat + if MEMQ(char ch,q) then l := cons(ch,l) + + --x is a plain word + l := cons(x,l) + addBlanks NREVERSE l + +addBlanks msg == + -- adds proper blanks + null PAIRP msg => msg + null msg => msg + LENGTH msg = 1 => msg + blanksOff := false + x := first msg + if x = '"%n" then + blanksOff := true + msg1 := [] + else + msg1 := LIST x + blank := '" " + for y in rest msg repeat + y in '("%n" %n) => blanksOff := true + y in '("%y" %y) => blanksOff := false + if noBlankAfterP x or noBlankBeforeP y or blanksOff then + msg1 := [y,:msg1] + else + msg1 := [y,blank,:msg1] + x := y + NREVERSE msg1 + + +SETANDFILEQ($msgdbPrims,'( %b %d %l %i %u %U %n %x %ce %rj "%U" "%b" "%d" "%l" "%i" "%u" "%U" "%n" "%x" "%ce" "%rj")) +SETANDFILEQ($msgdbPunct,'(_. _, _! _: _; _? _] _) "." "," "!" ":" ";" "?" "]" ")" )) +SETANDFILEQ($msgdbNoBlanksBeforeGroup,['" ", " ", '"%", "%",_ + :$msgdbPrims, :$msgdbPunct]) +SETANDFILEQ($msgdbListPrims,'(%m %s %ce %rj "%m" "%s" "%ce" "%rj")) + +noBlankBeforeP word== + INTP word => false + word in $msgdbNoBlanksBeforeGroup => true + if CVECP word and SIZE word > 1 then + word.0 = char '% and word.1 = char 'x => return true + word.0 = char " " => return true + (PAIRP word) and (CAR word in $msgdbListPrims) => true + false + +$msgdbPunct := '(_[ _( "[" "(" ) +SETANDFILEQ($msgdbNoBlanksAfterGroup,['" ", " ",'"%" ,"%",_ + :$msgdbPrims,:$msgdbPunct]) + +noBlankAfterP word== + INTP word => false + word in $msgdbNoBlanksAfterGroup => true + if CVECP word and (s := SIZE word) > 1 then + word.0 = char '% and word.1 = char 'x => return true + word.(s-1) = char " " => return true + (PAIRP word) and (CAR word in $msgdbListPrims) => true + false + +cleanUpSegmentedMsg msg == + -- removes any junk like double blanks + -- takes a reversed msg and puts it in the correct order + null PAIRP msg => msg + blanks := ['" "," "] + haveBlank := NIL + prims := + '(%b %d %l %i %u %m %ce %rj _ + "%b" "%d" "%l" "%i" "%m" "%u" "%ce" "%rj") + msg1 := NIL + for x in msg repeat + if haveBlank and ((x in blanks) or (x in prims)) then + msg1 := CDR msg1 + msg1 := cons(x,msg1) + haveBlank := (x in blanks => true; NIL) + msg1 + +operationLink name == + FORMAT(nil, '"\lispLink{\verb!(|oSearch| _"~a_")!}{~a}", + name, + escapeSpecialChars STRINGIMAGE name) + +---------------------------------------- +sayPatternMsg(msg,args) == + msg := segmentKeyedMsg msg + msg := substituteSegmentedMsg(msg,args) + sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) + +throwPatternMsg(key,args) == + sayMSG '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayPatternMsg(key,args) + spadThrow() + +sayKeyedMsgAsTeX(key, args) == + $texFormatting: fluid := true + sayKeyedMsgLocal(key, args) + +sayKeyedMsg(key,args) == + $texFormatting: fluid := false + sayKeyedMsgLocal(key, args) + +sayKeyedMsgLocal(key, args) == + msg := segmentKeyedMsg getKeyedMsg key + msg := substituteSegmentedMsg(msg,args) + if $displayMsgNumber then msg := ['"%b",key,":",'"%d",:msg] + msg' := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) + if $printMsgsToFile then sayMSG2File msg' + sayMSG msg' + +throwKeyedErrorMsg(kind,key,args) == + BUMPERRORCOUNT kind + sayMSG '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayKeyedMsg(key,args) + spadThrow() + +throwKeyedMsgSP(key,args,atree) == + if atree and (sp := getSrcPos(atree)) then + sayMSG '" " + srcPosDisplay(sp) + throwKeyedMsg(key,args) + +throwKeyedMsg(key,args) == + $saturn => saturnThrowKeyedMsg(key, args) + throwKeyedMsg1(key, args) + +saturnThrowKeyedMsg(key,args) == + SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) + last := pushSatOutput("line") + sayString '"\bgroup\color{red}\begin{list}\item{} " + sayKeyedMsgAsTeX(key,args) + sayString '"\end{list}\egroup" + popSatOutput(last) + spadThrow() + +throwKeyedMsg1(key,args) == + SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) + sayMSG '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayKeyedMsg(key,args) + spadThrow() + +throwListOfKeyedMsgs(descKey,descArgs,l) == + -- idea is that descKey and descArgs are the message describing + -- what the list is about and l is a list of [key,args] messages + -- the messages in the list are numbered and should have a %1 as + -- the first token in the message text. + sayMSG '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayKeyedMsg(descKey,descArgs) + sayMSG '" " + for [key,args] in l for i in 1.. repeat + n := STRCONC(object2String i,'".") + sayKeyedMsg(key,[n,:args]) + spadThrow() + +-- breakKeyedMsg is like throwKeyedMsg except that the user is given +-- a chance to play around in a break loop if $BreakMode is not 'nobreak + +breakKeyedMsg(key,args) == + BUMPERRORCOUNT "semantic" + sayKeyedMsg(key,args) + handleLispBreakLoop($BreakMode) + +keyedSystemError(key,args) == + $saturn => saturnKeyedSystemError(key, args) + keyedSystemError1(key, args) + +saturnKeyedSystemError(key, args) == + SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) + sayString '"\bgroup\color{red}" + sayString '"\begin{verbatim}" + sayKeyedMsg("S2GE0000",NIL) + BUMPERRORCOUNT "semantic" + sayKeyedMsgAsTeX(key,args) + sayString '"\end{verbatim}" + sayString '"\egroup" + handleLispBreakLoop($BreakMode) + +keyedSystemError1(key,args) == + sayKeyedMsg("S2GE0000",NIL) + breakKeyedMsg(key,args) + +-- these 2 functions control the mode of saturn output. +-- having the stream writing functions control this would +-- be better (eg. sayText, sayCommands) + +pushSatOutput(arg) == + $saturnMode = arg => arg + was := $saturnMode + arg = "verb" => + $saturnMode := "verb" + sayString '"\begin{verbatim}" + was + arg = "line" => + $saturnMode := "line" + sayString '"\end{verbatim}" + was + sayString FORMAT(nil, '"What is: ~a", $saturnMode) + $saturnMode + +popSatOutput(newmode) == + newmode = $saturnMode => nil + newmode = "verb" => + $saturnMode := "verb" + sayString '"\begin{verbatim}" + newmode = "line" => + $saturnMode := "line" + sayString '"\end{verbatim}" + sayString FORMAT(nil, '"What is: ~a", $saturnMode) + $saturnMode + +systemErrorHere functionName == + keyedSystemError("S2GE0017",[functionName]) + +isKeyedMsgInDb(key,dbName) == + $msgDatabaseName : fluid := pathname dbName + fetchKeyedMsg(key,true) + +getKeyedMsgInDb(key,dbName) == + $msgDatabaseName : fluid := pathname dbName + fetchKeyedMsg(key,false) + +sayKeyedMsgFromDb(key,args,dbName) == + $msgDatabaseName : fluid := pathname dbName + msg := segmentKeyedMsg getKeyedMsg key + msg := substituteSegmentedMsg(msg,args) + if $displayMsgNumber then msg := ['"%b",key,":",'%d,:msg] +--sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) + u := flowSegmentedMsg(msg,$LINELENGTH,3) + sayBrightly u + +returnStLFromKey(key,argL,:optDbN) == + savedDbN := $msgDatabaseName + if IFCAR optDbN then + $msgDatabaseName := pathname CAR optDbN + text := fetchKeyedMsg(key, false) + $msgDatabaseName := savedDbN + text := segmentKeyedMsg text + text := substituteSegmentedMsg(text,argL) + +throwKeyedMsgFromDb(key,args,dbName) == + sayMSG '" " + if $testingSystem then sayMSG $testingErrorPrefix + sayKeyedMsgFromDb(key,args,dbName) + spadThrow() + +queryUserKeyedMsg(key,args) == + -- display message and return reply + conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (MODE . INPUT)),120,0) + sayKeyedMsg(key,args) + ans := READ_-LINE conStream + SHUT conStream + ans + +flowSegmentedMsg(msg, len, offset) == + -- tries to break a sayBrightly-type input msg into multiple + -- lines, with offset and given length. + -- msgs that are entirely centered or right justified are not flowed + msg is [[ce,:.]] and ce in '(%ce "%ce" %rj "%rj") => msg + + -- if we are formatting latex, then we assume + -- that nothing needs to be done + $texFormatting => msg + -- msgs that are entirely centered are not flowed + msg is [[ce,:.]] and ListMember?(ce,'(%ce "%ce")) => msg + + potentialMarg := 0 + actualMarg := 0 + + off := (offset <= 0 => '""; fillerSpaces(offset,'" ")) + off1:= (offset <= 1 => '""; fillerSpaces(offset-1,'" ")) + firstLine := true + + PAIRP msg => + lnl := offset + if msg is [a,:.] and a in '(%b %d _ "%b" "%d" " ") then + nl := [off1] + lnl := lnl - 1 + else nl := [off] + for f in msg repeat + f in '("%l" %l) => + actualMarg := potentialMarg + if lnl = 99999 then nl := ['%l,:nl] + lnl := 99999 + PAIRP(f) and CAR(f) in '("%m" %m '%ce "%ce" %rj "%rj") => + actualMarg := potentialMarg + nl := [f,'%l,:nl] + lnl := 199999 + f in '("%i" %i ) => + potentialMarg := potentialMarg + 3 + nl := [f,:nl] + PAIRP(f) and CAR(f) in '("%t" %t) => + potentialMarg := potentialMarg + CDR f + nl := [f,:nl] + sbl := sayBrightlyLength f + tot := lnl + offset + sbl + actualMarg + if firstLine then + firstLine := false + offset := offset + offset + off1 := STRCONC(off, off1) + off := STRCONC(off, off) + if (tot <= len) or (sbl = 1 and tot = len) then + nl := [f,:nl] + lnl := lnl + sbl + else + f in '(%b %d _ "%b" "%d" " ") => + nl := [f,off1,'%l,:nl] + actualMarg := potentialMarg + lnl := -1 + offset + sbl + nl := [f,off,'%l,:nl] + lnl := offset + sbl + concat nreverse nl + concat('%l,off,msg) + +--% Other handy things + +keyedMsgCompFailure(key,args) == + -- Called when compilation fails in such a way that interpret-code + -- mode might be of some use. + not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) + if not($Coerce) and $reportInterpOnly then + sayKeyedMsg(key,args) + sayKeyedMsg("S2IB0009",NIL) + null $compilingMap => THROW('loopCompiler,'tryInterpOnly) + THROW('mapCompiler,'tryInterpOnly) + +keyedMsgCompFailureSP(key,args,atree) == + -- Called when compilation fails in such a way that interpret-code + -- mode might be of some use. + not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) + if not($Coerce) and $reportInterpOnly then + if atree and (sp := getSrcPos(atree)) then + sayMSG '" " + srcPosDisplay(sp) + sayKeyedMsg(key,args) + sayKeyedMsg("S2IB0009",NIL) + null $compilingMap => THROW('loopCompiler,'tryInterpOnly) + THROW('mapCompiler,'tryInterpOnly) + +throwKeyedMsgCannotCoerceWithValue(val,t1,t2) == + null (val' := coerceInteractive(objNew(val,t1),$OutputForm)) => + throwKeyedMsg("S2IC0002",[t1,t2]) + val' := objValUnwrap(val') + throwKeyedMsg("S2IC0003",[t1,t2,val']) + +--% Some Standard Message Printing Functions + +bright x == ['"%b",:(PAIRP(x) and NULL CDR LASTNODE x => x; [x]),'"%d"] +--bright x == ['%b,:(ATOM x => [x]; x),'%d] + +mkMessage msg == + msg and (PAIRP msg) and ((first msg) in '(%l "%l")) and + ((last msg) in '(%l "%l")) => concat msg + concat('%l,msg,'%l) + +sayMessage msg == sayMSG mkMessage msg + +sayNewLine(:margin) == + -- Note: this function should *always* be used by sayBrightly and + -- friends rather than TERPRI -- see bindSayBrightly + TERPRI() + if margin is [n] then BLANKS n + nil + +sayString x == + -- Note: this function should *always* be used by sayBrightly and + -- friends rather than PRINTEXP -- see bindSayBrightly + PRINTEXP x + +spadStartUpMsgs() == + -- messages displayed when the system starts up + $LINELENGTH < 60 => NIL + bar := fillerSpaces($LINELENGTH,specialChar 'hbar) + sayKeyedMsg("S2GL0001",[_*BUILD_-VERSION_*, _*YEARWEEK_*]) + sayMSG bar + sayKeyedMsg("S2GL0018C",NIL) + sayKeyedMsg("S2GL0018D",NIL) + sayKeyedMsg("S2GL0003B",[$opSysName]) + sayMSG bar +-- sayMSG bar +-- sayMSG '" *" +-- sayMSG '" ***** ** ** *** ****** ** * *" +-- sayMSG '" * * * * * * * ** ** ** **" +-- sayMSG '" * * * * * * ** *** **" +-- sayMSG '" ****** * * * * * * *" +-- sayMSG '" * * * * * * * * * *" +-- sayMSG '" * * * * * * * * * *" +-- sayMSG '" * * * * * * * * * *" +-- sayMSG '" ***** * ** ** *** **** ** *** ***" +-- sayMSG '" *" +-- sayMSG '" Issue )copyright for copyright notices." +-- sayKeyedMsg("S2GL0018A",NIL) +-- sayKeyedMsg("S2GL0018B",NIL) +-- sayKeyedMsg("S2GL0003C",NIL) +-- sayKeyedMsg("S2GL0003A",NIL) +-- if not $printTimeIfTrue then sayKeyedMsg("S2GL0004",NIL) +-- if not $printTypeIfTrue then sayKeyedMsg("S2GL0005",NIL) + -- if not $displaySetValue then sayKeyedMsg("S2GL0007",NIL) +-- if not $HiFiAccess then sayKeyedMsg("S2GL0008",NIL) +-- sayMSG bar +-- version() + $msgAlist := NIL -- these msgs need not be saved + sayMSG " " + +HELP() == sayKeyedMsg("S2GL0019",NIL) + +version() == _*YEARWEEK_* + +--% Some Advanced Formatting Functions + +brightPrint x == + $MARG : local := 0 + for y in x repeat brightPrint0 y + NIL + +brightPrint0 x == + $texFormatting => brightPrint0AsTeX x + if IDENTP x then x := PNAME x + + -- if the first character is a backslash and the second is a percent sign, + -- don't try to give the token any special interpretation. Just print + -- it without the backslash. + + STRINGP x and STRINGLENGTH x > 1 and x.0 = char "\" and x.1 = char "%" => + sayString SUBSTRING(x,1,NIL) + x = '"%l" => + sayNewLine() + for i in 1..$MARG repeat sayString '" " + x = '"%i" => + $MARG := $MARG + 3 + x = '"%u" => + $MARG := $MARG - 3 + if $MARG < 0 then $MARG := 0 + x = '"%U" => + $MARG := 0 + x = '"%" => + sayString '" " + x = '"%%" => + sayString '"%" + x = '"%b" => + NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " + NULL $highlightAllowed => sayString '" " + sayString $highlightFontOn + k := blankIndicator x => BLANKS k + x = '"%d" => + NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " + NULL $highlightAllowed => sayString '" " + sayString $highlightFontOff + STRINGP x => sayString x + brightPrintHighlight x + +brightPrint0AsTeX x == + x = '"%l" => + sayString('"\\") + for i in 1..$MARG repeat sayString '"\ " + x = '"%i" => + $MARG := $MARG + 3 + x = '"%u" => + $MARG := $MARG - 3 + if $MARG < 0 then $MARG := 0 + x = '"%U" => + $MARG := 0 + x = '"%" => + sayString '"\ " + x = '"%%" => + sayString '"%" + x = '"%b" => + sayString '" {\tt " + k := blankIndicator x => for i in 1..k repeat sayString '"\ " + x = '"%d" => + sayString '"} " + x = '"_"$_"" => + sayString('"_"\verb!$!_"") + x = '"$" => + sayString('"\verb!$!") + STRINGP x => sayString x + brightPrintHighlight x + +blankIndicator x == + if IDENTP x then x := PNAME x + null STRINGP x or MAXINDEX x < 1 => nil + x.0 = '% and x.1 = 'x => + MAXINDEX x > 1 => PARSE_-INTEGER SUBSTRING(x,2,nil) + 1 + nil + +brightPrint1 x == + if x in '(%l "%l") then sayNewLine() + else if STRINGP x then sayString x + else brightPrintHighlight x + NIL + +brightPrintHighlight x == + $texFormatting => brightPrintHighlightAsTeX x + IDENTP x => + pn := PNAME x + sayString pn + -- following line helps find certain bugs that slip through + -- also see sayBrightlyLength1 + VECP x => sayString '"UNPRINTABLE" + ATOM x => sayString object2String x + [key,:rst] := x + if IDENTP key then key:=PNAME key + key = '"%m" => mathprint rst + key in '("%p" "%s") => PRETTYPRIN0 rst + key = '"%ce" => brightPrintCenter rst + key = '"%rj" => brightPrintRightJustify rst + key = '"%t" => $MARG := $MARG + tabber rst + sayString '"(" + brightPrint1 key + if EQ(key,'TAGGEDreturn) then + rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] + for y in rst repeat + sayString '" " + brightPrint1 y + if rst and (la := LASTATOM rst) then + sayString '" . " + brightPrint1 la + sayString '")" + +brightPrintHighlightAsTeX x == + IDENTP x => + pn := PNAME x + sayString pn + ATOM x => sayString object2String x + VECP x => sayString '"UNPRINTABLE" + [key,:rst] := x + key = '"%m" => mathprint rst + key = '"%m" => rst + key = '"%s" => + sayString '"\verb__" + PRETTYPRIN0 rst + sayString '"__" + key = '"%ce" => brightPrintCenter rst + key = '"%t" => $MARG := $MARG + tabber rst + -- unhandled junk (print verbatim(ish) + sayString '"(" + brightPrint1 key + if EQ(key,'TAGGEDreturn) then + rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] + for y in rst repeat + sayString '" " + brightPrint1 y + if rst and (la := LASTATOM rst) then + sayString '" . " + brightPrint1 la + sayString '")" + +tabber num == + maxTab := 50 + num > maxTab => maxTab + num + +brightPrintCenter x == + $texFormatting => brightPrintCenterAsTeX x + -- centers rst within $LINELENGTH, checking for %l's + ATOM x => + x := object2String x + wid := STRINGLENGTH x + if wid < $LINELENGTH then + f := DIVIDE($LINELENGTH - wid,2) + x := LIST(fillerSpaces(f.0,'" "),x) + for y in x repeat brightPrint0 y + NIL + y := NIL + ok := true + while x and ok repeat + if CAR(x) in '(%l "%l") then ok := NIL + else y := cons(CAR x, y) + x := CDR x + y := NREVERSE y + wid := sayBrightlyLength y + if wid < $LINELENGTH then + f := DIVIDE($LINELENGTH - wid,2) + y := CONS(fillerSpaces(f.0,'" "),y) + for z in y repeat brightPrint0 z + if x then + sayNewLine() + brightPrintCenter x + NIL + +brightPrintCenterAsTeX x == + ATOM x => + sayString '"\centerline{" + sayString x + sayString '"}" + lst := x + while lst repeat + words := nil + while lst and not CAR(lst) = "%l" repeat + words := [CAR lst,: words] + lst := CDR lst + if lst then lst := cdr lst + sayString '"\centerline{" + words := nreverse words + for zz in words repeat + brightPrint0 zz + sayString '"}" + nil + +brightPrintRightJustify x == + -- right justifies rst within $LINELENGTH, checking for %l's + ATOM x => + x := object2String x + wid := STRINGLENGTH x + wid < $LINELENGTH => + x := LIST(fillerSpaces($LINELENGTH-wid,'" "),x) + for y in x repeat brightPrint0 y + NIL + brightPrint0 x + NIL + y := NIL + ok := true + while x and ok repeat + if CAR(x) in '(%l "%l") then ok := NIL + else y := cons(CAR x, y) + x := CDR x + y := NREVERSE y + wid := sayBrightlyLength y + if wid < $LINELENGTH then + y := CONS(fillerSpaces($LINELENGTH-wid,'" "),y) + for z in y repeat brightPrint0 z + if x then + sayNewLine() + brightPrintRightJustify x + NIL + +-- some hooks for older functions + +--------------------> NEW DEFINITION (see macros.lisp.pamphlet) +BRIGHTPRINT x == brightPrint x +--------------------> NEW DEFINITION (see macros.lisp.pamphlet) +BRIGHTPRINT_-0 x == brightPrint0 x + +--% Message Formatting Utilities + +sayBrightlyLength l == + null l => 0 + atom l => sayBrightlyLength1 l + sayBrightlyLength1 first l + sayBrightlyLength rest l + +sayBrightlyLength1 x == + member(x,'("%b" "%d" %b %d)) => + NULL $highlightAllowed => 1 + 1 + member(x,'("%l" %l)) => 0 + STRINGP x and STRINGLENGTH x > 2 and x.0 = '"%" and x.1 = '"x" => + INTERN x.3 + STRINGP x => STRINGLENGTH x + IDENTP x => STRINGLENGTH PNAME x + -- following line helps find certain bugs that slip through + -- also see brightPrintHighlight + VECP x => STRINGLENGTH '"UNPRINTABLE" + ATOM x => STRINGLENGTH STRINGIMAGE x + 2 + sayBrightlyLength x + +sayAsManyPerLineAsPossible l == + -- it is assumed that l is a list of strings + l := [atom2String a for a in l] + m := 1 + "MAX"/[SIZE(a) for a in l] + -- w will be the field width in which we will display the elements + m > $LINELENGTH => + for a in l repeat sayMSG a + NIL + w := MIN(m + 3,$LINELENGTH) + -- p is the number of elements per line + p := QUOTIENT($LINELENGTH,w) + n := # l + str := '"" + for i in 0..(n-1) repeat + [c,:l] := l + str := STRCONC(str,c,fillerSpaces(w - #c,'" ")) + REMAINDER(i+1,p) = 0 => (sayMSG str ; str := '"" ) + if str ^= '"" then sayMSG str + NIL + +say2PerLine l == say2PerLineWidth(l,$LINELENGTH / 2) + +say2PerLineWidth(l,n) == + [short,long] := say2Split(l,nil,nil,n) + say2PerLineThatFit short + for x in long repeat sayLongOperation x + sayBrightly '"" + +say2Split(l,short,long,width) == + l is [x,:l'] => + sayWidth x < width => say2Split(l',[x,:short],long,width) + say2Split(l',short,[x,:long],width) + [nreverse short,nreverse long] + +sayLongOperation x == + sayWidth x > $LINELENGTH and (splitListOn(x,"if") is [front,back]) => + sayBrightly front + BLANKS (6 + # PNAME front.1) + sayBrightly back + sayBrightly x + +splitListOn(x,key) == + key in x => + while first x ^= key repeat + y:= [first x,:y] + x:= rest x + [nreverse y,x] + nil + +say2PerLineThatFit l == + while l repeat + sayBrightlyNT first l + sayBrightlyNT + fillerSpaces((($LINELENGTH/2)-sayDisplayWidth first l),'" ") + (l:= rest l) => + sayBrightlyNT first l + l:= rest l + sayBrightly '"" + sayBrightly '"" + +sayDisplayStringWidth x == + null x => 0 + sayDisplayWidth x + +sayDisplayWidth x == + PAIRP x => + +/[fn y for y in x] where fn y == + y in '(%b %d "%b" "%d") or y=$quadSymbol => 1 + k := blankIndicator y => k + sayDisplayWidth y + x = "%%" or x = '"%%" => 1 + # atom2String x + +sayWidth x == + atom x => # atom2String x + +/[fn y for y in x] where fn y == + sayWidth y + +pp2Cols(al) == + while al repeat + [[abb,:name],:al]:= al + ppPair(abb,name) + if canFit2ndEntry(name,al) then + [[abb,:name],:al]:= al + TAB ($LINELENGTH / 2) + ppPair(abb,name) + sayNewLine() + nil + +ppPair(abb,name) == + sayBrightlyNT [:bright abb,fillerSpaces(8-entryWidth abb," "),name] + +canFit2ndEntry(name,al) == + wid := ($LINELENGTH/2) - 10 + null al => nil + entryWidth name > wid => nil + entryWidth CDAR al > wid => nil + 'T + +entryWidth x == # atom2String x + +center80 text == centerNoHighlight(text,$LINELENGTH,'" ") + +centerAndHighlight(text,:argList) == + width := IFCAR argList or $LINELENGTH + fillchar := IFCAR IFCDR argList or '" " + wid := entryWidth text + 2 + wid >= width - 2 => sayBrightly ['%b,text,'%d] + f := DIVIDE(width - wid - 2,2) + fill1 := '"" + for i in 1..(f.0) repeat + fill1 := STRCONC(fillchar,fill1) + if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) + sayBrightly [fill1,'%b,text,'%d,fill2] + nil + +centerNoHighlight(text,:argList) == sayBrightly center(text,argList) + +center(text,argList) == + width := IFCAR argList or $LINELENGTH + fillchar := IFCAR IFCDR argList or '" " + if (u:= splitSayBrightlyArgument text) then [text,:moreLines]:= u + wid := sayBrightlyLength text + wid >= width - 2 => sayBrightly text + f := DIVIDE(width - wid - 2,2) + fill1 := '"" + for i in 1..(f.0) repeat + fill1 := STRCONC(fillchar,fill1) + if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) + concat(fill1,text,fill2) + +splitSayBrightly u == + width:= 0 + while u and (width:= width + sayWidth first u) < $LINELENGTH repeat + segment:= [first u,:segment] + u := rest u + null u => NREVERSE segment + segment => [:NREVERSE segment,"%l",:splitSayBrightly(u)] + u + +splitSayBrightlyArgument u == + atom u => nil + while splitListSayBrightly u is [head,:u] repeat result:= [head,:result] + result => [:NREVERSE result,u] + [u] + +splitListSayBrightly u == + for x in tails u repeat + y := rest x + null y => nil + first y = '%l => + RPLACD(x,nil) + ans:= [u,:rest y] + ans + + +--======================================================================= +-- Utility Functions +--======================================================================= + +$htSpecialChars := ['"_#", '"[", '"]", '"%", '"{", '"}", '"_\", + '"$", '"&", '"^", '"__", '"_~"] + +$htCharAlist := '( + ("$" . "\%") + ("[]" . "\[\]") + ("{}" . "\{\}") + ("\\" . "\\\\") + ("\/" . "\\/" ) + ("/\" . "/\\" ) ) + +escapeSpecialChars s == + u := LASSOC(s,$htCharAlist) => u + member(s, $htSpecialChars) => STRCONC('"_\", s) + null $saturn => s + ALPHA_-CHAR_-P (s.0) => s + not (or/[dbSpecialDisplayOpChar? s.i for i in 0..MAXINDEX s]) => s + buf := '"" + for i in 0..MAXINDEX s repeat buf := + dbSpecialDisplayOpChar?(s.i) => STRCONC(buf,'"\verb!",s.i,'"!") + STRCONC(buf,s.i) + buf + +dbSpecialDisplayOpChar? c == (c = char '_~) + diff --git a/src/interp/msgdb.boot.pamphlet b/src/interp/msgdb.boot.pamphlet deleted file mode 100644 index 842d9e82..00000000 --- a/src/interp/msgdb.boot.pamphlet +++ /dev/null @@ -1,1079 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/msgdb.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\begin{verbatim} -Description of Messages - -Axiom messages are read from a flat file database and returned -as one long string. They are preceded in the database by a key and -this is how they are referenced from code. For example, one key is -S2IL0001 which means: - S2 Scratchpad II designation - I from the interpreter - L originally from LISPLIB BOOT - 0001 a sequence number - -Each message may contain formatting codes and and parameter codes. -The formatting codes are: - %b turn on bright printing - %ceoff turn off centering - %ceon turn on centering - %d turn off bright printing - %f user defined printing - %i start indentation of 3 more spaces - %l start a new line - %m math-print an expression - %rjoff turn off right justification (actually ragged left) - %rjon turn on right justification (actually ragged left) - %s pretty-print as an S-expression - %u unindent 3 spaces - %x# insert # spaces - -The parameter codes look like %1, %2b, %3p, %4m, %5bp, %6s where the -digit is the parameter number ans the letters following indicate -additional formatting. You can indicate as many additional formatting -qualifiers as you like, to the degree they make sense. The "p" code -means to call prefix2String on the parameter, a standard way of -printing abbreviated types. The "P" operator maps prefix2String over -its arguments. The "o" operation formats the argument as an operation -name. "b" means to print that parameter in -a bold (bright) font. "c" means to center that parameter on a -new line. "f" means that the parameter is a list [fn, :args] -and that "fn" is to be called on "args" to get the text. "r" means -to right justify (ragged left) the argument. - -Look in the file with the name defined in $defaultMsgDatabaseName -above for examples. - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -import '"g-util" -)package "BOOT" - ---% Message Database Code and Message Utility Functions - -$msgDatabase := NIL -$cacheMessages := 'T -- for debugging purposes -$msgAlist := NIL -$msgDatabaseName := NIL -$testingErrorPrefix := '"Daly Bug" - -$texFormatting := false - ---% Accessing the Database - -string2Words l == - i := 0 - [w while wordFrom(l,i) is [w,i]] - -wordFrom(l,i) == - maxIndex := MAXINDEX l - k := or/[j for j in i..maxIndex | l.j ^= char ('_ ) ] or return nil - buf := '"" - while k < maxIndex and (c := l.k) ^= char ('_ ) repeat - ch := - c = char '__ => l.(k := 1+k) --this may exceed bounds - c - buf := STRCONC(buf,ch) - k := k + 1 - if k = maxIndex and (c := l.k) ^= char ('_ ) then buf := STRCONC(buf,c) - [buf,k+1] - -getKeyedMsg key == fetchKeyedMsg(key,false) - ---% Formatting and Printing Keyed Messages - -segmentKeyedMsg(msg) == string2Words msg - -segmentedMsgPreprocess x == - ATOM x => x - [head,:tail] := x - center := rightJust := NIL - if head in '(%ceon "%ceon") then center := true - if head in '(%rjon "%rjon") then rightJust := true - center or rightJust => - -- start collecting terms - y := NIL - ok := true - while tail and ok repeat - [t,:tail] := tail - t in '(%ceoff "%ceoff" %rjoff "%rjoff") => ok := NIL - y := CONS(segmentedMsgPreprocess t,y) - head1 := [(center => '"%ce"; '"%rj"),:NREVERSE y] - NULL tail => [head1] - [head1,:segmentedMsgPreprocess tail] - head1 := segmentedMsgPreprocess head - tail1 := segmentedMsgPreprocess tail - EQ(head,head1) and EQ(tail,tail1) => x - [head1,:tail1] - -removeAttributes msg == - --takes a segmented message and returns it with the attributes - --separted. - first msg ^= '"%atbeg" => - [msg,NIL] - attList := [] - until item = '"%atend" repeat - msg := rest msg - item := first msg - attList := [INTERN item,:attList] - msg := rest msg - attList := rest attList - [msg,attList] - -substituteSegmentedMsg(msg,args) == - -- this does substitution of the parameters - l := NIL - nargs := #args - for x in segmentedMsgPreprocess msg repeat - -- x is a list - PAIRP x => - l := cons(substituteSegmentedMsg(x,args),l) - c := x.0 - n := STRINGLENGTH x - - -- x is a special case - (n > 2) and (c = "%") and (x.1 = "k") => - l := NCONC(NREVERSE pkey SUBSTRING(x,2,NIL),l) - - -- ?name gets replaced by '"Push PF10" or '"Type >b (enter)" - (x.0 = char "?") and n > 1 and (v := pushOrTypeFuture(INTERN x,nil)) => - l := NCONC(NREVERSE v,l) - - -- x requires parameter substitution - (x.0 = char "%") and (n > 1) and (DIGITP x.1) => - a := DIG2FIX x.1 - arg := - a <= nargs => args.(a-1) - '"???" - -- now pull out qualifiers - q := NIL - for i in 2..(n-1) repeat q := cons(x.i,q) - -- Note 'f processing must come first. - if MEMQ(char 'f,q) then - arg := - PAIRP arg => APPLY(first arg, rest arg) - arg - if MEMQ(char 'm,q) then arg := [['"%m",:arg]] - if MEMQ(char 's,q) then arg := [['"%s",:arg]] - if MEMQ(char 'p,q) then - $texFormatting => arg := prefix2StringAsTeX arg - arg := prefix2String arg - if MEMQ(char 'P,q) then - $texFormatting => arg := [prefix2StringAsTeX x for x in arg] - arg := [prefix2String x for x in arg] - if MEMQ(char 'o, q) and $texFormatting then arg := operationLink(arg) - - if MEMQ(char 'c,q) then arg := [['"%ce",:arg]] - if MEMQ(char 'r,q) then arg := [['"%rj",:arg]] - - if MEMQ(char 'l,q) then l := cons('"%l",l) - if MEMQ(char 'b,q) then l := cons('"%b",l) - --we splice in arguments that are lists - --if y is not specified, then the adding of blanks is - --stifled after the first item in the list until the - --end of the list. (using %n and %y) - l := - PAIRP(arg) => - MEMQ(char 'y,q) or (CAR arg = '"%y") or ((LENGTH arg) = 1) => - APPEND(REVERSE arg, l) - head := first arg - tail := rest arg - ['"%y",:APPEND(REVERSE tail, ['"%n",head,:l ]) ] - cons(arg,l) - if MEMQ(char 'b,q) then l := cons('"%d",l) - for ch in '(_. _, _! _: _; _?) repeat - if MEMQ(char ch,q) then l := cons(ch,l) - - --x is a plain word - l := cons(x,l) - addBlanks NREVERSE l - -addBlanks msg == - -- adds proper blanks - null PAIRP msg => msg - null msg => msg - LENGTH msg = 1 => msg - blanksOff := false - x := first msg - if x = '"%n" then - blanksOff := true - msg1 := [] - else - msg1 := LIST x - blank := '" " - for y in rest msg repeat - y in '("%n" %n) => blanksOff := true - y in '("%y" %y) => blanksOff := false - if noBlankAfterP x or noBlankBeforeP y or blanksOff then - msg1 := [y,:msg1] - else - msg1 := [y,blank,:msg1] - x := y - NREVERSE msg1 - - -SETANDFILEQ($msgdbPrims,'( %b %d %l %i %u %U %n %x %ce %rj "%U" "%b" "%d" "%l" "%i" "%u" "%U" "%n" "%x" "%ce" "%rj")) -SETANDFILEQ($msgdbPunct,'(_. _, _! _: _; _? _] _) "." "," "!" ":" ";" "?" "]" ")" )) -SETANDFILEQ($msgdbNoBlanksBeforeGroup,['" ", " ", '"%", "%",_ - :$msgdbPrims, :$msgdbPunct]) -SETANDFILEQ($msgdbListPrims,'(%m %s %ce %rj "%m" "%s" "%ce" "%rj")) - -noBlankBeforeP word== - INTP word => false - word in $msgdbNoBlanksBeforeGroup => true - if CVECP word and SIZE word > 1 then - word.0 = char '% and word.1 = char 'x => return true - word.0 = char " " => return true - (PAIRP word) and (CAR word in $msgdbListPrims) => true - false - -$msgdbPunct := '(_[ _( "[" "(" ) -SETANDFILEQ($msgdbNoBlanksAfterGroup,['" ", " ",'"%" ,"%",_ - :$msgdbPrims,:$msgdbPunct]) - -noBlankAfterP word== - INTP word => false - word in $msgdbNoBlanksAfterGroup => true - if CVECP word and (s := SIZE word) > 1 then - word.0 = char '% and word.1 = char 'x => return true - word.(s-1) = char " " => return true - (PAIRP word) and (CAR word in $msgdbListPrims) => true - false - -cleanUpSegmentedMsg msg == - -- removes any junk like double blanks - -- takes a reversed msg and puts it in the correct order - null PAIRP msg => msg - blanks := ['" "," "] - haveBlank := NIL - prims := - '(%b %d %l %i %u %m %ce %rj _ - "%b" "%d" "%l" "%i" "%m" "%u" "%ce" "%rj") - msg1 := NIL - for x in msg repeat - if haveBlank and ((x in blanks) or (x in prims)) then - msg1 := CDR msg1 - msg1 := cons(x,msg1) - haveBlank := (x in blanks => true; NIL) - msg1 - -operationLink name == - FORMAT(nil, '"\lispLink{\verb!(|oSearch| _"~a_")!}{~a}", - name, - escapeSpecialChars STRINGIMAGE name) - ----------------------------------------- -sayPatternMsg(msg,args) == - msg := segmentKeyedMsg msg - msg := substituteSegmentedMsg(msg,args) - sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) - -throwPatternMsg(key,args) == - sayMSG '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayPatternMsg(key,args) - spadThrow() - -sayKeyedMsgAsTeX(key, args) == - $texFormatting: fluid := true - sayKeyedMsgLocal(key, args) - -sayKeyedMsg(key,args) == - $texFormatting: fluid := false - sayKeyedMsgLocal(key, args) - -sayKeyedMsgLocal(key, args) == - msg := segmentKeyedMsg getKeyedMsg key - msg := substituteSegmentedMsg(msg,args) - if $displayMsgNumber then msg := ['"%b",key,":",'"%d",:msg] - msg' := flowSegmentedMsg(msg,$LINELENGTH,$MARGIN) - if $printMsgsToFile then sayMSG2File msg' - sayMSG msg' - -throwKeyedErrorMsg(kind,key,args) == - BUMPERRORCOUNT kind - sayMSG '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayKeyedMsg(key,args) - spadThrow() - -throwKeyedMsgSP(key,args,atree) == - if atree and (sp := getSrcPos(atree)) then - sayMSG '" " - srcPosDisplay(sp) - throwKeyedMsg(key,args) - -throwKeyedMsg(key,args) == - $saturn => saturnThrowKeyedMsg(key, args) - throwKeyedMsg1(key, args) - -saturnThrowKeyedMsg(key,args) == - SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) - last := pushSatOutput("line") - sayString '"\bgroup\color{red}\begin{list}\item{} " - sayKeyedMsgAsTeX(key,args) - sayString '"\end{list}\egroup" - popSatOutput(last) - spadThrow() - -throwKeyedMsg1(key,args) == - SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) - sayMSG '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayKeyedMsg(key,args) - spadThrow() - -throwListOfKeyedMsgs(descKey,descArgs,l) == - -- idea is that descKey and descArgs are the message describing - -- what the list is about and l is a list of [key,args] messages - -- the messages in the list are numbered and should have a %1 as - -- the first token in the message text. - sayMSG '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayKeyedMsg(descKey,descArgs) - sayMSG '" " - for [key,args] in l for i in 1.. repeat - n := STRCONC(object2String i,'".") - sayKeyedMsg(key,[n,:args]) - spadThrow() - --- breakKeyedMsg is like throwKeyedMsg except that the user is given --- a chance to play around in a break loop if $BreakMode is not 'nobreak - -breakKeyedMsg(key,args) == - BUMPERRORCOUNT "semantic" - sayKeyedMsg(key,args) - handleLispBreakLoop($BreakMode) - -keyedSystemError(key,args) == - $saturn => saturnKeyedSystemError(key, args) - keyedSystemError1(key, args) - -saturnKeyedSystemError(key, args) == - SETQ(_*STANDARD_-OUTPUT_*, $texOutputStream) - sayString '"\bgroup\color{red}" - sayString '"\begin{verbatim}" - sayKeyedMsg("S2GE0000",NIL) - BUMPERRORCOUNT "semantic" - sayKeyedMsgAsTeX(key,args) - sayString '"\end{verbatim}" - sayString '"\egroup" - handleLispBreakLoop($BreakMode) - -keyedSystemError1(key,args) == - sayKeyedMsg("S2GE0000",NIL) - breakKeyedMsg(key,args) - --- these 2 functions control the mode of saturn output. --- having the stream writing functions control this would --- be better (eg. sayText, sayCommands) - -pushSatOutput(arg) == - $saturnMode = arg => arg - was := $saturnMode - arg = "verb" => - $saturnMode := "verb" - sayString '"\begin{verbatim}" - was - arg = "line" => - $saturnMode := "line" - sayString '"\end{verbatim}" - was - sayString FORMAT(nil, '"What is: ~a", $saturnMode) - $saturnMode - -popSatOutput(newmode) == - newmode = $saturnMode => nil - newmode = "verb" => - $saturnMode := "verb" - sayString '"\begin{verbatim}" - newmode = "line" => - $saturnMode := "line" - sayString '"\end{verbatim}" - sayString FORMAT(nil, '"What is: ~a", $saturnMode) - $saturnMode - -systemErrorHere functionName == - keyedSystemError("S2GE0017",[functionName]) - -isKeyedMsgInDb(key,dbName) == - $msgDatabaseName : fluid := pathname dbName - fetchKeyedMsg(key,true) - -getKeyedMsgInDb(key,dbName) == - $msgDatabaseName : fluid := pathname dbName - fetchKeyedMsg(key,false) - -sayKeyedMsgFromDb(key,args,dbName) == - $msgDatabaseName : fluid := pathname dbName - msg := segmentKeyedMsg getKeyedMsg key - msg := substituteSegmentedMsg(msg,args) - if $displayMsgNumber then msg := ['"%b",key,":",'%d,:msg] ---sayMSG flowSegmentedMsg(msg,$LINELENGTH,3) - u := flowSegmentedMsg(msg,$LINELENGTH,3) - sayBrightly u - -returnStLFromKey(key,argL,:optDbN) == - savedDbN := $msgDatabaseName - if IFCAR optDbN then - $msgDatabaseName := pathname CAR optDbN - text := fetchKeyedMsg(key, false) - $msgDatabaseName := savedDbN - text := segmentKeyedMsg text - text := substituteSegmentedMsg(text,argL) - -throwKeyedMsgFromDb(key,args,dbName) == - sayMSG '" " - if $testingSystem then sayMSG $testingErrorPrefix - sayKeyedMsgFromDb(key,args,dbName) - spadThrow() - -queryUserKeyedMsg(key,args) == - -- display message and return reply - conStream := DEFIOSTREAM ('((DEVICE . CONSOLE) (MODE . INPUT)),120,0) - sayKeyedMsg(key,args) - ans := READ_-LINE conStream - SHUT conStream - ans - -flowSegmentedMsg(msg, len, offset) == - -- tries to break a sayBrightly-type input msg into multiple - -- lines, with offset and given length. - -- msgs that are entirely centered or right justified are not flowed - msg is [[ce,:.]] and ce in '(%ce "%ce" %rj "%rj") => msg - - -- if we are formatting latex, then we assume - -- that nothing needs to be done - $texFormatting => msg - -- msgs that are entirely centered are not flowed - msg is [[ce,:.]] and ListMember?(ce,'(%ce "%ce")) => msg - - potentialMarg := 0 - actualMarg := 0 - - off := (offset <= 0 => '""; fillerSpaces(offset,'" ")) - off1:= (offset <= 1 => '""; fillerSpaces(offset-1,'" ")) - firstLine := true - - PAIRP msg => - lnl := offset - if msg is [a,:.] and a in '(%b %d _ "%b" "%d" " ") then - nl := [off1] - lnl := lnl - 1 - else nl := [off] - for f in msg repeat - f in '("%l" %l) => - actualMarg := potentialMarg - if lnl = 99999 then nl := ['%l,:nl] - lnl := 99999 - PAIRP(f) and CAR(f) in '("%m" %m '%ce "%ce" %rj "%rj") => - actualMarg := potentialMarg - nl := [f,'%l,:nl] - lnl := 199999 - f in '("%i" %i ) => - potentialMarg := potentialMarg + 3 - nl := [f,:nl] - PAIRP(f) and CAR(f) in '("%t" %t) => - potentialMarg := potentialMarg + CDR f - nl := [f,:nl] - sbl := sayBrightlyLength f - tot := lnl + offset + sbl + actualMarg - if firstLine then - firstLine := false - offset := offset + offset - off1 := STRCONC(off, off1) - off := STRCONC(off, off) - if (tot <= len) or (sbl = 1 and tot = len) then - nl := [f,:nl] - lnl := lnl + sbl - else - f in '(%b %d _ "%b" "%d" " ") => - nl := [f,off1,'%l,:nl] - actualMarg := potentialMarg - lnl := -1 + offset + sbl - nl := [f,off,'%l,:nl] - lnl := offset + sbl - concat nreverse nl - concat('%l,off,msg) - ---% Other handy things - -keyedMsgCompFailure(key,args) == - -- Called when compilation fails in such a way that interpret-code - -- mode might be of some use. - not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) - if not($Coerce) and $reportInterpOnly then - sayKeyedMsg(key,args) - sayKeyedMsg("S2IB0009",NIL) - null $compilingMap => THROW('loopCompiler,'tryInterpOnly) - THROW('mapCompiler,'tryInterpOnly) - -keyedMsgCompFailureSP(key,args,atree) == - -- Called when compilation fails in such a way that interpret-code - -- mode might be of some use. - not $useCoerceOrCroak => THROW('coerceOrCroaker, 'croaked) - if not($Coerce) and $reportInterpOnly then - if atree and (sp := getSrcPos(atree)) then - sayMSG '" " - srcPosDisplay(sp) - sayKeyedMsg(key,args) - sayKeyedMsg("S2IB0009",NIL) - null $compilingMap => THROW('loopCompiler,'tryInterpOnly) - THROW('mapCompiler,'tryInterpOnly) - -throwKeyedMsgCannotCoerceWithValue(val,t1,t2) == - null (val' := coerceInteractive(objNew(val,t1),$OutputForm)) => - throwKeyedMsg("S2IC0002",[t1,t2]) - val' := objValUnwrap(val') - throwKeyedMsg("S2IC0003",[t1,t2,val']) - ---% Some Standard Message Printing Functions - -bright x == ['"%b",:(PAIRP(x) and NULL CDR LASTNODE x => x; [x]),'"%d"] ---bright x == ['%b,:(ATOM x => [x]; x),'%d] - -mkMessage msg == - msg and (PAIRP msg) and ((first msg) in '(%l "%l")) and - ((last msg) in '(%l "%l")) => concat msg - concat('%l,msg,'%l) - -sayMessage msg == sayMSG mkMessage msg - -sayNewLine(:margin) == - -- Note: this function should *always* be used by sayBrightly and - -- friends rather than TERPRI -- see bindSayBrightly - TERPRI() - if margin is [n] then BLANKS n - nil - -sayString x == - -- Note: this function should *always* be used by sayBrightly and - -- friends rather than PRINTEXP -- see bindSayBrightly - PRINTEXP x - -spadStartUpMsgs() == - -- messages displayed when the system starts up - $LINELENGTH < 60 => NIL - bar := fillerSpaces($LINELENGTH,specialChar 'hbar) - sayKeyedMsg("S2GL0001",[_*BUILD_-VERSION_*, _*YEARWEEK_*]) - sayMSG bar - sayKeyedMsg("S2GL0018C",NIL) - sayKeyedMsg("S2GL0018D",NIL) - sayKeyedMsg("S2GL0003B",[$opSysName]) - sayMSG bar --- sayMSG bar --- sayMSG '" *" --- sayMSG '" ***** ** ** *** ****** ** * *" --- sayMSG '" * * * * * * * ** ** ** **" --- sayMSG '" * * * * * * ** *** **" --- sayMSG '" ****** * * * * * * *" --- sayMSG '" * * * * * * * * * *" --- sayMSG '" * * * * * * * * * *" --- sayMSG '" * * * * * * * * * *" --- sayMSG '" ***** * ** ** *** **** ** *** ***" --- sayMSG '" *" --- sayMSG '" Issue )copyright for copyright notices." --- sayKeyedMsg("S2GL0018A",NIL) --- sayKeyedMsg("S2GL0018B",NIL) --- sayKeyedMsg("S2GL0003C",NIL) --- sayKeyedMsg("S2GL0003A",NIL) --- if not $printTimeIfTrue then sayKeyedMsg("S2GL0004",NIL) --- if not $printTypeIfTrue then sayKeyedMsg("S2GL0005",NIL) - -- if not $displaySetValue then sayKeyedMsg("S2GL0007",NIL) --- if not $HiFiAccess then sayKeyedMsg("S2GL0008",NIL) --- sayMSG bar --- version() - $msgAlist := NIL -- these msgs need not be saved - sayMSG " " - -HELP() == sayKeyedMsg("S2GL0019",NIL) - -version() == _*YEARWEEK_* - ---% Some Advanced Formatting Functions - -brightPrint x == - $MARG : local := 0 - for y in x repeat brightPrint0 y - NIL - -brightPrint0 x == - $texFormatting => brightPrint0AsTeX x - if IDENTP x then x := PNAME x - - -- if the first character is a backslash and the second is a percent sign, - -- don't try to give the token any special interpretation. Just print - -- it without the backslash. - - STRINGP x and STRINGLENGTH x > 1 and x.0 = char "\" and x.1 = char "%" => - sayString SUBSTRING(x,1,NIL) - x = '"%l" => - sayNewLine() - for i in 1..$MARG repeat sayString '" " - x = '"%i" => - $MARG := $MARG + 3 - x = '"%u" => - $MARG := $MARG - 3 - if $MARG < 0 then $MARG := 0 - x = '"%U" => - $MARG := 0 - x = '"%" => - sayString '" " - x = '"%%" => - sayString '"%" - x = '"%b" => - NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " - NULL $highlightAllowed => sayString '" " - sayString $highlightFontOn - k := blankIndicator x => BLANKS k - x = '"%d" => - NULL IS_-CONSOLE CUROUTSTREAM => sayString '" " - NULL $highlightAllowed => sayString '" " - sayString $highlightFontOff - STRINGP x => sayString x - brightPrintHighlight x - -brightPrint0AsTeX x == - x = '"%l" => - sayString('"\\") - for i in 1..$MARG repeat sayString '"\ " - x = '"%i" => - $MARG := $MARG + 3 - x = '"%u" => - $MARG := $MARG - 3 - if $MARG < 0 then $MARG := 0 - x = '"%U" => - $MARG := 0 - x = '"%" => - sayString '"\ " - x = '"%%" => - sayString '"%" - x = '"%b" => - sayString '" {\tt " - k := blankIndicator x => for i in 1..k repeat sayString '"\ " - x = '"%d" => - sayString '"} " - x = '"_"$_"" => - sayString('"_"\verb!$!_"") - x = '"$" => - sayString('"\verb!$!") - STRINGP x => sayString x - brightPrintHighlight x - -blankIndicator x == - if IDENTP x then x := PNAME x - null STRINGP x or MAXINDEX x < 1 => nil - x.0 = '% and x.1 = 'x => - MAXINDEX x > 1 => PARSE_-INTEGER SUBSTRING(x,2,nil) - 1 - nil - -brightPrint1 x == - if x in '(%l "%l") then sayNewLine() - else if STRINGP x then sayString x - else brightPrintHighlight x - NIL - -brightPrintHighlight x == - $texFormatting => brightPrintHighlightAsTeX x - IDENTP x => - pn := PNAME x - sayString pn - -- following line helps find certain bugs that slip through - -- also see sayBrightlyLength1 - VECP x => sayString '"UNPRINTABLE" - ATOM x => sayString object2String x - [key,:rst] := x - if IDENTP key then key:=PNAME key - key = '"%m" => mathprint rst - key in '("%p" "%s") => PRETTYPRIN0 rst - key = '"%ce" => brightPrintCenter rst - key = '"%rj" => brightPrintRightJustify rst - key = '"%t" => $MARG := $MARG + tabber rst - sayString '"(" - brightPrint1 key - if EQ(key,'TAGGEDreturn) then - rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] - for y in rst repeat - sayString '" " - brightPrint1 y - if rst and (la := LASTATOM rst) then - sayString '" . " - brightPrint1 la - sayString '")" - -brightPrintHighlightAsTeX x == - IDENTP x => - pn := PNAME x - sayString pn - ATOM x => sayString object2String x - VECP x => sayString '"UNPRINTABLE" - [key,:rst] := x - key = '"%m" => mathprint rst - key = '"%m" => rst - key = '"%s" => - sayString '"\verb__" - PRETTYPRIN0 rst - sayString '"__" - key = '"%ce" => brightPrintCenter rst - key = '"%t" => $MARG := $MARG + tabber rst - -- unhandled junk (print verbatim(ish) - sayString '"(" - brightPrint1 key - if EQ(key,'TAGGEDreturn) then - rst:=[CAR rst,CADR rst,CADDR rst, '"environment (omitted)"] - for y in rst repeat - sayString '" " - brightPrint1 y - if rst and (la := LASTATOM rst) then - sayString '" . " - brightPrint1 la - sayString '")" - -tabber num == - maxTab := 50 - num > maxTab => maxTab - num - -brightPrintCenter x == - $texFormatting => brightPrintCenterAsTeX x - -- centers rst within $LINELENGTH, checking for %l's - ATOM x => - x := object2String x - wid := STRINGLENGTH x - if wid < $LINELENGTH then - f := DIVIDE($LINELENGTH - wid,2) - x := LIST(fillerSpaces(f.0,'" "),x) - for y in x repeat brightPrint0 y - NIL - y := NIL - ok := true - while x and ok repeat - if CAR(x) in '(%l "%l") then ok := NIL - else y := cons(CAR x, y) - x := CDR x - y := NREVERSE y - wid := sayBrightlyLength y - if wid < $LINELENGTH then - f := DIVIDE($LINELENGTH - wid,2) - y := CONS(fillerSpaces(f.0,'" "),y) - for z in y repeat brightPrint0 z - if x then - sayNewLine() - brightPrintCenter x - NIL - -brightPrintCenterAsTeX x == - ATOM x => - sayString '"\centerline{" - sayString x - sayString '"}" - lst := x - while lst repeat - words := nil - while lst and not CAR(lst) = "%l" repeat - words := [CAR lst,: words] - lst := CDR lst - if lst then lst := cdr lst - sayString '"\centerline{" - words := nreverse words - for zz in words repeat - brightPrint0 zz - sayString '"}" - nil - -brightPrintRightJustify x == - -- right justifies rst within $LINELENGTH, checking for %l's - ATOM x => - x := object2String x - wid := STRINGLENGTH x - wid < $LINELENGTH => - x := LIST(fillerSpaces($LINELENGTH-wid,'" "),x) - for y in x repeat brightPrint0 y - NIL - brightPrint0 x - NIL - y := NIL - ok := true - while x and ok repeat - if CAR(x) in '(%l "%l") then ok := NIL - else y := cons(CAR x, y) - x := CDR x - y := NREVERSE y - wid := sayBrightlyLength y - if wid < $LINELENGTH then - y := CONS(fillerSpaces($LINELENGTH-wid,'" "),y) - for z in y repeat brightPrint0 z - if x then - sayNewLine() - brightPrintRightJustify x - NIL - --- some hooks for older functions - ---------------------> NEW DEFINITION (see macros.lisp.pamphlet) -BRIGHTPRINT x == brightPrint x ---------------------> NEW DEFINITION (see macros.lisp.pamphlet) -BRIGHTPRINT_-0 x == brightPrint0 x - ---% Message Formatting Utilities - -sayBrightlyLength l == - null l => 0 - atom l => sayBrightlyLength1 l - sayBrightlyLength1 first l + sayBrightlyLength rest l - -sayBrightlyLength1 x == - member(x,'("%b" "%d" %b %d)) => - NULL $highlightAllowed => 1 - 1 - member(x,'("%l" %l)) => 0 - STRINGP x and STRINGLENGTH x > 2 and x.0 = '"%" and x.1 = '"x" => - INTERN x.3 - STRINGP x => STRINGLENGTH x - IDENTP x => STRINGLENGTH PNAME x - -- following line helps find certain bugs that slip through - -- also see brightPrintHighlight - VECP x => STRINGLENGTH '"UNPRINTABLE" - ATOM x => STRINGLENGTH STRINGIMAGE x - 2 + sayBrightlyLength x - -sayAsManyPerLineAsPossible l == - -- it is assumed that l is a list of strings - l := [atom2String a for a in l] - m := 1 + "MAX"/[SIZE(a) for a in l] - -- w will be the field width in which we will display the elements - m > $LINELENGTH => - for a in l repeat sayMSG a - NIL - w := MIN(m + 3,$LINELENGTH) - -- p is the number of elements per line - p := QUOTIENT($LINELENGTH,w) - n := # l - str := '"" - for i in 0..(n-1) repeat - [c,:l] := l - str := STRCONC(str,c,fillerSpaces(w - #c,'" ")) - REMAINDER(i+1,p) = 0 => (sayMSG str ; str := '"" ) - if str ^= '"" then sayMSG str - NIL - -say2PerLine l == say2PerLineWidth(l,$LINELENGTH / 2) - -say2PerLineWidth(l,n) == - [short,long] := say2Split(l,nil,nil,n) - say2PerLineThatFit short - for x in long repeat sayLongOperation x - sayBrightly '"" - -say2Split(l,short,long,width) == - l is [x,:l'] => - sayWidth x < width => say2Split(l',[x,:short],long,width) - say2Split(l',short,[x,:long],width) - [nreverse short,nreverse long] - -sayLongOperation x == - sayWidth x > $LINELENGTH and (splitListOn(x,"if") is [front,back]) => - sayBrightly front - BLANKS (6 + # PNAME front.1) - sayBrightly back - sayBrightly x - -splitListOn(x,key) == - key in x => - while first x ^= key repeat - y:= [first x,:y] - x:= rest x - [nreverse y,x] - nil - -say2PerLineThatFit l == - while l repeat - sayBrightlyNT first l - sayBrightlyNT - fillerSpaces((($LINELENGTH/2)-sayDisplayWidth first l),'" ") - (l:= rest l) => - sayBrightlyNT first l - l:= rest l - sayBrightly '"" - sayBrightly '"" - -sayDisplayStringWidth x == - null x => 0 - sayDisplayWidth x - -sayDisplayWidth x == - PAIRP x => - +/[fn y for y in x] where fn y == - y in '(%b %d "%b" "%d") or y=$quadSymbol => 1 - k := blankIndicator y => k - sayDisplayWidth y - x = "%%" or x = '"%%" => 1 - # atom2String x - -sayWidth x == - atom x => # atom2String x - +/[fn y for y in x] where fn y == - sayWidth y - -pp2Cols(al) == - while al repeat - [[abb,:name],:al]:= al - ppPair(abb,name) - if canFit2ndEntry(name,al) then - [[abb,:name],:al]:= al - TAB ($LINELENGTH / 2) - ppPair(abb,name) - sayNewLine() - nil - -ppPair(abb,name) == - sayBrightlyNT [:bright abb,fillerSpaces(8-entryWidth abb," "),name] - -canFit2ndEntry(name,al) == - wid := ($LINELENGTH/2) - 10 - null al => nil - entryWidth name > wid => nil - entryWidth CDAR al > wid => nil - 'T - -entryWidth x == # atom2String x - -center80 text == centerNoHighlight(text,$LINELENGTH,'" ") - -centerAndHighlight(text,:argList) == - width := IFCAR argList or $LINELENGTH - fillchar := IFCAR IFCDR argList or '" " - wid := entryWidth text + 2 - wid >= width - 2 => sayBrightly ['%b,text,'%d] - f := DIVIDE(width - wid - 2,2) - fill1 := '"" - for i in 1..(f.0) repeat - fill1 := STRCONC(fillchar,fill1) - if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) - sayBrightly [fill1,'%b,text,'%d,fill2] - nil - -centerNoHighlight(text,:argList) == sayBrightly center(text,argList) - -center(text,argList) == - width := IFCAR argList or $LINELENGTH - fillchar := IFCAR IFCDR argList or '" " - if (u:= splitSayBrightlyArgument text) then [text,:moreLines]:= u - wid := sayBrightlyLength text - wid >= width - 2 => sayBrightly text - f := DIVIDE(width - wid - 2,2) - fill1 := '"" - for i in 1..(f.0) repeat - fill1 := STRCONC(fillchar,fill1) - if f.1 = 0 then fill2 := fill1 else fill2 := STRCONC(fillchar,fill1) - concat(fill1,text,fill2) - -splitSayBrightly u == - width:= 0 - while u and (width:= width + sayWidth first u) < $LINELENGTH repeat - segment:= [first u,:segment] - u := rest u - null u => NREVERSE segment - segment => [:NREVERSE segment,"%l",:splitSayBrightly(u)] - u - -splitSayBrightlyArgument u == - atom u => nil - while splitListSayBrightly u is [head,:u] repeat result:= [head,:result] - result => [:NREVERSE result,u] - [u] - -splitListSayBrightly u == - for x in tails u repeat - y := rest x - null y => nil - first y = '%l => - RPLACD(x,nil) - ans:= [u,:rest y] - ans - - ---======================================================================= --- Utility Functions ---======================================================================= - -$htSpecialChars := ['"_#", '"[", '"]", '"%", '"{", '"}", '"_\", - '"$", '"&", '"^", '"__", '"_~"] - -$htCharAlist := '( - ("$" . "\%") - ("[]" . "\[\]") - ("{}" . "\{\}") - ("\\" . "\\\\") - ("\/" . "\\/" ) - ("/\" . "/\\" ) ) - -escapeSpecialChars s == - u := LASSOC(s,$htCharAlist) => u - member(s, $htSpecialChars) => STRCONC('"_\", s) - null $saturn => s - ALPHA_-CHAR_-P (s.0) => s - not (or/[dbSpecialDisplayOpChar? s.i for i in 0..MAXINDEX s]) => s - buf := '"" - for i in 0..MAXINDEX s repeat buf := - dbSpecialDisplayOpChar?(s.i) => STRCONC(buf,'"\verb!",s.i,'"!") - STRCONC(buf,s.i) - buf - -dbSpecialDisplayOpChar? c == (c = char '_~) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3