Initial population.

1 files changed, 262 insertions, 0 deletions

diff --git a/src/interp/g-cndata.boot.pamphlet b/src/interp/g-cndata.boot.pamphlet
new file mode 100644
index 00000000..7e09df96
--- /dev/null
+++ b/src/interp/g-cndata.boot.pamphlet
@@ -0,0 +1,262 @@
+\documentclass{article}
+\usepackage{axiom}
+\begin{document}
+\title{\$SPAD/src/interp g-cndata.boot}
+\author{The Axiom Team}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+\section{License}
+<<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>>
+
+--% Manipulation of Constructor Datat
+
+--=======================================================================
+--            Build Table of Lower Case Constructor Names
+--=======================================================================
+mkLowerCaseConTable() ==
+--Called at system build time by function BUILD-INTERPSYS (see util.lisp)
+--Table is referenced by functions conPageFastPath and grepForAbbrev
+  $lowerCaseConTb := MAKE_-HASH_-TABLE()
+  for x in allConstructors() repeat augmentLowerCaseConTable x
+  $lowerCaseConTb
+
+augmentLowerCaseConTable x ==
+  y:=GETDATABASE(x,'ABBREVIATION)
+  item:=[x,y,nil]
+  HPUT($lowerCaseConTb,x,item)
+  HPUT($lowerCaseConTb,DOWNCASE x,item)
+  HPUT($lowerCaseConTb,y,item)
+
+getCDTEntry(info,isName) ==
+  not IDENTP info => NIL
+  (entry := HGET($lowerCaseConTb,info)) =>
+    [name,abb,:.] := entry
+    isName and EQ(name,info) => entry
+    not isName and EQ(abb,info) => entry
+    NIL
+  entry
+ 
+putConstructorProperty(name,prop,val) ==
+  null (entry := getCDTEntry(name,true)) => NIL
+  RPLACD(CDR entry,PUTALIST(CDDR entry,prop,val))
+  true
+
+attribute? name == 
+	MEMQ(name, _*ATTRIBUTES_*)
+ 
+abbreviation? abb ==
+  -- if it is an abbreviation, return the corresponding name
+  GETDATABASE(abb,'CONSTRUCTOR)
+ 
+constructor? name ==
+  -- if it is a constructor name, return the abbreviation
+  GETDATABASE(name,'ABBREVIATION)
+ 
+domainForm? d ==
+  GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain
+
+packageForm? d ==
+  GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package
+
+categoryForm? c ==
+  op := opOf c
+  MEMQ(op, $CategoryNames) => true
+  GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true
+  nil
+
+getImmediateSuperDomain(d) ==
+  IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN)
+
+maximalSuperType d ==
+  d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d'
+  d
+
+-- probably will switch over to 'libName soon
+getLisplibName(c) == getConstructorAbbreviation(c)
+ 
+getConstructorAbbreviation op ==
+  constructor?(op) or throwKeyedMsg("S2IL0015",[op])
+ 
+getConstructorUnabbreviation op ==
+  abbreviation?(op) or throwKeyedMsg("S2IL0019",[op])
+ 
+mkUserConstructorAbbreviation(c,a,type) ==
+  if not atom c then c:= CAR c  --  Existing constructors will be wrapped
+  constructorAbbreviationErrorCheck(c,a,type,'abbreviationError)
+  clearClams()
+  clearConstructorCache(c)
+  installConstructor(c,type)
+  setAutoLoadProperty(c)
+ 
+abbQuery(x) ==
+  abb := GETDATABASE(x,'ABBREVIATION) =>
+   sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x])
+  sayKeyedMsg("S2IZ0003",[x])
+ 
+installConstructor(cname,type) ==
+  (entry := getCDTEntry(cname,true)) => entry
+  item := [cname,GETDATABASE(cname,'ABBREVIATION),nil]
+  if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then
+    HPUT($lowerCaseConTb,cname,item)
+    HPUT($lowerCaseConTb,DOWNCASE cname,item)
+ 
+constructorNameConflict(name,kind) ==
+  userError
+    ["The name",:bright name,"conflicts with the name of an existing rule",
+      "%l","please choose another ",kind]
+ 
+constructorAbbreviationErrorCheck(c,a,typ,errmess) ==
+  siz := SIZE (s := PNAME a)
+  if typ = 'category and siz > 7
+    then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL)
+  if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL)
+  if s ^= UPCASE s then throwKeyedMsg("S2IL0006",NIL)
+  abb := GETDATABASE(c,'ABBREVIATION)
+  name:= GETDATABASE(a,'CONSTRUCTOR)
+  type := GETDATABASE(c,'CONSTRUCTORKIND)
+  a=abb and c^=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb)
+  a=name and c^=name => lisplibError(c,a,typ,abb,name,type,'abbIsName)
+  c=name and typ^=type => lisplibError(c,a,typ,abb,name,type,'wrongType)
+ 
+abbreviationError(c,a,typ,abb,name,type,error) ==
+  sayKeyedMsg("S2IL0009",[a,typ,c])
+  error='duplicateAbb =>
+    throwKeyedMsg("S2IL0010",[a,typ,name])
+  error='abbIsName =>
+    throwKeyedMsg("S2IL0011",[a,type])
+  error='wrongType =>
+    throwKeyedMsg("S2IL0012",[c,type])
+  NIL
+ 
+abbreviate u ==
+  u is ['Union,:arglist] =>
+    ['Union,:[abbreviate a for a in arglist]]
+  u is [op,:arglist] =>
+    abb := constructor?(op) =>
+      [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))]
+    u
+  constructor?(u) or u
+ 
+unabbrev u == unabbrev1(u,nil)
+ 
+unabbrevAndLoad u == unabbrev1(u,true)
+ 
+isNameOfType x ==
+  $doNotAddEmptyModeIfTrue:local:= true
+  (val := get(x,'value,$InteractiveFrame)) and
+    (domain := objMode val) and
+      domain in '((Mode) (Domain) (SubDomain (Domain))) => true
+  y := opOf unabbrev x
+  constructor? y
+ 
+unabbrev1(u,modeIfTrue) ==
+  atom u =>
+    modeIfTrue =>
+      d:= isDomainValuedVariable u => u
+      a := abbreviation? u =>
+        GETDATABASE(a,'NILADIC) => [a]
+        largs := ['_$EmptyMode for arg in
+          getPartialConstructorModemapSig(a)]
+        unabbrev1([u,:largs],modeIfTrue)
+      u
+    a:= abbreviation?(u) or u
+    GETDATABASE(a,'NILADIC) => [a]
+    a
+  [op,:arglist] := u
+  op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]]
+  d:= isDomainValuedVariable op =>
+    throwKeyedMsg("S2IL0013",[op,d])
+  (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r
+  (cname := abbreviation? op) or (constructor?(op) and (cname := op)) =>
+    (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r
+    -- ??? if modeIfTrue then loadIfNecessary cname
+    [cname,:condUnabbrev(op,arglist,
+      getPartialConstructorModemapSig(cname),modeIfTrue)]
+  u
+ 
+unabbrevSpecialForms(op,arglist,modeIfTrue) ==
+  op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]]
+  op = 'Union   =>
+    [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]]
+  op = 'Record =>
+    [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]]
+  nil
+ 
+unabbrevRecordComponent(a,modeIfTrue) ==
+  a is ["Declare",b,T] or a is [":",b,T] =>
+    [":",b,unabbrev1(T,modeIfTrue)]
+  userError "wrong format for Record type"
+ 
+unabbrevUnionComponent(a,modeIfTrue) ==
+  a is ["Declare",b,T] or a is [":",b,T] =>
+    [":",b,unabbrev1(T,modeIfTrue)]
+  unabbrev1(a, modeIfTrue)
+ 
+condAbbrev(arglist,argtypes) ==
+  res:= nil
+  for arg in arglist for type in argtypes repeat
+    if categoryForm?(type) then arg:= abbreviate arg
+    res:=[:res,arg]
+  res
+ 
+condUnabbrev(op,arglist,argtypes,modeIfTrue) ==
+  #arglist ^= #argtypes =>
+    throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"),
+      bright(#arglist)])
+  [newArg for arg in arglist for type in argtypes] where newArg ==
+    categoryForm?(type) => unabbrev1(arg,modeIfTrue)
+    arg
+ 
+--% Code Being Phased Out
+ 
+nAssocQ(x,l,n) ==
+  repeat
+    if atom l then return nil
+    if EQ(x,(QCAR l).n) then return QCAR l
+    l:= QCDR l
+ 
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}