Revert commits to the wrong tree.

1 files changed, 288 insertions, 0 deletions

diff --git a/src/interp/br-prof.boot.pamphlet b/src/interp/br-prof.boot.pamphlet
new file mode 100644
index 00000000..cf1d0e58
--- /dev/null
+++ b/src/interp/br-prof.boot.pamphlet
@@ -0,0 +1,288 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp br-prof.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{License}
+<<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.
+
+@
+
+<<*>>=
+<<license>>
+
+--====================> WAS b-prof.boot <================================
+
+--============================================================================
+--                Browser Code for Profiling
+--============================================================================
+kciPage(htPage,junk) ==
+  --info alist must have NEW format with [op,:sig] in its CAARs
+  which:= '"operation"
+  htpSetProperty(htPage,'which,which)
+  domname := htpProperty(htPage,'domname)
+  conform := htpProperty(htPage,'conform)
+  heading := ['"Capsule Cross Reference for ",:htpProperty(htPage,'heading)]
+  page := htInitPage(heading,htCopyProplist htPage)
+  conname := opOf conform
+  htpSetProperty(page,'infoAlist,infoAlist := getInfoAlist conname)
+  dbGetExpandedOpAlist page      --expand opAlist "in place"
+  opAlist := kciReduceOpAlist(htpProperty(page,'opAlist),infoAlist)
+  dbShowOperationsFromConform(page,which,opAlist)
+
+kciReduceOpAlist(opAlist,infoAlist) ==
+--count opAlist
+  res := [pair for [op,:items] in opAlist | pair] where pair ==
+    u := LASSOC(op,infoAlist) =>
+      y := [x for x in items
+            | x is [sig,:.] and or/[sig = sig1 for [sig1,:.] in u]] => [op,:y]
+      nil
+    nil
+  res
+
+displayInfoOp(htPage,infoAlist,op,sig) ==
+  (sigAlist := LASSOC(op,infoAlist)) and (itemlist := LASSOC(sig,sigAlist)) =>
+     dbShowInfoOp(htPage,op,sig,itemlist)
+  nil
+
+dbShowInfoOp(htPage,op,sig,alist) ==
+  heading := htpProperty(htPage,'heading)
+  domname := htpProperty(htPage,'domname)
+  conform := htpProperty(htPage,'conform)
+  opAlist := htpProperty(htPage,'opAlist)
+  conname := opOf conform
+  kind     := GETDATABASE(conname,'CONSTRUCTORKIND)
+  honestConform :=
+    kind = 'category =>
+      [INTERN STRCONC(PNAME conname,'"&"),"$",:CDR conform]
+    conform
+  faTypes  := CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP)
+
+  conArgTypes :=
+    SUBLISLIS(IFCDR conform,TAKE(#faTypes,$FormalMapVariableList),faTypes)
+  conform := htpProperty(htPage,'conform)
+  conname := opOf conform
+--argTypes := REVERSE ASSOCRIGHT LASSOC('arguments,alist)
+--sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes]
+  ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op
+  oppart := ['"{\em ", ops, '"}"]
+  head :=
+    sig => [:oppart,'": ",:dbConformGen dbInfoSig sig]
+    oppart
+  heading := [:head,'" from {\sf ",form2HtString conform,'"}"]
+  for u in alist repeat
+    [x,:y] := u
+    x = 'locals => locals := y
+    x = 'arguments => arguments := y
+    fromAlist := [[x,:zeroOneConvertAlist y], :fromAlist]
+  fromAlist :=
+    cons := args := nil
+    for (p := [x,:y]) in fromAlist repeat
+      x = $ => dollar := [[honestConform,:y]]
+      x = 'Rep => rep := [['Rep,:y]]
+      IDENTP x => args := [dbInfoFindCat(conform,conArgTypes,p), :args]
+      cons := [dbInfoTran(x,y), :cons]
+    [:mySort args, :dollar, :rep, :mySort cons]
+  sigAlist  := LASSOC(op,opAlist)
+  item := or/[x for x in sigAlist | x is [sig1,:.] and sig1 = sig] or
+    systemError '"cannot find signature"
+  --item is [sig,pred,origin,exposeFlag,comments]
+  [sig,pred,origin,exposeFlag,doc] := item
+  htpSetProperty(htPage,'fromAlist,fromAlist)
+  htSayHline()
+  htSay('"\center{Cross Reference for definition of {\em ",ops,'"}}\beginmenu ")
+--  if arguments then
+--    htSay '"\item\menuitemstyle{}{\em arguments:}\newline"
+--    dbShowInfoList(arguments,0,false)
+  if locals then
+    htSay '"\item\menuitemstyle{}{\em local variables:}\newline"
+    dbShowInfoList(locals,8192,false)
+  bincount := 2
+  for [con,:fns] in fromAlist repeat
+    htSay '"\item"
+    if IDENTP con then
+        htSay '"\menuitemstyle{} {\em calls to} "
+        if con ^= 'Rep then htSay '"{\em argument} "
+        htSay con
+        if and/[fn is ['origin,orig,.] and
+          (null origin and (origin := orig) or origin = orig) for fn in fns] then
+            htSay '" {\em of type} "
+            bcConform orig
+        buttonForOp := false
+    else
+      htMakePage [['bcLinks,['"\menuitemstyle{}",'"",'dbInfoChoose,bincount]]]
+      htSay '"{\em calls to} "
+      bcConform con
+      buttonForOp := true
+    htSay('":\newline ")
+    dbShowInfoList(fns, bincount * 8192,buttonForOp)
+    bincount := bincount + 1
+  htSay '"\endmenu "
+
+dbShowInfoList(dataItems,count,buttonForOp?) ==
+--dataItems are [op,:sig]
+  single? := null rest dataItems
+  htSay '"\table{"
+  for item in dataItems repeat
+    [op,:sig] :=
+       item is ['origin,.,s] =>
+         buttonForOp? := true
+         s
+       item
+    ops := escapeSpecialChars STRINGIMAGE op
+    htSay '"{"
+    if count < 16384 or not buttonForOp? then
+      htSay [ops,'": "]
+      atom sig => bcConform sig
+      bcConform dbInfoSig sig
+    else
+      htMakePage [['bcLinks,[ops,'"",'dbInfoChooseSingle,count]]]
+      htSay '": "
+      if atom sig then htSay sig else
+        bcConform dbInfoSig sig
+    htSay '"}"
+    count := count + 1
+  htSay '"} "
+  count
+
+dbInfoFindCat(conform,conArgTypes,u) ==
+  [argName,:opSigList] := u
+  n := POSITION(argName,IFCDR conform) or systemError()
+  t := conArgTypes . n
+  [argName,:[dbInfoWrapOrigin(x,t) for x in opSigList]]
+
+dbInfoWrapOrigin(x, t) ==
+  [op, :sig] := x
+  origin := dbInfoOrigin(op,sig,t) => ['origin, origin, x]
+  x
+
+dbInfoOrigin(op,sig,t) ==
+  t is ['Join, :r] => or/[dbInfoOrigin(op,sig,x) for x in r]
+  t is ['CATEGORY,:.] => false
+  [sig = sig1 for [sig1,:.] in LASSOC(op, koOps(t,nil))] => t
+  false
+
+dbInfoTran(con,opSigList) == [con,:SUBST("$",con,mySort opSigList)]
+
+zeroOneConvertAlist u == [[zeroOneConvert x,:y] for [x,:y] in u]
+
+dbInfoChoose(htPage,count) ==
+  fromAlist := htpProperty(htPage,'fromAlist)
+  index := count - 2
+  [con, :alist] := fromAlist.index
+  dbInfoChoose1(htPage,con,alist)
+
+dbInfoChooseSingle(htPage,count) ==
+  fromAlist := htpProperty(htPage,'fromAlist)
+  [index, binkey] := DIVIDE(count, 8192)
+  [con, :alist] := fromAlist.(index - 2)
+  item := alist . binkey
+  alist :=
+    item is ['origin,origin,s] =>
+      con := origin
+      [s]
+    [item]
+  dbInfoChoose1(htPage,con,alist)
+
+dbInfoChoose1(htPage,con,alist) ==
+  $conform: local := con
+  opAlist := [pair for x in koOps(con,nil) | pair:=dbInfoSigMatch(x,alist)]
+  page := htInitPage(nil,nil)
+  htpSetProperty(page,'conform,con)
+  htpSetProperty(page,'kind,PNAME GETDATABASE(opOf con,'CONSTRUCTORKIND))
+  dbShowOperationsFromConform(page,'"operation",opAlist)
+
+dbInfoSigMatch(x,alist) ==
+  [op,:sigAlist] := x
+  candidates := [sig for [op1,:sig] in alist | op1 = op] or return nil
+  sigs := [s for s in sigAlist | "or"/[first s = s1 for s1 in candidates] or
+    (s2 := SUBST($conform,"$",s)) and "or"/[first s2 = s1 for s1 in candidates]]
+  sigs and [op,:sigs]
+
+
+dbInfoSig sig ==
+  null rest sig => first sig
+  ['Mapping,:sig]
+
+--============================================================================
+--                Code to Expand opAlist
+--============================================================================
+dbGetExpandedOpAlist htPage ==
+  expand := htpProperty(htPage,'expandOperations)
+  if expand ^= 'fullyExpanded then
+    if null expand then htpSetProperty(htPage,'expandOperations,'lists)
+    opAlist := koOps(htpProperty(htPage,'conform),nil)
+    htpSetProperty(htPage,'opAlist,opAlist)
+    dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",false,false)
+  htpProperty(htPage,'opAlist)
+
+--============================================================================
+--                  Get Info File Alist
+--============================================================================
+hasNewInfoAlist conname ==
+  (u := getInfoAlist conname) and hasNewInfoText u
+
+hasNewInfoText u ==
+  and/[ATOM op and and/[item is [sig,:alist] and
+    null sig or null atom sig and null atom alist for item in items] for [op,:items] in u]
+
+getInfoAlist conname ==
+  cat? := GETDATABASE(conname,'CONSTRUCTORKIND) = 'category
+  if cat? then conname := INTERN STRCONC(STRINGIMAGE conname,'"&")
+  abb := constructor? conname or return '"not a constructor"
+  fs  := STRCONC(PNAME abb,'".NRLIB/info")
+  inStream :=
+    PROBE_-FILE fs => OPEN fs
+    filename := STRCONC('"/spad/int/algebra/",PNAME abb,'".NRLIB/info")
+    PROBE_-FILE filename => OPEN filename
+    return nil
+  alist := mySort READ inStream
+  if cat? then
+    [.,dollarName,:.] := GETDATABASE(conname,'CONSTRUCTORFORM)
+    alist := SUBST("$",dollarName,alist)
+  alist
+
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}