1-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
2-- All rights reserved.
3--
4-- Redistribution and use in source and binary forms, with or without
5-- modification, are permitted provided that the following conditions are
6-- met:
7--
8--     - Redistributions of source code must retain the above copyright
9--       notice, this list of conditions and the following disclaimer.
10--
11--     - Redistributions in binary form must reproduce the above copyright
12--       notice, this list of conditions and the following disclaimer in
13--       the documentation and/or other materials provided with the
14--       distribution.
15--
16--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
17--       names of its contributors may be used to endorse or promote products
18--       derived from this software without specific prior written permission.
19--
20-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
21-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
22-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
23-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
24-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
25-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
26-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
27-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
28-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
29-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
30-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31
32)package "BOOT"
33
34--% Manipulation of Constructor Datat
35
36--=======================================================================
37--            Build Table of Lower Case Constructor Names
38--=======================================================================
39mkLowerCaseConTable() ==
40--Table is referenced by functions conPageFastPath and grepForAbbrev
41  $lowerCaseConTb := MAKE_HASHTABLE('EQUAL)
42  for x in allConstructors() repeat augmentLowerCaseConTable x
43  $lowerCaseConTb
44
45augmentLowerCaseConTable x ==
46  y:=GETDATABASE(x,'ABBREVIATION)
47  item:=[x,y,nil]
48  HPUT($lowerCaseConTb,x,item)
49  HPUT($lowerCaseConTb,DOWNCASE x,item)
50  HPUT($lowerCaseConTb,y,item)
51
52getCDTEntry(info,isName) ==
53  not IDENTP info => NIL
54  (entry := HGET($lowerCaseConTb,info)) =>
55    [name,abb,:.] := entry
56    isName and EQ(name,info) => entry
57    not isName and EQ(abb,info) => entry
58    NIL
59  entry
60
61abbreviation? abb ==
62  -- if it is an abbreviation, return the corresponding name
63  GETDATABASE(abb,'CONSTRUCTOR)
64
65constructor? name ==
66  -- if it is a constructor name, return the abbreviation
67  GETDATABASE(name,'ABBREVIATION)
68
69domainForm? d ==
70  GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'domain
71
72packageForm? d ==
73  GETDATABASE(opOf d,'CONSTRUCTORKIND) = 'package
74
75categoryForm? c ==
76  op := opOf c
77  MEMQ(op, $CategoryNames) => true
78  GETDATABASE(op,'CONSTRUCTORKIND) = 'category => true
79  nil
80
81getImmediateSuperDomain(d) ==
82  IFCAR GETDATABASE(opOf d, 'SUPERDOMAIN)
83
84maximalSuperType d ==
85  d' := GETDATABASE(opOf d, 'SUPERDOMAIN) => maximalSuperType first d'
86  d
87
88getConstructorAbbreviation op ==
89  constructor?(op) or throwKeyedMsg("S2IL0015",[op])
90
91mkUserConstructorAbbreviation(c,a,type) ==
92  if not atom c then c := first c  --  Existing constructors will be wrapped
93  constructorAbbreviationErrorCheck(c,a,type,'abbreviationError)
94  clearClams()
95  clearConstructorCache(c)
96  installConstructor(c,type)
97  setAutoLoadProperty(c)
98
99abbQuery(x) ==
100  abb := GETDATABASE(x,'ABBREVIATION) =>
101   sayKeyedMsg("S2IZ0001",[abb,GETDATABASE(x,'CONSTRUCTORKIND),x])
102  sayKeyedMsg("S2IZ0003",[x])
103
104installConstructor(cname,type) ==
105  (entry := getCDTEntry(cname,true)) => entry
106  item := [cname,GETDATABASE(cname,'ABBREVIATION),nil]
107  if BOUNDP '$lowerCaseConTb and $lowerCaseConTb then
108    HPUT($lowerCaseConTb,cname,item)
109    HPUT($lowerCaseConTb,DOWNCASE cname,item)
110
111constructorAbbreviationErrorCheck(c,a,typ,errmess) ==
112  siz := SIZE (s := PNAME a)
113  if typ = 'category and siz > 7
114    then throwKeyedErrorMsg('precompilation,"S2IL0021",NIL)
115  if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",NIL)
116  if s ~= UPCASE s then throwKeyedMsg("S2IL0006",NIL)
117  abb := GETDATABASE(c,'ABBREVIATION)
118  name:= GETDATABASE(a,'CONSTRUCTOR)
119  type := GETDATABASE(c,'CONSTRUCTORKIND)
120  a=abb and c~=name => lisplibError(c,a,typ,abb,name,type,'duplicateAbb)
121  a=name and c~=name => lisplibError(c,a,typ,abb,name,type,'abbIsName)
122  c=name and typ~=type => lisplibError(c,a,typ,abb,name,type,'wrongType)
123
124abbreviationError(c,a,typ,abb,name,type,error) ==
125  sayKeyedMsg("S2IL0009",[a,typ,c])
126  error='duplicateAbb =>
127    throwKeyedMsg("S2IL0010",[a,typ,name])
128  error='abbIsName =>
129    throwKeyedMsg("S2IL0011",[a,type])
130  error='wrongType =>
131    throwKeyedMsg("S2IL0012",[c,type])
132  NIL
133
134abbreviate u ==
135  u is ['Union,:arglist] =>
136    ['Union,:[abbreviate a for a in arglist]]
137  u is [op,:arglist] =>
138    abb := constructor?(op) =>
139      [abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))]
140    u
141  constructor?(u) or u
142
143unabbrev u == unabbrev1(u,nil)
144
145unabbrevAndLoad u == unabbrev1(u,true)
146
147isNameOfType x ==
148  (val := get(x,'value,$InteractiveFrame)) and
149    (domain := objMode val) and
150      domain in '((Mode) (Type) (Category)) => true
151  y := opOf unabbrev x
152  constructor? y
153
154unabbrev1(u,modeIfTrue) ==
155  atom u =>
156    modeIfTrue =>
157      d:= isDomainValuedVariable u => u
158      a := abbreviation? u =>
159        GETDATABASE(a,'NILADIC) => [a]
160        largs := ['_$EmptyMode for arg in
161          getPartialConstructorModemapSig(a)]
162        unabbrev1([u,:largs],modeIfTrue)
163      u
164    a:= abbreviation?(u) or u
165    GETDATABASE(a,'NILADIC) => [a]
166    a
167  [op,:arglist] := u
168  op = 'Join => ['Join, :[unabbrev1(x, modeIfTrue) for x in arglist]]
169  d:= isDomainValuedVariable op =>
170    throwKeyedMsg("S2IL0013",[op,d])
171  (r := unabbrevSpecialForms(op,arglist,modeIfTrue)) => r
172  (cname := abbreviation? op) or (constructor?(op) and (cname := op)) =>
173    (r := unabbrevSpecialForms(cname,arglist,modeIfTrue)) => r
174    -- ??? if modeIfTrue then loadIfNecessary cname
175    [cname,:condUnabbrev(op,arglist,
176      getPartialConstructorModemapSig(cname),modeIfTrue)]
177  u
178
179unabbrevSpecialForms(op,arglist,modeIfTrue) ==
180  op = 'Mapping => [op,:[unabbrev1(a,modeIfTrue) for a in arglist]]
181  op = 'Union   =>
182    [op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]]
183  op = 'Record =>
184    [op,:[unabbrevRecordComponent(a,modeIfTrue) for a in arglist]]
185  nil
186
187unabbrevRecordComponent(a,modeIfTrue) ==
188  a is ["Declare",b,T] or a is [":",b,T] =>
189    [":",b,unabbrev1(T,modeIfTrue)]
190  userError "wrong format for Record type"
191
192unabbrevUnionComponent(a,modeIfTrue) ==
193  a is ["Declare",b,T] or a is [":",b,T] =>
194    [":",b,unabbrev1(T,modeIfTrue)]
195  unabbrev1(a, modeIfTrue)
196
197condAbbrev(arglist,argtypes) ==
198  res:= nil
199  for arg in arglist for type in argtypes repeat
200    if categoryForm?(type) then arg:= abbreviate arg
201    res:=[:res,arg]
202  res
203
204condUnabbrev(op,arglist,argtypes,modeIfTrue) ==
205  #arglist ~= #argtypes =>
206    throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"),
207      bright(#arglist)])
208  [newArg for arg in arglist for type in argtypes] where newArg ==
209    categoryForm?(type) => unabbrev1(arg,modeIfTrue)
210    arg
211