open-axiom repository from github
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2011, 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 sys_-macros
import c_-util
namespace BOOT
--% Manipulation of Constructor Datat
--=======================================================================
-- Build Table of Lower Case Constructor Names
--=======================================================================
$lowerCaseConTb := nil
mkLowerCaseConTable() ==
--Called at system build time by function BUILD-INTERPSYS (see util.lisp)
--Table is referenced by functions conPageFastPath and grepForAbbrev
$lowerCaseConTb := makeTable function scalarEq?
for x in allConstructors() repeat augmentLowerCaseConTable x
$lowerCaseConTb
augmentLowerCaseConTable x ==
y:=getConstructorAbbreviationFromDB x
item:=[x,y,nil]
tableValue($lowerCaseConTb,x) := item
tableValue($lowerCaseConTb,DOWNCASE x) := item
tableValue($lowerCaseConTb,y) := item
getCDTEntry(info,isName) ==
not ident? info => nil
(entry := tableValue($lowerCaseConTb,info)) =>
[name,abb,:.] := entry
isName and sameObject?(name,info) => entry
not isName and sameObject?(abb,info) => entry
nil
entry
putConstructorProperty(name,prop,val) ==
null (entry := getCDTEntry(name,true)) => nil
entry.rest.rest := PUTALIST(CDDR entry,prop,val)
true
attribute? name ==
symbolMember?(name, $BuiltinAttributes)
abbreviation? abb ==
-- if it is an abbreviation, return the corresponding name
getConstructorFullNameFromDB abb
constructor? name ==
-- if it is a constructor name, return the abbreviation
getConstructorAbbreviationFromDB name
domainForm?: %Form -> %Boolean
domainForm? d ==
getConstructorKindFromDB opOf d is "domain"
packageForm?: %Form -> %Boolean
packageForm? d ==
getConstructorKindFromDB opOf d is "package"
categoryFrom?: %Form -> %Boolean
categoryForm? c ==
op := opOf c
builtinCategoryName? op => true
getConstructorKindFromDB op is "category"
-- probably will switch over to 'libName soon
getLisplibName(c) == getConstructorAbbreviation(c)
getConstructorAbbreviation: %Symbol -> %Symbol
getConstructorAbbreviation op ==
getConstructorAbbreviationFromDB op or throwKeyedMsg("S2IL0015",[op])
getConstructorUnabbreviation op ==
abbreviation?(op) or throwKeyedMsg("S2IL0019",[op])
mkUserConstructorAbbreviation(c,a,type) ==
if cons? c then c := first c -- Existing constructors will be wrapped
constructorAbbreviationErrorCheck(c,a,type,'abbreviationError)
clearClams()
clearConstructorCache(c)
installConstructor(c,type)
setAutoLoadProperty(c)
abbQuery(x) ==
abb := getConstructorAbbreviation x =>
sayKeyedMsg("S2IZ0001",[abb,getConstructorKindFromDB x,x])
sayKeyedMsg("S2IZ0003",[x])
installConstructor(cname,type) ==
$lowerCaseConTb = nil => nil
(entry := getCDTEntry(cname,true)) => entry
item := [cname,getConstructorAbbreviationFromDB cname,nil]
tableValue($lowerCaseConTb,cname) := item
tableValue($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 := # (s := symbolName a)
if typ = "category" and siz > 7
then throwKeyedErrorMsg('precompilation,"S2IL0021",nil)
if siz > 8 then throwKeyedErrorMsg('precompilation,"S2IL0006",nil)
if s ~= stringUpcase s then throwKeyedMsg("S2IL0006",nil)
abb := getConstructorAbbreviationFromDB c
name:= getConstructorFullNameFromDB a
type := getConstructorKindFromDB c
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 := getConstructorAbbreviationFromDB(op) =>
[abb,:condAbbrev(arglist,getPartialConstructorModemapSig(op))]
u
getConstructorAbbreviationFromDB(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
listMember?(domain,$LangSupportTypes) => true
constructor? opOf unabbrev x
unabbrev1(u,modeIfTrue) ==
u isnt [.,:.] =>
not ident? u => u -- surely not constructor abbrev
modeIfTrue =>
d:= isDomainValuedVariable u => u
a := abbreviation? u =>
niladicConstructor? a => [a]
largs := ['_$EmptyMode for arg in
getPartialConstructorModemapSig(a)]
unabbrev1([u,:largs],modeIfTrue)
u
a:= abbreviation?(u) or u
niladicConstructor? a => [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 in '(Mapping MappingCategory) =>
[op,:[unabbrev1(a,modeIfTrue) for a in arglist]]
op in '(Union UnionCategory) =>
[op,:[unabbrevUnionComponent(a,modeIfTrue) for a in arglist]]
op in '(Record RecordCategory) =>
[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 and argtypes isnt [["Tuple",t]] =>
throwKeyedMsg("S2IL0014",[op,plural(#argtypes,'"argument"),
bright(#arglist)])
-- fix up argument list for unary constructor taking tuples.
t ~= nil =>
categoryForm? t =>
[["tuple",:[unabbrev1(arg,modeIfTrue) for arg in arglist]]]
[["tuple",:arglist]]
[newArg for arg in arglist for type in argtypes] where newArg() ==
categoryForm?(type) => unabbrev1(arg,modeIfTrue)
arg
++ returns true if `op' is the name of a constructor.
++ Note: From this function point of view, a symbol names a
++ constructor if it is either a builtin constructor, or it is
++ known to the global database as designating a constructor. In
++ particular neither the category frame, nor the normal frame
++ are consulted. Consequently, this functions is not appropriate
++ for use in the compiler.
isConstructorName op ==
getConstructorAbbreviationFromDB op
or builtinConstructor? op
--% Code Being Phased Out
nAssocQ(x,l,n) ==
repeat
if l isnt [.,:.] then return nil
if sameObject?(x,first(l).n) then return first l
l:= rest l