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