open-axiom repository from github
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2016, 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 nruncomp
import g_-error
import c_-util
import database
namespace BOOT
module define where
compDefine: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple
compSubDomain: (%Form,%Mode,%Env) -> %Maybe %Triple
compCapsule: (%Form, %Mode, %Env) -> %Maybe %Triple
compJoin: (%Form,%Mode,%Env) -> %Maybe %Triple
compAdd: (%Form, %Mode, %Env) -> %Maybe %Triple
compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
evalCategoryForm: (%Form,%Env) -> %Maybe %Shell
getCategoryObjectIfCan: (%Table,%Form,%Env) -> %Maybe %Shell
getCategoryObject: (%Table,%Form,%Env) -> %Shell
--%
compDefine1: (%Maybe %Database,%Form,%Mode,%Env) -> %Maybe %Triple
$doNotCompileJustPrint := false
++ stack of pending capsule function definitions.
$capsuleFunctionStack := []
--%
$forceAdd := false
$functionStats := nil
$functorStats := nil
$functorTarget := nil
$condAlist := []
$uncondAlist := []
$NRTslot1PredicateList := []
$NRTattributeAlist := []
$signature := nil
$byteAddress := nil
$sigAlist := []
$predAlist := []
$argumentConditionList := []
$finalEnv := nil
$initCapsuleErrorCount := nil
$CapsuleModemapFrame := nil
$CapsuleDomainsInScope := nil
$signatureOfForm := nil
$addFormLhs := nil
++ True if the current functor definition refines a domain.
$subdomain := false
--%
compDefineAddSignature: (%Form,%Sig,%Env) -> %Env
--% ADDINFORMATION CODE
--% This code adds various items to the special value of $Information,
--% in order to keep track of all the compiler's information about
--% various categories and similar objects
--% An actual piece of (unconditional) information can have one of 3 forms:
--% (ATTRIBUTE domainname attribute)
--% --These are only stored here
--% (SIGNATURE domainname operator signature)
--% --These are also stored as 'modemap' properties
--% (has domainname categoryexpression)
--% --These are also stored as 'value' properties
--% Conditional attributes are of the form
--% (%when
--% (condition info info ...)
--% ... )
--% where the condition looks like a 'has' clause, or the 'and' of several
--% 'has' clauses:
--% (has name categoryexpression)
--% (has name (ATTRIBUTE attribute))
--% (has name (SIGNATURE operator signature))
--% The use of two representations is admitted to be clumsy
liftCond (clause is [ante,conseq]) ==
conseq is ['%when,:l] =>
[[lcAnd(ante,a),:b] for [a,:b] in l] where
lcAnd(pred,conj) ==
conj is ["and",:ll] => ["and",pred,:ll]
["and",pred,conj]
[clause]
formatPred(u,e) ==
u is ["has",a,b] =>
b isnt [.,:.] and isCategoryForm([b],e) => ["has",a,[b]]
b isnt [.,:.] => ["has",a,["ATTRIBUTE",b]]
isCategoryForm(b,e) => u
b is ["ATTRIBUTE",.] => u
b is ["SIGNATURE",:.] => u
["has",a,["ATTRIBUTE",b]]
u isnt [.,:.] => u
u is ["and",:v] => ["and",:[formatPred(w,e) for w in v]]
systemError ['"formatPred",u]
formatInfo(u,e) ==
u isnt [.,:.] => u
u is ["SIGNATURE",:v] => ["SIGNATURE","$",:v]
u is ["PROGN",:l] => ["PROGN",:[formatInfo(v,e) for v in l]]
u is ["ATTRIBUTE",v] =>
-- The parser can't tell between those attributes that really
-- are attributes, and those that are category names
v isnt [.,:.] and isCategoryForm([v],e) => ["has","$",[v]]
v isnt [.,:.] => ["ATTRIBUTE","$",v]
isCategoryForm(v,e) => ["has","$",v]
["ATTRIBUTE","$",v]
u is ["IF",a,b,c] =>
c is "%noBranch" =>
['%when,:liftCond [formatPred(a,e),formatInfo(b,e)]]
b is "%noBranch" =>
['%when,:liftCond [["not",formatPred(a,e)],formatInfo(c,e)]]
['%when,:liftCond [formatPred(a,e),formatInfo(b,e)],:
liftCond [["not",formatPred(a,e)],formatInfo(c,e)]]
systemError ['"formatInfo",u]
addInformation(m,e) ==
facts := ref nil -- list of facts to derive from `m'.
deduce(m,facts,e) where
deduce(m,facts,e) ==
m isnt [.,:.] => nil
m is ["CATEGORY",.,:stuff] =>
for u in stuff repeat
deref(facts) := [formatInfo(u,e),:deref facts]
m is ["Join",:stuff] =>
for u in stuff repeat deduce(u,facts,e)
nil
put("$Information","special",
[:deref facts,:get("$Information","special",e)],e)
hasToInfo (pred is ["has",a,b]) ==
b is ["SIGNATURE",:data] => ["SIGNATURE",a,:data]
b is ["ATTRIBUTE",c] => ["ATTRIBUTE",a,c]
pred
++ Return true if we are certain that the information
++ denotated by `pred' is derivable from the current environment `env'.
++ The third parameter `tbl' serves as a memo-table to help avoid
++ repeated computation of the same piece of information.
++ Note that because this is a compile-time determination, the value
++ computed by this subroutine is by necessary an approximation.
++ If it returns true, when we know for certain that the predicate
++ will hold also at runtime. However, if it returns false the predicate
++ may or may not hold at runtime.
knownInfo(pred,env,tbl == makeTable function valueEq?) ==
pred=true => true
tableValue(tbl,pred) => true -- re-use previously computed value
listMember?(pred,get("$Information","special",env)) =>
tableValue(tbl,pred) := true
pred is ["OR",:l] => or/[knownInfo(u,env,tbl) for u in l]
pred is ["AND",:l] => and/[knownInfo(u,env,tbl) for u in l]
pred is ["or",:l] => or/[knownInfo(u,env,tbl) for u in l]
pred is ["and",:l] => and/[knownInfo(u,env,tbl) for u in l]
pred is ["ATTRIBUTE",name,attr] =>
v := compForMode(name,$EmptyMode,env) or return
stackAndThrow('"can't find category of %1pb",[name])
[vv,.,.] := compMakeCategoryObject(v.mode,env) or return
stackAndThrow('"can't make category of %1pb",[name])
listMember?(attr,categoryAttributes vv) =>
tableValue(tbl,pred) := true
x := assoc(attr,categoryAttributes vv) =>
--format is a list of two elements: information, predicate
tableValue(tbl,pred) := knownInfo(second x,env,tbl)
false
pred is ["has",name,cat] =>
cat is ["ATTRIBUTE",:a] =>
tableValue(tbl,pred) := knownInfo(["ATTRIBUTE",name,:a],env,tbl)
cat is ["SIGNATURE",:a] =>
tableValue(tbl,pred) := knownInfo(["SIGNATURE",name,:a],env,tbl)
-- unnamed category expressions imply structural checks.
cat is ["Join",:.] =>
tableValue(tbl,pred) :=
and/[knownInfo(["has",name,c],env,tbl) for c in cat.args]
cat is ["CATEGORY",.,:atts] =>
tableValue(tbl,pred) :=
and/[knownInfo(hasToInfo ["has",name,att],env,tbl) for att in atts]
name is ['Union,:.] => false
-- we have a named category expression
v:= compForMode(name,$EmptyMode,env) or return
stackAndThrow('"can't find category of %1pb",[name])
vmode := v.mode
cat = vmode => tableValue(tbl,pred) := true
vmode is ["Join",:l] and listMember?(cat,l) =>
tableValue(tbl,pred) := true
[vv,.,.]:= compMakeCategoryObject(vmode,env) or return
stackAndThrow('"cannot find category %1pb",[vmode])
listMember?(cat,categoryPrincipals vv) =>
--checks princ. ancestors
tableValue(tbl,pred) := true
(u:=assoc(cat,categoryAncestors vv)) and knownInfo(second u,env,tbl) =>
tableValue(tbl,pred) := true
-- previous line checks fundamental anscestors, we should check their
-- principal anscestors but this requires instantiating categories
or/[ancestor?(cat,[first u],tbl,env)
for u in categoryAncestors vv | knownInfo(second u,env,tbl)] =>
tableValue(tbl,pred) := true
false
pred is ["SIGNATURE",name,op,sig,:.] =>
v:= get(op,"modemap",env)
for w in v repeat
ww := w.mmSignature --the actual signature part
ww = sig =>
w.mmCondition = true => return (tableValue(tbl,pred) := true)
false
--error '"knownInfo"
false
mkJoin(cat,mode) ==
mode is ['Join,:cats] => ['Join,cat,:cats]
['Join,cat,mode]
getvalue(name,e) ==
u := get(name,"value",e) => u
u := comp(name,$EmptyMode,e) => u --name may be a form
systemError [name,'" is not bound in the current environment"]
actOnInfo(u,$e) ==
null u => $e
u is ["PROGN",:l] =>
for v in l repeat $e := actOnInfo(v,$e)
$e
db := currentDB $e
$e:=
put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e
)
u is ['%when,:l] =>
--there is nowhere %else that this sort of thing exists
for [ante,:conseq] in l repeat
if listMember?(hasToInfo ante,Info) then for v in conseq repeat
$e := actOnInfo(v,$e)
$e
u is ["ATTRIBUTE",name,att] =>
[vval,vmode,.] := getvalue(name,$e)
compilerMessage('"augmenting %1: %2p", [name,["ATTRIBUTE",att]])
key :=
-- FIXME: there should be a better to tell whether name
-- designates a domain, as opposed to a package
CONTAINED("$",vmode) => 'domain
'package
cat := ["CATEGORY",key,["ATTRIBUTE",att]]
$e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
--there is nowhere %else that this sort of thing exists
u is ["SIGNATURE",name,operator,modemap,:q] =>
kind :=
q is ["constant"] => "CONST"
"ELT"
implem:=
(implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) =>
CADADR implem
name = "$" => [kind,name,-1]
[kind,name,substitute('$,name,modemap)]
$e:= addModemap(operator,name,modemap,true,implem,$e)
[vval,vmode,.] := getvalue(name,$e)
compilerMessage('"augmenting %1: %2p",
[name,["SIGNATURE",operator,modemap,:q]])
key :=
-- FIXME: there should be a better to tell whether name
-- designates a domain, as opposed to a package
CONTAINED("$",vmode) => 'domain
'package
cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap,:q]]
$e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
u is ["has",name,cat] =>
[vval,vmode,.] := getvalue(name,$e)
cat=vmode => $e --stating the already known
u:= compMakeCategoryObject(cat,$e) =>
--we are adding information about a category
[catvec,.,$e]:= u
[ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e)
--we are adding a principal descendant of what was already known
listMember?(cat,categoryPrincipals ocatvec) or
assoc(cat,categoryAncestors ocatvec) is [.,"T",.] => $e
--what was being asserted is an ancestor of what was known
if name="$"
then $e:= augModemapsFromCategory(db,name,name,cat,$e)
else
genDomainView(db,name,cat,"HasCategory")
-- a domain upgrade at function level is local to that function.
if not $insideCapsuleFunctionIfTrue and
not symbolMember?(name,$functorLocalParameters) then
$functorLocalParameters:=[:$functorLocalParameters,name]
compilerMessage('"augmenting %1: %2p", [name,cat])
$e:= put(name,"value",[vval,mkJoin(cat,vmode),nil],$e)
SAY("extension of ",vval," to ",cat," ignored")
$e
systemError ['"actOnInfo",u]
infoToHas a ==
a is ["SIGNATURE",b,:data] => ["has",b,["SIGNATURE",:data]]
a is ["ATTRIBUTE",b,c] => ["has",b,["ATTRIBUTE",c]]
a
chaseInferences(pred,$e) ==
foo hasToInfo pred where
foo pred ==
knownInfo(pred,$e) => nil
$e := actOnInfo(pred,$e)
pred:= infoToHas pred
for u in get("$Information","special",$e) repeat
u is ['%when,:l] =>
for [ante,:conseq] in l repeat
ante=pred => [foo w for w in conseq]
ante is ["and",:ante'] and listMember?(pred,ante') =>
ante':= remove(ante',pred)
v':=
# ante'=1 => first ante'
["and",:ante']
v':= ['%when,[v',:conseq]]
listMember?(v',get("$Information","special",$e)) => nil
$e:=
put("$Information","special",[v',:
get("$Information","special",$e)],$e)
nil
$e
--%
--=======================================================================
-- Generate Code to Create Infovec
--=======================================================================
++ Called by compDefineFunctor1 to create infovec at compile time
getInfovecCode(db,e) ==
$byteAddress: local := 0
['LIST,
MKQ makeDomainTemplate db,
MKQ makeCompactDirect(db,makeSlot1Info db),
MKQ genFinalAttributeAlist(db,e),
makeCategoryAlist(db,e),
MKQ dbLookupFunction db]
--=======================================================================
-- Generation of Domain Vector Template (Compile Time)
--=======================================================================
makeDomainTemplate db ==
--NOTES: This function is called at compile time to create the template
-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1
vec := dbTemplate db
for index in 0..maxIndex vec repeat
item := domainRef(vec,index)
item isnt [.,:.] => nil
domainRef(vec,index) :=
cons? first item => makeGoGetSlot(db,item,index)
item
dbByteList(db) := "append"/reverse! dbByteList db
vec
makeGoGetSlot(db,item,index) ==
--NOTES: creates byte vec strings for LATCH slots
--these parts of the dbByteList are created first; see also makeCompactDirect
[sig,whereToGo,op,:flag] := item
n := #sig - 1
newcode := [n,whereToGo,:makeCompactSigCode sig,index]
dbByteList(db) := [newcode,:dbByteList db]
curAddress := $byteAddress
$byteAddress := $byteAddress + n + 4
[curAddress,:op]
--=======================================================================
-- Generate OpTable at Compile Time
--=======================================================================
--> called by getInfovecCode (see top of this file) from compDefineFunctor1
makeCompactDirect(db,u) ==
$predListLength :local := # $NRTslot1PredicateList
$byteVecAcc: local := nil
[nam,[addForm,:opList]] := u
--pp opList
d := [:[op,y] for [op,:items] in opList
| y := makeCompactDirect1(db,op,items)]
dbByteList(db) := [:dbByteList db,:"append"/reverse! $byteVecAcc]
dbOperationTable(db) := vector d
makeCompactDirect1(db,op,items) ==
--NOTES: creates byte codes for ops implemented by the domain
curAddress := $byteAddress
$op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption)
newcodes := "append"/[u for y in orderBySubsumption items |
u := fn(db,y)] or return nil
$byteVecAcc := [newcodes,:$byteVecAcc]
curAddress
where fn(db,y) ==
[sig,:r] := y
r = ['Subsumed] =>
n := #sig - 1
$byteAddress := $byteAddress + n + 4
[n,0,:makeCompactSigCode sig,0] --always followed by subsuming signature
--identified by a 0 in slot position
if r is [n,:s] then
slot :=
n is [p,:.] => p --the rest is linenumber of function definition
n
predCode :=
s is [pred,:.] => predicateBitIndex(db,pred,$e)
0
--> drop items which are not present (predCode = -1)
predCode = -1 => return nil
--> drop items with nil slots if lookup function is incomplete
if null slot then
dbLookupFunction db is 'lookupIncomplete => return nil
slot := 1 --signals that operation is not present
n := #sig - 1
$byteAddress := $byteAddress + n + 4
res := [n,predCode,:makeCompactSigCode sig,slot]
res
orderBySubsumption items ==
acc := subacc := nil
for x in items repeat
not ($op in '(Zero One)) and x is [.,.,.,'Subsumed] =>
subacc := [x,:subacc]
acc := [x,:acc]
y := z := nil
for [a,b,:.] in subacc | b repeat
--NOTE: b = nil means that the signature a will appear in acc, that this
-- entry is be ignored (e.g. init: -> $ in ULS)
while (u := assoc(b,subacc)) repeat b := second u
u := assoc(b,acc) or systemError nil
if null second u then u := [first u,1] --mark as missing operation
y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed
z := insert(b,z) --mark a signature as already present
[:y,:[w for (w := [c,:.]) in acc | not listMember?(c,z)]] --add those not subsuming
makeCompactSigCode sig == [fn for x in sig] where
fn() ==
x is "$$" => 2
x is "$" => 0
not integer? x =>
systemError ['"code vector slot is ",x,'"; must be number"]
x
--=======================================================================
-- Generate Slot 4 Constructor Vectors
--=======================================================================
depthAssocList(u,cache) ==
u := removeSymbol(u,'DomainSubstitutionMacro) --hack by RDJ 8/90
removeDuplicates ("append"/[depthAssoc(y,cache) for y in u])
depthAssoc(x,cache) ==
y := tableValue(cache,x) => y
x is ['Join,:u] or (u := substSource parentsOfForm x) =>
v := depthAssocList(u,cache)
tableValue(cache,x) := [[x,:n],:v]
where n() == 1 + "MAX"/[rest y for y in v]
tableValue(cache,x) := [[x,:0]]
makeCategoryAlist(db,e) ==
pcAlist := [:[[x,:true] for x in $uncondAlist],:$condAlist]
levelAlist := depthAssocList(substSource pcAlist,hashTable 'EQUAL)
opcAlist := sortBy(function(x +-> LASSOC(first x,levelAlist)),pcAlist)
newPairlis := [[i,:b] for [.,:b] in dbFormalSubst db for i in $NRTbase..]
slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
| (k := predicateBitIndex(db,b,e)) ~= -1]
slot0 := [getCategoryConstructorDefault a.op for [a,:.] in slot1]
sixEtc := [$AddChainIndex + i for i in 1..dbArity db]
formals := substTarget dbFormalSubst db
for x in slot1 repeat
x.first := applySubst(pairList(['$,:formals],["$$",:sixEtc]),first x)
-----------code to make a new style slot4 -----------------
predList := substTarget slot1 --is list of predicate indices
maxPredList := "MAX"/predList
catformvec := substSource slot1
maxElement := "MAX"/dbByteList db
['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList],
['CONS, MKQ vector slot0,
['CONS, MKQ vector [encodeCatform(db,x) for x in catformvec],
['makeByteWordVec2,maxElement,MKQ dbByteList db]]]]
--NOTE: this is new form: old form satisfies vector? CDDR form
encodeCatform(db,x) ==
x is '$ => x
k := assocIndex(db,x) => k
x isnt [.,:.] or rest x isnt [.,:.] => x
[first x,:[encodeCatform(db,y) for y in rest x]]
++ Like getmode, except that if the mode is local variable with
++ defined value, we want that value instead.
getXmode(x,e) ==
m := getmode(x,e) or return nil
ident? m and get(m,'%macro,e) or m
--=======================================================================
-- Compute the lookup function (complete or incomplete)
--=======================================================================
NRTgetLookupFunction(db,addForm,tbl,env) ==
$why: local := nil
domform := dbSubstituteFormals(db,dbConstructorForm db)
cat := dbCategory db
addForm isnt [.,:.] =>
ident? addForm and (m := getmode(addForm,env)) ~= nil and
isCategoryForm(m,env) and
extendsCategory(db,domform,cat,dbSubstituteFormals(db,m),tbl,env) =>
'lookupIncomplete
'lookupComplete
addForm := dbSubstituteFormals(db,addForm)
NRTextendsCategory1(db,domform,cat,getBaseExports(db,addForm),tbl,env) =>
'lookupIncomplete
[u,msg,:v] := $why
SAY '"--------------non extending category----------------------"
sayPatternMsg('"%1p of category %2p", [domform,u])
if v ~= nil then
sayPatternMsg('"%1b %2p",[msg,first v])
else
sayPatternMsg('"%1b",[msg])
SAY '"----------------------------------------------------------"
'lookupComplete
getBaseExports(db,form) ==
[op,:argl] := form
op is 'Record => ['RecordCategory,:argl]
op is 'Union => ['UnionCategory,:argl]
op is 'Enumeration => ['EnumerationCategory,:argl]
op is 'Mapping => ['MappingCategory,:argl]
op is '%Comma => ['Join,
:[getBaseExports(db,substSlotNumbers(x,dbTemplate db,dbConstructorForm db))
for x in argl]]
[[.,target,:tl],:.] := getConstructorModemap op
applySubst(pairList($FormalMapVariableList,argl),target)
NRTextendsCategory1(db,domform,exCategory,addForm,tbl,env) ==
addForm is ["%Comma",:r] =>
and/[extendsCategory(db,domform,exCategory,x,tbl,env) for x in r]
extendsCategory(db,domform,exCategory,addForm,tbl,env)
--=======================================================================
-- Compute if a domain constructor is forgetful functor
--=======================================================================
extendsCategory(db,dom,u,v,tbl,env) ==
--does category u extend category v (yes iff u contains everything in v)
--is dom of category u also of category v?
u=v => true
v is ["Join",:l] => and/[extendsCategory(db,dom,u,x,tbl,env) for x in l]
v is ["CATEGORY",.,:l] =>
and/[extendsCategory(db,dom,u,x,tbl,env) for x in l]
v is ["SubsetCategory",cat,d] =>
extendsCategory(db,dom,u,cat,tbl,env) and isSubset(dom,d,env)
v := substSlotNumbers(v,dbTemplate db,dbConstructorForm db)
extendsCategoryBasic(dom,u,v,tbl,env) => true
$why :=
v is ['SIGNATURE,op,sig,:.] =>
[u,['" has no ",:formatOpSignature(op,sig)]]
[u,'" has no",v]
nil
extendsCategoryBasic(dom,u,v,tbl,env) ==
v is ['IF,p,['ATTRIBUTE,c],.] =>
uVec := getCategoryObjectIfCan(tbl,u,env) or return false
cons? c and isCategoryForm(c,env) =>
LASSOC(c,categoryAncestors uVec) is [=p,:.]
LASSOC(c,categoryAttributes uVec) is [=p,:.]
u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l]
u = v => true
v is ['ATTRIBUTE,c] =>
cons? c and isCategoryForm(c,env) =>
extendsCategoryBasic(dom,u,c,tbl,env)
u is ['CATEGORY,.,:l] =>
or/[extendsCategoryBasic(dom,x,v,tbl,env) for x in l]
uVec := getCategoryObjectIfCan(tbl,u,env) or return false
LASSOC(c,categoryAttributes uVec) is [=true]
isCategoryForm(v,env) => catExtendsCat?(u,v,tbl,env)
v is ['SIGNATURE,op,sig,:.] =>
uVec := getCategoryObjectIfCan(tbl,u,env) or return false
or/[categoryRef(uVec,i) is [[=op,=sig],:.] for i in $NRTbase..maxIndex uVec]
u is ['CATEGORY,.,:l] =>
v is ['IF,:.] => listMember?(v,l)
false
false
catExtendsCat?(u,v,tbl,env) ==
u = v => true
uvec := getCategoryObject(tbl,u,env)
prinAncestorList := categoryPrincipals uvec
listMember?(v,prinAncestorList) => true
vOp := KAR v
if similarForm := assoc(vOp,prinAncestorList) then
PRINT u
sayBrightlyNT '" extends "
PRINT similarForm
sayBrightlyNT '" but not "
PRINT v
or/[catExtendsCat?(x,v,tbl,env) for x in substSource categoryAncestors uvec]
substSlotNumbers(form,template,domain) ==
form is ['SIGNATURE,op,sig,:q] =>
['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig],:q]
form is ['CATEGORY,k,:u] =>
['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]]
expandType(form,template,domain)
expandType(lazyt,template,domform) ==
lazyt isnt [.,:.] => expandTypeArgs(lazyt,template,domform)
[functorName,:argl] := lazyt
functorName is ":" =>
[functorName,first argl,expandTypeArgs(second argl,template,domform)]
lazyt is ['local,x] =>
n := symbolPosition(x,$FormalMapVariableList)
domform.(1 + n)
[functorName,:[expandTypeArgs(a,template,domform) for a in argl]]
expandTypeArgs(u,template,domform) ==
u is '$ => u
integer? u => expandType(vectorRef(template,u),template,domform)
u is [.,y] and u.op in '(%eval QUOTE) => y
u isnt [.,:.] => u
expandType(u,template,domform)
folks u == --called by getParentsFor
u isnt [.,:.] => nil
u is [op,:v] and op in '(Join PROGN)
or u is ['CATEGORY,.,:v] => "append"/[folks x for x in v]
u is ['SIGNATURE,:.] => nil
u is ['ATTRIBUTE,a] =>
a is [.,:.] and constructor? a.op => folks a
nil
u is ['IF,p,q,r] =>
q1 := folks q
r1 := folks r
q1 or r1 => [['IF,p,q1,r1]]
nil
[u]
explodeIfs x == main where --called by getParentsFor
main() ==
x is ['IF,p,a,b] => fn(p,a,b)
[[x,:true]]
fn(p,a,b) ==
[:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]]
gn(p,a) ==
a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil)
[[a,:p]]
getParentsFor db ==
constructorForm := dbConstructorForm db
n := #constructorForm.args
s1 := pairList(take(n,$TriangleVariableList),$FormalMapVariableList)
s2 := pairList($FormalMapVariableList,constructorForm.args)
[:explodeIfs applySubst(s2,applySubst(s1,x)) for x in folks dbCategory db]
--% Subdomains
++ We are defining a functor with head given by `form', as a subdomain
++ of the domain designated by the domain form `super', and predicate
++ `pred' (a VM instruction form). Emit appropriate info into the
++ databases.
emitSubdomainInfo(form,super,pred) ==
pred := applySubst!(pairList(form.args,$AtVariables),pred)
super := applySubst!(pairList(form.args,$AtVariables),super)
dbSuperDomain(constructorDB form.op) := [super,pred]
++ List of operations defined in a given capsule
++ Each item on this list is of the form
++ (op sig pred)
++ where
++ op: name of the operation
++ sig: signature of the operation
++ pred: scope predicate of the operation.
$capsuleFunctions := nil
++ record that the operation `op' with signature `sig' and predicate
++ `pred' is defined in the current capsule of the current domain
++ being compiled.
noteCapsuleFunctionDefinition(op,sig,pred) ==
listMember?([op,sig,pred],$capsuleFunctions) =>
stackAndThrow('"redefinition of %1b: %2 %3",
[op,formatUnabbreviated ["Mapping",:sig],formatIf pred])
$capsuleFunctions := [[op,sig,pred],:$capsuleFunctions]
++ Clear the list of functions defined in the last domain capsule.
clearCapsuleFunctionTable() ==
$capsuleFunctions := nil
++ List of exports (paireed with scope predicate) declared in
++ the category of the currend domain or package.
++ Note: for category packages, this list is nil.
$exports := nil
noteExport(db,form,pred) ==
-- don't recheck category package exports; we just check
-- them when defining the category. Plus, we might actually
-- get indirect duplicates, which is OK.
$insideCategoryPackageIfTrue => nil
listMember?([form,pred],$exports) =>
stackAndThrow('"redeclaration of %1 %2",
[form,formatIf pred])
$exports := [[form,pred],:$exports]
clearExportsTable() ==
$exports := nil
makePredicate l ==
null l => true
MKPF(l,"and")
--% FUNCTIONS WHICH MUNCH ON == STATEMENTS
++ List of reserved identifiers for which the compiler has special
++ meanings and that shall not be redefined.
$reservedNames == '(per rep _$)
++ Check that `var' (a variable of parameter name) is not a reversed name.
checkVariableName var ==
symbolMember?(var,$reservedNames) =>
stackAndThrow('"You cannot use reserved name %1b as variable",[var])
var
checkParameterNames parms ==
for p in parms repeat
checkVariableName p
compDefine(db,form,m,e) ==
$macroIfTrue: local := false
compDefine1(db,form,m,e)
++ We are about to process the body of a capsule. Check the form of
++ `Rep' definition, and whether it is appropriate to activate the
++ implicitly generated morphisms
++ per: Rep -> %
++ rep: % -> Rep
++ as local inline functions.
checkRepresentation: (%Thing, %Form,%List %Form,%Env) -> %Env
checkRepresentation(db,addForm,body,env) ==
domainRep := nil
hasAssignRep := false -- assume code does not assign to Rep.
viewFuns := nil
null body => env -- Don't be too hard on nothing.
-- Locate possible Rep definition
for [stmt,:.] in tails body repeat
stmt is [":=","Rep",val] =>
domainRep ~= nil =>
stackAndThrow('"You cannot assign to constant domain %1b",["Rep"])
if addForm = val then
stackWarning('"OpenAxiom suggests removing assignment to %1b",["Rep"])
else if addForm ~= nil then
stackWarning('"%1b differs from the base domain",["Rep"])
return hasAssignRep := true
stmt is ["MDEF","Rep",:.] =>
stackWarning('"Consider using == definition for %1b",["Rep"])
return hasAssignRep := true
stmt is ["IF",.,:l] or stmt is ["SEQ",:l] or stmt is ["exit",:l] =>
checkRepresentation(db,nil,l,env)
stmt isnt ["DEF",lhs,sig,val] => nil -- skip for now.
op := opOf lhs
op in '(rep per) =>
domainRep ~= nil =>
stackAndThrow('"You cannot define implicitly generated %1b",[op])
viewFuns := [op,:viewFuns]
op ~= "Rep" => nil -- we are only interested in Rep definition
domainRep := val
viewFuns ~= nil =>
stackAndThrow('"You cannot define both %1b and %2b",["Rep",:viewFuns])
-- A package has no "%".
dbConstructorKind db = "package" =>
stackAndThrow('"You cannot define %1b in a package",["Rep"])
-- It is a mistake to define Rep in category defaults
$insideCategoryPackageIfTrue =>
stackAndThrow('"You cannot define %1b in category defaults",["Rep"])
if lhs is [.,.,:.] then --FIXME: ideally should be 'lhs is [.,:.]'
stackAndThrow('"%1b does take arguments",["Rep"])
if sig.target ~= nil then
stackAndThrow('"You cannot specify type for %1b",["Rep"])
-- Now, trick the rest of the compiler into believing that
-- `Rep' was defined the Old Way, for lookup purpose.
stmt.op := ":="
stmt.args := ["Rep",domainRep]
$useRepresentationHack := false -- Don't confuse `Rep' and `%'.
-- Shall we perform the dirty tricks?
if hasAssignRep then
$useRepresentationHack := true
-- Domain extensions with no explicit Rep definition have the
-- the base domain as representation (at least operationally).
else if null domainRep and addForm ~= nil then
if dbConstructorKind db = "domain" and addForm isnt ["%Comma",:.] then
domainRep :=
addForm is ["SubDomain",dom,.] =>
$subdomain := true
dom
addForm
$useRepresentationHack := false
env := putMacro('Rep,domainRep,env)
env
getSignatureFromMode(form,e) ==
getXmode(opOf form,e) is ['Mapping,:signature] =>
#form~=#signature => stackAndThrow ["Wrong number of arguments: ",form]
applySubst(pairList($FormalMapVariableList,form.args),signature)
compDefine1(db,form,m,e) ==
$insideExpressionIfTrue: local:= false
--1. decompose after macro-expanding form
['DEF,lhs,signature,rhs] := form := macroExpand(form,e)
$insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode)
=> [lhs,m,putMacro(lhs.op,rhs,e)]
if lhs is [.,:.] then
checkParameterNames lhs.args
null signature.target and symbol? KAR rhs and not builtinConstructor? KAR rhs and
(sig := getSignatureFromMode(lhs,e)) =>
-- here signature of lhs is determined by a previous declaration
compDefine1(db,['DEF,lhs,[sig.target,:signature.source],rhs],m,e)
if not $insideCategoryPackageIfTrue and not $insideFunctorIfTrue and not $bootStrapMode then
-- evaluate signature
SAY("debug: compDefine1 lhs: ", lhs)
parameters
$param := rest lhs
-- $SL := NIL
--for arg in $param for dom in rest signature repeat
-- SAY("debug: compDefine1 augmentSub arg: ", arg, " dom: ", dom)
-- $SL:=augmentSub(arg, dom, $SL)
--SAY("debug: compDefine1 $SL: ",$SL)
SAY(" signature (pre-evaluate): ", signature)
$genValue:local := false
signature := [(null sig => NIL;evaluateType sig) for sig in signature]
--$param := []
SAY("debug: compDefine1 signature (post evaluate): ", signature)
--form := ['DEF,lhs,signature,specialCases,rhs]
-- RDJ (11/83): when argument and return types are all declared,
-- or arguments have types declared in the environment,
-- and there is no existing modemap for this signature, add
-- the modemap by a declaration, then strip off declarations and recurse
if lhs is [.,:.] then
e := compDefineAddSignature(lhs,signature,e)
-- 2. if signature list for arguments is not empty, replace ('DEF,..) by
-- ('where,('DEF,..),..) with an empty signature list;
-- otherwise, fill in all NILs in the signature
lhs is [.,:.] and (or/[x ~= nil for x in signature.source]) =>
compDefWhereClause(form,m,e)
signature.target=$Category =>
compDefineCategory(form,m,e,$formalArgList)
isDomainForm(rhs,e) and not $insideFunctorIfTrue =>
if lhs is [.,:.] then
e := giveFormalParametersValues(lhs.args,e)
if signature.target = nil then
signature := [getTargetFromRhs(lhs,rhs,e),:signature.source]
rhs := addEmptyCapsuleIfNecessary(signature.target,rhs)
compDefineFunctor(['DEF,lhs,signature,rhs],m,e,$formalArgList)
db = nil =>
-- no free function in library, yet.
stackAndThrow ['"malformed definition syntax:",form]
newPrefix :=
$prefix => makeSymbol strconc(symbolName $prefix,'",",symbolName $op)
dbAbbreviation db
compDefineCapsuleFunction(db,form,m,e,newPrefix,$formalArgList)
compDefineAddSignature([op,:argl],signature,e) ==
(sig:= hasFullSignature(argl,signature,e)) and
null assoc(['$,:sig],symbolTarget('modemap,getProplist(op,e))) =>
declForm:=
[":",[op,:[[":",x,m] for x in argl for m in sig.source]],signature.target]
[.,.,e]:= comp(declForm,$EmptyMode,e)
e
e
hasFullSignature(argl,[target,:ml],e) ==
target =>
u := [m or get(x,"mode",e) or return 'failed for x in argl for m in ml]
u is 'failed => nil
[target,:u]
nil
addEmptyCapsuleIfNecessary: (%Form,%Form) -> %Form
addEmptyCapsuleIfNecessary(target,rhs) ==
symbolMember?(KAR rhs,$SpecialDomainNames) => rhs
['add,rhs,['CAPSULE]]
++ We are about to elaborate a functor definition, but there
++ is no source-level user-supplied target mode on the result.
++ Attempt to infer the target type by compiling the body.
getTargetFromRhs: (%Form, %Form, %Env) -> %Form
getTargetFromRhs(lhs,rhs,e) ==
--undeclared target mode obtained from rhs expression
rhs is ['CAPSULE,:.] =>
stackSemanticError(['"target category of ",lhs,
'" cannot be determined from definition"],nil)
rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e)
rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e)
rhs is ['Record,:l] => ['RecordCategory,:l]
rhs is ['Union,:l] => ['UnionCategory,:l]
mode(rhs,e) where
mode(x,e) ==
$onlyAbstractSlot: local := true -- not yet in codegen phase.
compOrCroak(x,$EmptyMode,e).mode
giveFormalParametersValues(argl,e) ==
for x in argl | ident? x repeat
e := giveVariableSomeValue(x,get(x,'mode,e),e)
e
macroExpand!: (%Form,%Env) -> %Form
macroExpand!(x,e) ==
y:= macroExpand(x,e)
x isnt [.,:.] or y isnt [.,:.] => y
x.first := first y
x.rest := rest y
x
macroExpand: (%Form,%Env) -> %Form
macroExpand(x,e) == --not worked out yet
x isnt [.,:.] =>
not ident? x or (u := get(x,"macro",e)) = nil => x
-- Don't expand a functional macro name by itself.
u is ['%mlambda,:.] => x
macroExpand(u,e)
x is ['DEF,lhs,sig,rhs] =>
['DEF,lhs,macroExpandList(sig,e),macroExpand(rhs,e)]
-- macros should override niladic props
[op,:args] := x
ident? op and args = nil and niladicConstructor? op and
(u := get(op,"macro", e)) => macroExpand(u,e)
ident? op and (get(op,"macro",e) is ['%mlambda,parms,body]) =>
nargs := #args
nparms := #parms
msg :=
nargs < nparms => '"Too few arguments"
nargs > nparms => '"Too many arguments"
nil
msg => (stackMessage(strconc(msg,'" to macro %1bp"),[op]); x)
args' := macroExpandList(args,e)
applySubst(pairList(parms,args'),body)
macroExpandList(x,e)
macroExpandList(l,e) ==
[macroExpand(x,e) for x in l]
--% constructor evaluation
mkEvalableCategoryForm c ==
c is [op,:argl] =>
op is "DomainSubstitutionMacro" => mkEvalableCategoryForm second argl
op in '(QUOTE mkCategory EnumerationCategory) => c
op is ":" => [op,second c,mkEvalableCategoryForm third c]
op in '(CATEGORY SubsetCategory) =>
[x,m,$e] := compOrCroak(c,$EmptyMode,$e)
m = $Category => x
MKQ c
categoryConstructor? op =>
[op,:[mkEvalableCategoryForm x for x in argl]]
MKQ c
MKQ c
evalCategoryForm(x,e) ==
eval mkEvalableCategoryForm x
++ Return true if we should skip compilation of category package.
++ This situation happens either when there is no default, of we are in
++ bootstrap mode.
skipCategoryPackage? capsule ==
null capsule or $bootStrapMode
compDefineCategory1(db,df is ['DEF,form,sig,body],m,e,fal) ==
categoryCapsule :=
body is ['add,cat,capsule] =>
body := cat
capsule
nil
if form isnt [.,:.] then
form := [form]
[d,m,e]:= compDefineCategory2(db,form,sig,body,m,e,fal)
if not skipCategoryPackage? categoryCapsule then [.,.,e] :=
$insideCategoryPackageIfTrue: local := true
$categoryPredicateList: local := makeCategoryPredicates db
defaults := mkCategoryPackage(db,cat,categoryCapsule,e)
T := compDefine1(nil,defaults,$EmptyMode,e)
or return stackSemanticError(
['"cannot compile defaults of",:bright opOf form],nil)
[d,m,e]
makeCategoryPredicates db ==
n := dbArity db
sl := pairList(take(n,$TriangleVariableList),take(n,rest $FormalMapVariableList))
fn(dbCategory db,sl,nil) where
fn(u,sl,pl) ==
u is ['Join,:.,a] => fn(a,sl,pl)
u is ["IF",p,:x] => fnl(x,sl,insert(applySubst(sl,p),pl))
u is ["has",:.] => insert(applySubst(sl,u),pl)
u is [op,:.] and op in '(SIGNATURE ATTRIBUTE) => pl
u isnt [.,:.] => pl
fnl(u,sl,pl)
fnl(u,sl,pl) ==
for x in u repeat pl := fn(x,sl,pl)
pl
++ Subroutine of mkCategoryPackage.
++ Return a category-level declaration of an operation described by `desc'.
mkExportFromDescription desc ==
t :=
desc.mapKind = 'CONST => ['constant]
nil
['SIGNATURE,desc.mapOperation,desc.mapSignature,:t]
mkCategoryPackage(db,cat,def,e) ==
[op,:argl] := dbConstructorForm db
packageName:= makeDefaultPackageName symbolName op
dbConstructorDefault(db) := packageName
packageAbb := makeDefaultPackageAbbreviation db
$options:local := []
-- This stops the next line from becoming confused
abbreviationsSpad2Cmd ['package,packageAbb,packageName]
-- This is a little odd, but the parser insists on calling
-- domains, rather than packages
packageArgl := makeDefaultPackageParameters db
nameForDollar := first packageArgl
capsuleDefAlist := fn(def,nil) where fn(x,oplist) ==
x isnt [.,:.] => oplist
x is ['DEF,y,:.] => [opOf y,:oplist]
fn(x.args,fn(x.op,oplist))
catvec := evalCategoryForm(dbConstructorForm db,e)
fullCatOpList := categoryExports JoinInner([catvec],e)
catOpList :=
[mkExportFromDescription desc for desc in fullCatOpList
| symbolMember?(desc.mapOperation,capsuleDefAlist)]
null catOpList => nil
packageCategory :=
['CATEGORY,'package,
:applySubst(pairList($FormalMapVariableList,argl),catOpList)]
nils:= [nil for x in argl]
packageSig := [packageCategory,dbConstructorForm db,:nils]
$categoryPredicateList := substitute(nameForDollar,'$,$categoryPredicateList)
substitute(nameForDollar,'$,['DEF,[packageName,:packageArgl],packageSig,def])
++ Return the typing constraint operator for `t' in the environment `e'.
typingKind(t,e) ==
isCategoryForm(t,e) => 'ofCategory
'ofType
++ Subroutine of compDefineFunctor1 and compDefineCategory2.
++ Given a constructor definition defining `db', compute implicit
++ parameters and store that list in `db'.
deduceImplicitParameters(db,e) ==
parms := dbParameters db
nonparms := [x for [x,:.] in get('%compilerData,'%whereDecls,e)
| not symbolMember?(x,parms)]
nonparms = nil => true
-- Collect all first-order dependencies.
preds := nil
qvars := $QueryVariables
subst := nil
for p in parms for i in 1.. repeat
m := getXmode(p,e)
ident? m and symbolMember?(m,nonparms) =>
stackAndThrow('"Parameter %1b cannot be of type implicit parameter %2pb",
[p,m])
m isnt [.,:.] => nil
preds := [[typingKind(m,e),dbSubstituteFormals(db,p),m],:preds]
st := [qpair for a in m.args for [v,:qvars] in tails qvars
| ident? a and symbolMember?(a,nonparms)] where
qpair() ==
t := getXmode(a,e)
preds := [[typingKind(t,e),a,t],:preds]
[a,:v]
subst := [:st,:subst]
-- Now, build the predicate for implicit parameters.
for s in nonparms repeat
x := [rest y for y in subst | symbolEq?(s,first y)]
x = nil =>
stackAndThrow('"Implicit parameter %1b has no visible constraint",[s])
x is [.] => nil -- OK.
stackAndThrow('"Too many constraints for implicit parameter %1b",[s])
dbImplicitData(db) := [subst,preds]
buildConstructorCondition db ==
dbImplicitData db is [subst,cond] =>
['%exist,substTarget subst,mkpf(applySubst(subst,cond),'AND)]
true
getArgumentMode: (%Form,%Env) -> %Maybe %Mode
getArgumentMode(x,e) ==
string? x => x
get(x,'mode,e)
getArgumentModeOrMoan: (%Form, %Form, %Env) -> %Mode
getArgumentModeOrMoan(x,form,e) ==
getArgumentMode(x,e) or
stackSemanticError(["argument ",x," of ",form," is not declared"],nil)
compDefineCategory2(db,form,signature,body,m,e,$formalArgList) ==
--1. bind global variables
$prefix: local := nil
$op: local := form.op
$definition: local := form --used by DomainSubstitutionFunction
$form: local := nil
$extraParms: local := nil
e := registerConstructor($op,e)
-- Remember the body for checking the current instantiation.
$currentCategoryBody : local := body
--Set in DomainSubstitutionFunction, used further down
-- 1.1 augment e to add declaration $: <form>
dbFormalSubst(db) := pairList(form.args,$TriangleVariableList)
dbInstanceCache(db) := true
deduceImplicitParameters(db,e)
e:= addBinding("$",[['mode,:form]],e)
-- 2. obtain signature
signature':=
[signature.target,
:[getArgumentModeOrMoan(a,form,e) for a in form.args]]
e := giveFormalParametersValues(form.args,e)
dbDualSignature(db) :=
[true,:[isCategoryForm(t,e) for t in signature'.source]]
-- 3. replace arguments by $1,..., substitute into body,
-- and introduce declarations into environment
sargl := take(# form.args, $TriangleVariableList)
$functorForm:= $form:= [$op,:sargl]
$formalArgList:= [:sargl,:$formalArgList]
formalBody := dbSubstituteFormals(db,body)
signature' := dbSubstituteFormals(db,signature')
--Begin lines for category default definitions
$functionStats: local:= [0,0]
$functorStats: local:= [0,0]
$getDomainCode: local := nil
$addForm: local:= nil
for x in sargl for t in signature'.source repeat
[.,.,e]:= compMakeDeclaration(x,t,e)
-- 4. compile body in environment of %type declarations for arguments
op':= $op
-- following line causes cats with no with or Join to be fresh copies
if opOf(formalBody)~='Join and opOf(formalBody)~='mkCategory then
formalBody := ['Join, formalBody]
dbCategory(db) := formalBody
body := optFunctorBody(db,compOrCroak(formalBody,signature'.target,e).expr)
if $extraParms ~= nil then
formals := nil
actuals := nil
for [u,:v] in $extraParms repeat
formals := [u,:formals]
actuals := [MKQ v,:actuals]
body := ['sublisV,['pairList,quote formals,['%list,:actuals]],body]
if form.args then body := -- always subst for args after extraparms
['sublisV,['pairList,quote sargl,['%list,:
[['devaluate,u] for u in sargl]]],body]
body:=
["%bind",[[g:= gensym(),body]],
['%seq,['%store,['%tref,g,0],mkConstructor $form],g]]
fun := compile(db,[op',['%lambda,sargl,body]],signature')
-- 5. give operator a 'modemap property
pairlis := pairList(form.args,$FormalMapVariableList)
parSignature := applySubst(pairlis,dbSubstituteQueries(db,signature'))
parForm := applySubst(pairlis,form)
-- 6. put modemaps into InteractiveModemapFrame
dbDomainShell(db) := eval [op',:[MKQ f for f in sargl]]
dbConstructorModemap(db) :=
[[parForm,:parSignature],[buildConstructorCondition db,$op]]
dbPrincipals(db) := getParentsFor db
dbAncestors(db) := applySubst(pairlis,computeAncestorsOf(db,nil))
dbModemaps(db) := modemapsFromCategory(db,[op',:sargl],formalBody,signature')
[fun,$Category,e]
mkConstructor: %Form -> %Form
mkConstructor form ==
form isnt [.,:.] => ['devaluate,form]
null form.args => quote [form.op]
['%list,MKQ form.op,:[mkConstructor x for x in form.args]]
compDefineCategory(df,m,e,fal) ==
-- since we have so many ways to say state the kind of a constructor,
-- make sure we do have some minimal internal coherence.
lhs := second df
ctor := opOf lhs
db := constructorDB ctor
kind := dbConstructorKind db
kind ~= "category" => throwKeyedMsg("S2IC0016",[ctor,"category",kind])
dbClearForCompilation! db
dbConstructorForm(db) := lhs
dbCompilerData(db) := makeCompilationData()
dbOutputPath(db) := getOutputPath()
$backend: local := function(x +-> printBackendStmt(dbLibstream db,x))
try
$insideFunctorIfTrue => compDefineCategory1(db,df,m,e,fal)
compDefineLisplib(db,df,m,e,fal,'compDefineCategory1)
finally dbCompilerData(db) := nil
%CatObjRes -- result of compiling a category
<=> [%Shell,:[%Mode,:[%Env,:null]]]
compMakeCategoryObject: (%Form,%Env) -> %Maybe %CatObjRes
compMakeCategoryObject(c,$e) ==
not isCategoryForm(c,$e) => nil
u := evalCategoryForm(c,$e) => [u,$Category,$e]
nil
getCategoryObjectIfCan(tbl,x,env) ==
obj := tableValue(tbl,x) => obj
T := compMakeCategoryObject(x,env) => tableValue(tbl,x) := T.expr
nil
getCategoryObject(tbl,x,env) ==
getCategoryObjectIfCan(tbl,x,env)
or systemErrorHere ['getCategoryObject]
predicatesFromAttributes: %List %Form -> %List %Form
predicatesFromAttributes attrList ==
removeDuplicates [second x for x in attrList]
getModemap(x is [op,:.],e) ==
for modemap in get(op,'modemap,e) repeat
if u:= compApplyModemap(x,modemap,e) then return
([.,.,sl]:= u; applySubst(sl,modemap))
addModemap(op,mc,sig,pred,fn,$e) ==
$InteractiveMode => $e
if knownInfo(pred,$e) then pred:=true
$insideCapsuleFunctionIfTrue =>
$CapsuleModemapFrame :=
addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
$e
addModemap0(op,mc,sig,pred,fn,$e)
addModemapKnown(op,mc,sig,pred,fn,$e) ==
$insideCapsuleFunctionIfTrue =>
$CapsuleModemapFrame :=
addModemap0(op,mc,sig,pred,fn,$CapsuleModemapFrame)
$e
addModemap0(op,mc,sig,pred,fn,$e)
addModemap0(op,mc,sig,pred,fn,e) ==
--mc is the "mode of computation"; fn the "implementation"
--fn is ['Subsumed,:.] => e -- don't skip subsumed modemaps
-- breaks -:($,$)->U($,failed) in DP
op='elt or op='setelt => addEltModemap(op,mc,sig,pred,fn,e)
addModemap1(op,mc,sig,pred,fn,e)
addEltModemap(op,mc,sig,pred,fn,e) ==
--hack to change selectors from strings to identifiers; and to
--add flag identifiers as literals in the envir
op='elt and sig is [:lt,sel] =>
string? sel =>
id:= makeSymbol sel
if $insideCapsuleFunctionIfTrue
then $e:= makeLiteral(id,$e)
else e:= makeLiteral(id,e)
addModemap1(op,mc,[:lt,id],pred,fn,e)
-- sel isnt [.,:.] => systemErrorHere '"addEltModemap"
addModemap1(op,mc,sig,pred,fn,e)
op='setelt and sig is [:lt,sel,v] =>
string? sel =>
id:= makeSymbol sel
if $insideCapsuleFunctionIfTrue
then $e:= makeLiteral(id,$e)
else e:= makeLiteral(id,e)
addModemap1(op,mc,[:lt,id,v],pred,fn,e)
-- sel isnt [.,:.] => systemError '"addEltModemap"
addModemap1(op,mc,sig,pred,fn,e)
systemErrorHere '"addEltModemap"
mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) ==
for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat
mc=mc' or isSubset(mc,mc',e) =>
newmm:= nil
mm:= modemapList
while (not sameObject?(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm)
if (mc=mc') and (sig=sig') then
--We only need one of these, unless the conditions are hairy
not $forceAdd and TruthP pred' =>
entry:=nil
--the new predicate buys us nothing
return modemapList
TruthP pred => mmtail:=rest mmtail
--the thing we matched against is useless, by comparison
modemapList:= append!(reverse! newmm,[entry,:mmtail])
entry:= nil
return modemapList
if entry then [:modemapList,entry] else modemapList
insertModemap(new,mmList) ==
null mmList => [new]
--isMoreSpecific(new,old:= first mmList) => [new,:mmList]
--[old,:insertModemap(new,rest mmList)]
[new,:mmList]
mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) ==
entry:= [map:= [mc,:sig],[pred,fn],:filenameOrNil]
listMember?(entry,curModemapList) => curModemapList
(oldMap:= assoc(map,curModemapList)) and oldMap is [.,[opred, =fn],:.] =>
$forceAdd => mergeModemap(entry,curModemapList,e)
opred=true => curModemapList
if pred ~= true and pred ~= opred then pred:= ["OR",pred,opred]
[if x=oldMap then [map,[pred,fn],:filenameOrNil] else x
--if new modemap less general, put at end; otherwise, at front
for x in curModemapList]
$InteractiveMode => insertModemap(entry,curModemapList)
mergeModemap(entry,curModemapList,e)
addModemap1(op,mc,sig,pred,fn,e) ==
--mc is the "mode of computation"; fn the "implementation"
if mc="Rep" then sig := substituteDollarIfRepHack sig
currentProplist:= getProplist(op,e) or nil
newModemapList:=
mkNewModemapList(mc,sig,pred,fn,symbolTarget('modemap,currentProplist),e,nil)
newProplist:= augProplist(currentProplist,'modemap,newModemapList)
newProplist':= augProplist(newProplist,"FLUID",true)
unErrorRef op
--There may have been a warning about op having no value
addBinding(op,newProplist',e)
getDomainsInScope e ==
$insideCapsuleFunctionIfTrue => $CapsuleDomainsInScope
get("$DomainsInScope","special",e)
putDomainsInScope(x,e) ==
l:= getDomainsInScope e
if $verbose and listMember?(x,l) then
sayBrightly ['" Note: Domain ",x," already in scope"]
newValue := [x,:remove(l,x)]
$insideCapsuleFunctionIfTrue => ($CapsuleDomainsInScope:= newValue; e)
put("$DomainsInScope","special",newValue,e)
getOperationAlist(db,name,functorForm,form) ==
if ident? name and niladicConstructor? name then
functorForm := [functorForm]
(u:= get(functorForm,'isFunctor,$CategoryFrame)) and not
($insideFunctorIfTrue and first functorForm=first $functorForm) => u
$insideFunctorIfTrue and name is "$" =>
dbDomainShell db = nil => systemError '"$ has no shell now"
categoryExports dbDomainShell db
T := compMakeCategoryObject(form,$e) =>
[.,.,$e] := T
categoryExports T.expr
stackMessage('"not a category form: %1bp",[form])
substNames(domainName,functorForm,opalist) ==
functorForm := substitute("$$","$", functorForm)
nameForDollar :=
isCategoryPackageName functorForm => second functorForm
domainName
[[:substitute("$","$$",substitute(nameForDollar,"$",modemapform)),
[sel, domainName,if domainName is "$" then pos else
modemapform.mmTarget]]
for [:modemapform,[sel,"$",pos]] in
applySubst(pairList($FormalMapVariableList,KDR functorForm),opalist)]
evalAndSub(db,domainName,functorForm,form,$e) ==
$lhsOfColon: local:= domainName
categoryObject? form =>
[substNames(domainName,functorForm,categoryExports form),$e]
--next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83
if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e)
opAlist:= getOperationAlist(db,domainName,functorForm,form)
substAlist:= substNames(domainName,functorForm,opAlist)
[substAlist,$e]
augModemapsFromCategory(db,domainName,functorForm,categoryForm,e) ==
[fnAlist,e]:= evalAndSub(db,domainName,functorForm,categoryForm,e)
compilerMessage('"Adding %1p modemaps",[domainName])
e:= putDomainsInScope(domainName,e)
for [[op,sig,:.],cond,fnsel] in fnAlist repeat
e:= addModemapKnown(op,domainName,sig,cond,fnsel,e)
e
addConstructorModemaps(name,form is [functorName,:.],e) ==
$InteractiveMode: local:= nil
e:= putDomainsInScope(name,e) --frame
fn := property(functorName,"makeFunctionList")
[funList,e]:= apply(fn,[name,form,e])
for [op,sig,opcode] in funList repeat
if opcode is [sel,dc,n] and sel='ELT then
nsig := substitute("$$$",name,sig)
nsig := substitute('$,"$$$",substitute("$$",'$,nsig))
opcode := [sel,dc,nsig]
e:= addModemap(op,name,sig,true,opcode,e)
e
augModemapsFromDomain1(db,name,functorForm,e) ==
property(KAR functorForm,"makeFunctionList") =>
addConstructorModemaps(name,functorForm,e)
functorForm isnt [.,:.] and (catform := getmode(functorForm,e)) =>
augModemapsFromCategory(db,name,functorForm,catform,e)
mappingForm := getmodeOrMapping(KAR functorForm,e) =>
["Mapping",categoryForm,:functArgTypes] := mappingForm
catform := substituteCategoryArguments(rest functorForm,categoryForm)
augModemapsFromCategory(db,name,functorForm,catform,e)
stackMessage('"%1pb is an unknown mode",[functorForm])
e
AMFCR_,redefinedList(op,l) == "OR"/[AMFCR_,redefined(op,u) for u in l]
AMFCR_,redefined(opname,u) ==
not(u is [op,:l]) => nil
op = 'DEF => opname = CAAR l
op in '(PROGN SEQ) => AMFCR_,redefinedList(opname,l)
op = '%when => "OR"/[AMFCR_,redefinedList(opname,rest u) for u in l]
dbClearForCompilation! db ==
dbTemplate(db) := nil
dbLookupFunction(db) := nil
dbCapsuleDefinitions(db) := nil
dbModemaps(db) := nil
dbDocumentation(db) := nil
dbOperations(db) := nil
dbAttributes(db) := nil
dbPredicates(db) := nil
dbAncestors(db) := nil
dbPrincipals(db) := nil
dbCategory(db) := nil
dbPredicates(db) := nil
dbConstructorModemap(db) := nil
dbDefaultDomain(db) := nil
dbDualSignature(db) := nil
substituteCategoryArguments(argl,catform) ==
argl := substitute("$$","$",argl)
applySubst(pairList($FormalMapVariableList,argl),catform)
++ Register in the current environment, the variable name for the
++ current domain. Usually it is $; except when we are compiling
++ a synthesized package containing category defaults.
setDollarName(form,env) ==
name :=
isCategoryPackageName form.op => first form.args
'$
put('%compilerData,'%dollar,name,env)
++ Retrieve the variable name for the current instantiation.
getDollarName env ==
get('%compilerData,'%dollar,env)
getOutputPath() ==
outfile := getOptionValue "output"
outfile = nil => nil
$insideCategoryPackageIfTrue =>
d := filePathDirectory outfile
n := strconc(filePathString filePathName outfile,'"-")
t := filePathType outfile
filePathString makeFilePath(directory <- d,name <- n,type <- t)
outfile
compDefineFunctor(df,m,e,fal) ==
$profileCompiler: local := true
$profileAlist: local := nil
form := second df
db := constructorDB opOf form
dbClearForCompilation! db
dbConstructorForm(db) := form
dbCompilerData(db) := makeCompilationData()
dbOutputPath(db) := getOutputPath()
$backend: local := function(x +-> printBackendStmt(dbLibstream db,x))
try compDefineLisplib(db,df,m,e,fal,'compDefineFunctor1)
finally dbCompilerData(db) := nil
compDefineFunctor1(db,df is ['DEF,form,signature,body],m,$e,$formalArgList) ==
-- 0. Make `form' a constructor instantiation form
if form isnt [.,:.] then
form := [form]
-- 1. bind global variables
$prefix: local := nil
$op: local := form.op
$addForm: local := nil
$subdomain: local := false
$functionStats: local:= [0,0]
$functorStats: local:= [0,0]
$form: local := form
$signature: local := nil
$functorTarget: local := nil
$Representation: local := nil
--Set in doIt, accessed in the compiler - compNoStacking
$functorForm: local := form
$functorLocalParameters: local := nil
$getDomainCode: local := nil -- code for getting views
$insideFunctorIfTrue: local:= true
$genSDVar: local:= 0
originale:= $e
dbFormalSubst(db) := pairList(form.args,$FormalMapVariableList)
$e := registerConstructor($op,$e)
$e := setDollarName(form,$e)
deduceImplicitParameters(db,$e)
$formalArgList:= [:form.args,:$formalArgList]
-- all defaulting packages should have caching turned off
dbInstanceCache(db) := not isCategoryPackageName $op
signature':=
[signature.target,:[getArgumentModeOrMoan(a,form,$e) for a in form.args]]
if signature'.target = nil then
signature' := modemap2Signature getModemap($form,$e)
dbDualSignature(db) :=
[false,:[isCategoryForm(t,$e) for t in signature'.source]]
$functorTarget := target := signature'.target
$e := giveFormalParametersValues(form.args,$e)
tbl := makeTable function valueEq? -- category-form/object table
ds := getCategoryObjectIfCan(tbl,target,$e) or return
stackAndThrow('" cannot produce category object: %1pb",[target])
dbDomainShell(db) := copyVector ds
attributeList := categoryAttributes ds --see below under "loadTimeAlist"
$condAlist: local := nil
$uncondAlist: local := nil
$NRTslot1PredicateList: local := predicatesFromAttributes attributeList
$NRTattributeAlist: local := genInitialAttributeAlist(db,attributeList)
$NRTaddForm: local := nil -- see compAdd
-- Generate slots for arguments first, then implicit parameters,
-- then for $NRTaddForm (if any) in compAdd
for x in form.args repeat getLocalIndex(db,x)
for x in dbImplicitParameters db repeat getLocalIndex(db,x)
[.,.,$e] := compMakeDeclaration("$",target,$e)
if not $insideCategoryPackageIfTrue then
$e := augModemapsFromCategory(db,'$,form,target,$e)
$e := put('$,'%dc,form,$e)
$signature := signature'
parSignature := dbSubstituteAllQuantified(db,signature')
parForm := dbSubstituteAllQuantified(db,form)
-- 3. give operator a 'modemap property
modemap := [[parForm,:parSignature],[buildConstructorCondition db,$op]]
dbConstructorModemap(db) := modemap
dbCategory(db) := modemap.mmTarget
-- (3.1) now make a list of the functor's local parameters; for
-- domain D in form.args,check its signature: if domain, its type is Join(A1,..,An);
-- in this case, D is replaced by D1,..,Dn (gensyms) which are set
-- to the A1,..,An view of D
makeFunctorArgumentParameters(db,form.args,signature'.source,signature'.target)
$functorLocalParameters := form.args
-- 4. compile body in environment of %type declarations for arguments
op':= $op
rettype:= signature'.target
-- If this functor is defined as instantiation of a functor
-- that is a subdomain of `D', then make this functor also a subdomain
-- of that super domain `D'.
if body is ["add",[rhsCtor,:rhsArgs],["CAPSULE"]]
and constructor? rhsCtor
and (u := getSuperDomainFromDB rhsCtor) then
u := sublisFormal(rhsArgs,u,$AtVariables)
emitSubdomainInfo($form,first u, second u)
T:= compFunctorBody(db,body,rettype,$e)
body':= T.expr
lamOrSlam :=
dbInstanceCache db = nil => '%lambda
'%slam
fun := compile(db,dbSubstituteFormals(db,[op',[lamOrSlam,form.args,body']]),signature')
--The above statement stops substitutions gettting in one another's way
operationAlist := dbSubstituteAllQuantified(db,$lisplibOperationAlist)
dbModemaps(db) := modemapsFromFunctor(db,parForm,operationAlist)
reportOnFunctorCompilation()
-- 5.
dbPrincipals(db) := getParentsFor db
dbAncestors(db) := computeAncestorsOf(db,nil)
$insideFunctorIfTrue:= false
if not $bootStrapMode then
dbLookupFunction(db) := NRTgetLookupFunction(db,$NRTaddForm,tbl,$e)
--either lookupComplete (for forgetful guys) or lookupIncomplete
$NRTslot1PredicateList :=
[simpBool x for x in $NRTslot1PredicateList]
printBackendStmt(dbLibstream db,
['MAKEPROP,MKQ $op,''infovec,getInfovecCode(db,$e)])
$lisplibOperationAlist:= operationAlist
[fun,['Mapping,:signature'],originale]
++ Finish the incomplete compilation of a functor body.
incompleteFunctorBody(db,m,body,e) ==
-- The slot numbers from the category shell are bogus at this point.
-- Nullify them so people don't think they bear any meaningful
-- semantics (well, they should not think these are forwarding either).
ops := nil
for [opsig,pred,funsel] in categoryExports dbDomainShell db repeat
if pred isnt true then
pred := simpBool pred
if funsel is [op,.,.] and op in '(ELT CONST) then
third(funsel) := nil
ops := [[opsig,pred,funsel],:ops]
$lisplibOperationAlist := listSort(function GGREATERP,ops,function first)
dbSuperDomain(db) :=
body is ['SubDomain,dom,pred] => [dom,pred]
body is ['add,['SubDomain,dom,pred],:.] => [dom,pred]
nil
[bootStrapError(dbConstructorForm db,$editFile),m,e]
++ Subroutine of compDefineFunctor1. Called to generate backend code
++ for a functor definition.
compFunctorBody(db,body,m,e) ==
$bootStrapMode => incompleteFunctorBody(db,m,body,e)
clearCapsuleDirectory() -- start collecting capsule functions.
T:= compOrCroak(body,m,e)
$capsuleFunctionStack := reverse! $capsuleFunctionStack
-- ??? Don't resolve default definitions, yet.
backendCompile(db,defs) where defs() ==
$insideCategoryPackageIfTrue => $capsuleFunctionStack
foldExportedFunctionReferences(db,$capsuleFunctionStack)
clearCapsuleDirectory() -- release storage.
body is [op,:.] and op in '(add CAPSULE) => T
$NRTaddForm :=
body is ["SubDomain",domainForm,predicate] => domainForm
body
T
reportOnFunctorCompilation() ==
if $semanticErrorStack then sayBrightly '" "
displaySemanticErrors()
if $warningStack then sayBrightly '" "
displayWarnings()
$functorStats:= addStats($functorStats,$functionStats)
[byteCount,elapsedSeconds] := $functorStats
sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor",$op]
timeString := normalizeStatAndStringify elapsedSeconds
sayBrightly ['" Time:",:bright timeString,'"seconds"]
sayBrightly '" "
'done
--% domain view code
makeFunctorArgumentParameters(db,argl,sigl,target) ==
$forceAdd: local:= true
$ConditionalOperators: local := nil
("append"/[fn(db,a,augmentSig(s,findExtras(a,target)))
for a in argl for s in sigl]) where
findExtras(a,target) ==
-- see if conditional information implies anything else
-- in the signature of a
target is ['Join,:l] => "union"/[findExtras(a,x) for x in l]
target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where
findExtras1(a,x) ==
x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l]
x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l]
x is ['IF,c,p,q] =>
union(findExtrasP(a,c),
union(findExtras1(a,p),findExtras1(a,q))) where
findExtrasP(a,x) ==
x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
nil
nil
augmentSig(s,ss) ==
-- if we find something extra, add it to the signature
null ss => s
for u in ss repeat
$ConditionalOperators:=[rest u,:$ConditionalOperators]
s is ['Join,:sl] =>
u := objectAssoc('CATEGORY,ss) =>
MSUBST([:u,:ss],u,s)
['Join,:sl,['CATEGORY,'package,:ss]]
['Join,s,['CATEGORY,'package,:ss]]
fn(db,a,s) ==
isCategoryForm(s,$CategoryFrame) =>
s is ["Join",:catlist] => genDomainViewList(db,a,s.args)
[genDomainView(db,a,s,"getDomainView")]
[a]
genDomainOps(db,dom,cat) ==
oplist:= getOperationAlist(db,dom,dom,cat)
siglist:= [sig for [sig,:.] in oplist]
oplist:= substNames(dom,dom,oplist)
cd:=
["%LET",dom,['mkOpVec,dom,['%list,:
[['%list,MKQ op,['%list,:[mkTypeForm mode for mode in sig]]]
for [op,sig] in siglist]]]]
$getDomainCode:= [cd,:$getDomainCode]
for [opsig,cond,:.] in oplist for i in 0.. repeat
if listMember?(opsig,$ConditionalOperators) then cond:=nil
[op,sig]:=opsig
$e := addModemap(op,dom,sig,cond,['ELT,dom,i],$e)
dom
genDomainView(db,viewName,c,viewSelector) ==
c is ['CATEGORY,.,:l] => genDomainOps(db,viewName,c)
code:=
c is ['SubsetCategory,c',.] => c'
c
$e:= augModemapsFromCategory(db,viewName,nil,c,$e)
cd:= ["%LET",viewName,[viewSelector,viewName,mkTypeForm code]]
if not listMember?(cd,$getDomainCode) then
$getDomainCode:= [cd,:$getDomainCode]
viewName
genDomainViewList(db,id,catlist) ==
[genDomainView(db,id,cat,"getDomainView")
for cat in catlist | isCategoryForm(cat,$EmptyEnvironment)]
mkOpVec(dom,siglist) ==
dom:= getPrincipalView dom
substargs := [['$,:canonicalForm dom],
:pairList($FormalMapVariableList,instantiationArgs dom)]
oplist:= getConstructorOperationsFromDB instantiationCtor dom
--new form is (<op> <signature> <slotNumber> <condition> <kind>)
ops := newVector #siglist
for (opSig:= [op,sig]) in siglist for i in 0.. repeat
u := objectAssoc(op,oplist)
assoc(sig,u) is [.,n,.,'ELT] =>
vectorRef(ops,i) := vectorRef(dom,n)
noplist := applySubst(substargs,u)
-- following variation on assoc needed for GENSYMS in Mutable domains
AssocBarGensym(substitute(dom.0,'$,sig),noplist) is [.,n,.,'ELT] =>
vectorRef(ops,i) := vectorRef(dom,n)
vectorRef(ops,i) := [function Undef,[dom.0,i],:opSig]
ops
++ form is lhs (f a1 ... an) of definition; body is rhs;
++ signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0;
++ removes declarative and assignment information from form and
++ signature, placing it in list L, replacing form by ("where",form',:L),
++ signature by a list of NILs (signifying declarations are in e)
compDefWhereClause(['DEF,form,signature,body],m,e) ==
$sigAlist: local := nil
$predAlist: local := nil
-- 1. create sigList= list of all signatures which have embedded
-- declarations moved into global variable $sigAlist
sigList:=
[transformType fetchType(a,x,e,form)
for a in form.args for x in signature.source] where
fetchType(a,x,e,form) ==
x => x
getmode(a,e) or userError concat(
'"There is no mode for argument",a,'"of function",form.op)
transformType x ==
x isnt [.,:.] => x
x is [":",R,Rtype] =>
($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x)
x is ['Record,:.] => x --RDJ 8/83
[x.op,:[transformType y for y in x.args]]
-- 2. replace each argument of the form (|| x p) by x, recording
-- the given predicate in global variable $predAlist
argList:=
[removeSuchthat a for a in form.args] where
removeSuchthat x ==
x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y)
x
-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that
-- the type of xi is independent of xj if i < j
varList :=
orderByDependency(substSource argDepAlist,substTarget argDepAlist) where
argDepAlist :=
[[x,:dependencies] for [x,:y] in argSigAlist] where
dependencies() ==
setUnion(listOfIdentifiersIn y,
remove(listOfIdentifiersIn LASSOC(x,$predAlist),x))
argSigAlist := [:$sigAlist,:pairList(argList,sigList)]
-- 4. construct a WhereList which declares and/or defines the xi's in
-- the order constructed in step 3
whereList := [addSuchthat(x,[":",x,symbolTarget(x,argSigAlist)]) for x in varList]
where addSuchthat(x,y) ==
p := LASSOC(x,$predAlist) => ["|",y,p]
y
-- 5. compile new ('DEF,("where",form',:WhereList),:.) where
-- all argument parameters of form' are bound/declared in WhereList
comp(form',m,e) where
form' := ["where",defform,:whereList] where
defform := ['DEF,form'',signature',body] where
form'' := [form.op,:argList]
signature' := [signature.target,:[nil for x in signature.source]]
orderByDependency(vl,dl) ==
-- vl is list of variables, dl is list of dependency-lists
selfDependents:= [v for v in vl for d in dl | symbolMember?(v,d)]
for v in vl for d in dl | symbolMember?(v,d) repeat
(SAY(v," depends on itself"); fatalError:= true)
fatalError => userError '"Parameter specification error"
until vl = nil repeat
newl:=
[v for v in vl for d in dl | setIntersection(d,vl) = nil] or return nil
orderedVarList:= [:newl,:orderedVarList]
vl' := setDifference(vl,newl)
dl' := [setDifference(d,newl) for x in vl for d in dl
| symbolMember?(x,vl')]
vl := vl'
dl := dl'
removeDuplicates reverse! orderedVarList --ordered so ith is indep. of jth if i < j
++ Subroutine of compDefineCapsuleFunction.
assignCapsuleFunctionSlot(db,op,sig) ==
kind := or/[u.mapKind for u in categoryExports dbDomainShell db
| symbolEq?(op,u.mapOperation) and sig = u.mapSignature]
kind = nil => nil -- op is local and need not be assigned
if $insideCategoryPackageIfTrue then
sig := substitute('$,second dbConstructorForm db,sig)
desc := [op,'$,:[getLocalIndex(db,x) for x in sig],kind]
n := dbEntitySlot(db,desc) => n --already there
n := dbEntityCount db + $NRTbase
dbUsedEntities(db) := [[desc,op,'$,:sig,kind],:dbUsedEntities db]
dbEntityCount(db) := dbEntityCount db + 1
n
localOperation?(op,e) ==
not symbolMember?(op,$formalArgList) and getXmode(op,e) is ['Mapping,:.]
++ Subroutine of hasSigInTargetCategory.
candidateSignatures(op,nmodes,slot1) ==
[sig for [[=op,sig,:.],:.] in slot1 | #sig = nmodes]
compareMode2Arg(x,m) == null x or modeEqual(x,m)
++ Subroutine of compDefineCapsuleFunction.
++ We are compiling a capsule function definition with head given by `form'.
++ Determine whether the function with possibly partial signature `target'
++ is exported. Return the complete signature if yes; otherwise
++ return nil, with diagnostic in ambiguity case.
hasSigInTargetCategory(db,form,target,e) ==
sigs := candidateSignatures(form.op,#form,categoryExports dbDomainShell db)
cc := checkCallingConvention(sigs,#form.args)
mList:= [(cc.i > 0 => quasiquote x; getArgumentMode(x,e))
for x in form.args for i in 0..]
--each element is a declared mode for the variable or nil if none exists
potentialSigList :=
removeDuplicates [sig for sig in sigs | fn(sig,target,mList)] where
fn(sig,target,mList) ==
(target = nil or target=sig.target) and
"and"/[compareMode2Arg(x,m) for x in mList for m in sig.source]
potentialSigList is [sig] => sig
potentialSigList = nil => nil
ambiguousSignatureError(form.op,potentialSigList)
first potentialSigList
++ Subroutine of compDefineCapsuleFunction.
checkAndDeclare(db,form,sig,e) ==
stack := nil
-- arguments with declared types must agree with those in sig;
-- those that don't get declarations put into e
for a in form.args for m in sig.source repeat
isQuasiquote m => nil -- we just built m from a.
symbolMember?(a,dbParameters db) =>
stackAndThrow('"Redeclaration of constructor parameter %1b",[a])
m1:= getArgumentMode(a,e) =>
not modeEqual(m1,m) =>
stack:= [" ",:bright a,'"must have type ",m,
'" not ",m1,'"%l",:stack]
e:= put(a,'mode,m,e)
if stack then
sayBrightly ['" Parameters of ",:bright form.op,
'" are of wrong type:",'"%l",:stack]
e
++ Subroutine of compDefineCapsuleFunction.
addArgumentConditions($body,$functionName) ==
$argumentConditionList =>
--$body is only used in this function
fn $argumentConditionList where
fn clist ==
clist is [[n,untypedCondition,typedCondition],:.] =>
['%when,[typedCondition,fn rest clist],
['%otherwise,["argumentDataError",n,
MKQ untypedCondition,MKQ $functionName]]]
null clist => $body
systemErrorHere ["addArgumentConditions",clist]
$body
++ Subroutine of compDefineCapsuleFunction.
compArgumentConditions: %Env -> %Env
compArgumentConditions e ==
$argumentConditionList:=
[f for [n,a,x] in $argumentConditionList] where
f() ==
y:= substitute(a,"#1",x)
T := [.,.,e]:= compOrCroak(y,$Boolean,e)
[n,x,T.expr]
e
++ Return true if signature `sig' contains unspeccified modes.
partialSignature? sig ==
sig.target = nil or (or/[s = nil for s in sig.source])
++ Subroutine of compDefineCapsuleFunction.
++ We are about to elaborate a definition with `form' as head, and
++ parameter types specified in `signature'. Refine that signature
++ in case some or all of the parameter types are missing.
refineDefinitionSignature(db,form,signature,e) ==
--let target and local signatures help determine modes of arguments
signature' :=
x := hasSigInTargetCategory(db,form,signature.target,e) => x
x := getSignatureFromMode(form,e) => x
[signature.target,:[getArgumentMode(a,e) for a in form.args]]
signature'.source := stripOffSubdomainConditions(signature'.source,form.args)
partialSignature? signature' => getSignature(form.op,signature'.source,e)
signature'
++ Subroutine of compDefineCapsuleFunction.
processDefinitionParameters(db,form,signature,e) ==
e := checkAndDeclare(db,form,signature,e)
e := giveFormalParametersValues(form.args,e)
e := addDomain(db,signature.target,e)
e := compArgumentConditions e
if $profileCompiler then
for x in form.args for t in signature.source repeat
profileRecord('arguments,x,t)
for domain in signature repeat
e := addDomain(db,domain,e)
e
mkRepititionAssoc l ==
mkRepfun(l,1) where
mkRepfun(l,n) ==
null l => nil
l is [x] => [[n,:x]]
l is [x, =x,:l'] => mkRepfun(rest l,n+1)
[[n,:first l],:mkRepfun(rest l,1)]
encodeItem x ==
x is [op,:argl] => getCaps op
ident? x => symbolName x
STRINGIMAGE x
getCaps x ==
s := symbolName x
clist := [c for i in 0..maxIndex s | upperCase? (c := stringChar(s,i))]
clist = nil => '"__"
strconc/[charString first clist,
:[charString charDowncase u for u in rest clist]]
encodeFunctionName(db,fun,signature,count) ==
if dbDefaultPackage? db then
signature := substitute('$,first dbParameters db,signature)
reducedSig := mkRepititionAssoc [:signature.source,signature.target]
encodedSig :=
(strconc/[encodedPair for [n,:x] in reducedSig]) where
encodedPair() ==
n=1 => encodeItem x
strconc(toString n,encodeItem x)
encodedName:= makeSymbol strconc(symbolName dbAbbreviation db,'";",
symbolName fun,'";",encodedSig,'";",toString count)
dbCapsuleDefinitions(db) :=
[[encodedName,signature],:dbCapsuleDefinitions db]
encodedName
compDefineCapsuleFunction(db,df is ['DEF,form,signature,body],
m,$e,$prefix,$formalArgList) ==
e := $e
--1. bind global variables
$form: local := nil
$op: local := nil
$functionStats: local:= [0,0]
$argumentConditionList: local := nil
$finalEnv: local := nil
--used by ReplaceExitEtc to get a common environment
$initCapsuleErrorCount: local:= #$semanticErrorStack
$insideCapsuleFunctionIfTrue: local:= true
$CapsuleModemapFrame: local:= e
$CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e)
$insideExpressionIfTrue: local:= true
$returnMode: local := m
$suffix := $suffix + 1
-- Change "^" to "**" in definitions. All other places have
-- been changed before we get here.
if form is ["^",:.] then
sayBrightly ['"Replacing", :bright '"^", '"with",:bright '"**"]
form.op := "**"
[$op,:argl] := form
$form := [$op,:argl]
argl:= stripOffArgumentConditions argl
$formalArgList:= [:argl,:$formalArgList]
signature := refineDefinitionSignature(db,form,signature,e) or return nil
$signatureOfForm := signature --this global is bound in compCapsuleItems
e := processDefinitionParameters(db,form,signature,e)
rettype := resolve(signature.target,$returnMode)
localOrExported :=
localOperation?($op,e) => 'local
'exported
formattedSig := formatUnabbreviatedSig signature
sayBrightly ['" compiling ",localOrExported,
:bright $op,'": ",:formattedSig]
pred := makePredicate $predl
noteCapsuleFunctionDefinition($op,signature,pred)
T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e))
or [$ClearBodyToken,rettype,e]
-- A THROW to the above CATCH occurs if too many semantic errors occur
-- see stackSemanticError
n := assignCapsuleFunctionSlot(db,$op,signature)
-- Build a name for the implementation.
op' :=
localOperation?($op,e) =>
-- object if the operation is both local and exported.
if or/[mm.mmDC is '$ for mm in get($op,'modemap,e)] then
userError ['"%b",$op,'"%d",'" is local and exported"]
makeSymbol strconc(symbolName $prefix,'";",symbolName $op)
encodeFunctionName(db,$op,signature,$suffix)
if n ~= nil and not $insideCategoryPackageIfTrue then
updateCapsuleDirectory([n,:op'],pred)
-- Let the backend know about this function's type
if $optProclaim then
proclaimCapsuleFunction(db,op',signature)
clearReplacement op' -- Make sure we have fresh info
-- Finally, build a lambda expression for this function.
fun :=
catchTag := MKQ gensym()
body' := replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode)
body' := addArgumentConditions(body',$op)
finalBody := ['%scope,catchTag,body']
compile(db,[op',['%lambda,[:argl,'$],finalBody]],signature)
$functorStats:= addStats($functorStats,$functionStats)
--7. give operator a 'value property
[fun,['Mapping,:signature],$e]
domainMember(dom,domList) ==
or/[modeEqual(dom,d) for d in domList]
augModemapsFromDomain(db,name,functorForm,e) ==
symbolMember?(KAR name or name,$DummyFunctorNames) => e
name = $Category or isCategoryForm(name,e) => e
listMember?(name,getDomainsInScope e) => e
if super := superType functorForm then
e := addNewDomain(db,super,e)
if name is ["Union",:dl] then for d in stripTags dl
repeat e:= addDomain(db,d,e)
augModemapsFromDomain1(db,name,functorForm,e)
addNewDomain(db,domain,e) ==
augModemapsFromDomain(db,domain,domain,e)
addDomain(db,domain,e) ==
domain isnt [.,:.] =>
domain="$EmptyMode" => e
domain="$NoValueMode" => e
not ident? domain or 2 < #(s:= symbolName domain) and
char "#" = stringChar(s,0) and char "#" = stringChar(s,1) => e
symbolMember?(domain,getDomainsInScope e) => e
isLiteral(domain,e) => e
addNewDomain(db,domain,e)
(name:= first domain)='Category => e
domainMember(domain,getDomainsInScope e) => e
getXmode(name,e) is ["Mapping",target,:.] and isCategoryForm(target,e) =>
addNewDomain(db,domain,e)
-- constructor? test needed for domains compiled with $bootStrapMode=true
isDomainForm(domain,e) => addNewDomain(db,domain,e)
-- ??? we should probably augment $DummyFunctorNames with CATEGORY
-- ??? so that we don't have to do this special check here. Investigate.
isQuasiquote domain => e
if not isCategoryForm(domain,e) and name ~= "Mapping" then
unknownTypeError name
e --is not a functor
++ Subroutine of getSignature.
++ Return true if the given parameter type list `src' is a refinment of
++ of the seed `pat'.
sourceMatches?(src,pat) ==
repeat
src = nil => return pat = nil
pat = nil => return src = nil
pat.first ~= nil and src.first ~= pat.first => return false
src := src.rest
pat := pat.rest
getSignature(op,argModeList,e) ==
mmList := get(op,'modemap,e)
dollar := getDollarName e
sigl := removeDuplicates
[sig for [[dc,:sig],[pred,:.]] in mmList
| dc=dollar and sourceMatches?(sig.source,argModeList)
and knownInfo(pred,e)]
sigl is [sig] => sig
null sigl =>
getXmode(op,e) is ['Mapping,:sig] => sig
SAY '"************* USER ERROR **********"
SAY("available signatures for ",op,": ")
if null mmList
then SAY " NONE"
else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig)
printSignature("NEED ",op,["?",:argModeList])
nil
stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil)
--% ARGUMENT CONDITION CODE
stripOffArgumentConditions argl ==
[f for x in argl for i in 1..] where
f() ==
x is ["|",arg,condition] =>
condition:= substitute('_#1,arg,condition)
-- in case conditions are given in terms of argument names, replace
$argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
arg
x
stripOffSubdomainConditions(margl,argl) ==
[f for x in margl for arg in argl for i in 1..] where
f() ==
x is ['SubDomain,marg,condition] =>
pair:= assoc(i,$argumentConditionList) =>
(pair.rest.first := MKPF([condition,second pair],'AND); marg)
$argumentConditionList:= [[i,arg,condition],:$argumentConditionList]
marg
x
putInLocalDomainReferences(db,def := [opName,[lam,varl,body]]) ==
NRTputInTail(db,CDDADR def)
def
compile(db,u,signature) ==
optimizedBody := optimizeFunctionDef u
stuffToCompile :=
$insideCapsuleFunctionIfTrue =>
putInLocalDomainReferences(db,optimizedBody)
optimizedBody
$doNotCompileJustPrint => (PRETTYPRINT stuffToCompile; first u)
$macroIfTrue => constructMacro stuffToCompile
try spadCompileOrSetq(db,stuffToCompile)
finally
functionStats := [0,elapsedTime()]
$functionStats := addStats($functionStats,functionStats)
printStats functionStats
++ Subroutine of compile. Called to generate backend code for
++ items defined directly or indirectly at capsule level. This is
++ also used to compile functors.
spadCompileOrSetq(db,form is [nam,[lam,vl,body]]) ==
--bizarre hack to take account of the existence of "known" functions
--good for performance (LISPLLIB size, BPI size, NILSEC)
CONTAINED($ClearBodyToken,body) => sayBrightly ['" ",:bright nam,'" not compiled"]
vl := cleanParameterList! vl
if $optReplaceSimpleFunctions then
body := replaceSimpleFunctions body
if nam' := forwardingCall?(vl,body) then
registerFunctionReplacement(db,nam,nam')
sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam']
else if macform := expandableDefinition?(vl,body) then
registerFunctionReplacement(db,nam,macform)
[:vl',.] := vl
sayBrightly ['" ",:bright prefix2String [nam,:vl'],
'"is replaced by",:bright prefix2String body]
form :=
getFunctionReplacement nam =>
[nam,[lam,vl,["DECLARE",["IGNORE",last vl]],body]]
[nam,[lam,vl,body]]
$insideCapsuleFunctionIfTrue =>
$optExportedFunctionReference =>
$capsuleFunctionStack := [form,:$capsuleFunctionStack]
first form
first backendCompile(db,[form])
compileConstructor(db,form)
compileConstructor(db,form) ==
u := compileConstructor1(db,form)
clearClams() --clear all CLAMmed functions
clearConstructorCache u --clear cache for constructor
u
compileConstructor1(db,form:=[fn,[key,vl,:bodyl]]) ==
-- fn is the name of some category/domain/package constructor;
-- we will cache all of its values on $ConstructorCache with reference
-- counts
dbConstructorKind db = 'category =>
first compAndDefine(db,[[fn,['%slam,vl,:bodyl]]])
dbInstanceCache db = nil =>
first backendCompile(db,[[fn,['%lambda,vl,:bodyl]]])
compHash(db,fn,vl,bodyl)
++ Subroutine of compileConstructor1. Called to compile the body
++ of a category constructor definition.
compAndDefine(db,l) ==
$backend: local := function(x +-> evalAndPrintBackendStmt(dbLibstream db,x))
backendCompile(db,l)
compHash(db,op,argl,body) ==
-- Entries will be stored on the global hashtable in a uniform way:
-- (<argument list>, <reference count>,:<value>)
-- where the reference count is optional
auxfn := makeWorkerName op
cacheName := "$ConstructorCache"
g2 := gensym() --value computed by calling function
putCode :=
argl = nil =>
['CDDAR,['%store,['tableValue,cacheName,MKQ op],
['%list,['%pair,'%nil,['%pair,1,[auxfn]]]]]]
[auxfn,:argl]
putCode :=
['UNWIND_-PROTECT,['PROG1,putCode,['%store,g2,'%true]],
['%when,[['%not,g2],['tableRemove!,cacheName,MKQ op]]]]
getCode :=
argl = nil => ['tableValue,cacheName,MKQ op]
key :=
argl is [g] => ['%list,['devaluate,g]]
['%list,:[['devaluate,x] for x in argl]]
['lassocShiftWithFunction,key,
['tableValue,cacheName,MKQ op],['%function,'domainEqualList]]
returnFoundValue :=
argl = nil => ['CDRwithIncrement,['CDAR,g2]]
['CDRwithIncrement,g2]
codeBody := mkBind([[g2,getCode]],
['%when,[g2,returnFoundValue],['%otherwise,putCode]])
computeFunction := [auxfn,['%lambda,argl,:body]]
if $reportCompilation then
sayBrightlyI bright '"Generated code for function:"
pp computeFunction
backendCompile(db,[[op,['%lambda,argl,codeBody]],computeFunction])
op
constructMacro: %Form -> %Form
constructMacro (form is [nam,[lam,vl,body]]) ==
not (and/[x isnt [.,:.] for x in vl]) =>
stackSemanticError(["illegal parameters for macro: ",vl],nil)
["XLAM",vl':= [x for x in vl | ident? x],body]
listInitialSegment(u,v) ==
null u => true
null v => nil
first u=first v and listInitialSegment(rest u,rest v)
--returns true iff u.i=v.i for i in 1..(#u)-1
modemap2Signature [[.,:sig],:.] == sig
uncons: %Form -> %Form
uncons x ==
x isnt [.,:.] => x
x is ["CONS",a,b] => [a,:uncons b]
--% CAPSULE
bootStrapError(functorForm,sourceFile) ==
['%when, _
['$bootStrapMode, _
['%vector,mkTypeForm functorForm,nil,nil,nil,nil,nil]],
['%otherwise, ['systemError,['%list,'"%b",MKQ functorForm.op,'"%d",'"from", _
'"%b",MKQ namestring sourceFile,'"%d",'"needs to be compiled"]]]]
registerInlinableDomain x ==
x is [ctor,:.] =>
ctor is ":" => registerInlinableDomain third x
ctor is 'Enumeration => nil
builtinFunctorName? ctor =>
for t in x.args repeat
registerInlinableDomain t
constructor? ctor =>
nominateForInlining ctor
cosig := getDualSignature ctor or return nil
for a in x.args for t in cosig.source | t and a is [.,:.] repeat
registerInlinableDomain a
nil
compAdd(['add,$addForm,capsule],m,e) ==
$bootStrapMode =>
if $addForm is ["%Comma",:.] then code := nil
else [code,m,e]:= comp($addForm,m,e)
[['%when, _
['$bootStrapMode, _
code],_
['%otherwise, ['systemError,['%list,'"%b",MKQ $functorForm.op,'"%d",'"from", _
'"%b",MKQ namestring $editFile,'"%d",'"needs to be compiled"]]]],m,e]
$addFormLhs: local:= $addForm
db := currentDB e
if $addForm is ["SubDomain",domainForm,predicate] then
$NRTaddForm := domainForm
getLocalIndex(db,domainForm)
registerInlinableDomain domainForm
--need to generate slot for add form since all $ go-get
-- slots will need to access it
[$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
else
$NRTaddForm := $addForm
[$addForm,.,e]:=
$addForm is ["%Comma",:.] =>
$NRTaddForm := ["%Comma",:[getLocalIndex(db,x) for x in $addForm.args]]
for x in $addForm.args repeat
registerInlinableDomain x
compOrCroak(compTuple2Record $addForm,$EmptyMode,e)
registerInlinableDomain $addForm
compOrCroak($addForm,$EmptyMode,e)
compCapsule(capsule,m,e)
compTuple2Record u ==
['Record,:[[":",i,x] for i in 1.. for x in u.args]]
compCapsule(['CAPSULE,:itemList],m,e) ==
$bootStrapMode =>
[bootStrapError($functorForm, $editFile),m,e]
$insideExpressionIfTrue: local:= false
$useRepresentationHack := true
db := currentDB e
clearCapsuleFunctionTable()
e := checkRepresentation(db,$addFormLhs,itemList,e)
compCapsuleInner(db,itemList,m,addDomain(db,'$,e))
compSubDomain(["SubDomain",domainForm,predicate],m,e) ==
$addFormLhs: local:= domainForm
$addForm: local := nil
$NRTaddForm := domainForm
[$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e)
compCapsule(['CAPSULE],m,e)
compSubDomain1(domainForm,predicate,m,e) ==
[.,.,e]:=
compMakeDeclaration("#1",domainForm,addDomain(currentDB e,domainForm,e))
u:=
compCompilerPredicate(predicate,e) or
stackSemanticError(["predicate: ",predicate,
" cannot be interpreted with #1: ",domainForm],nil)
pred := simplifyVMForm u.expr
-- For now, reject predicates that directly reference domains
usesVariable?(pred,'$) =>
stackAndThrow('"predicate %1pb is not simple enough",[predicate])
emitSubdomainInfo($form,domainForm,pred)
[domainForm,m,e]
compCapsuleInner(db,itemList,m,e) ==
e:= addInformation(m,e)
--puts a new 'special' property of $Information
data := ["PROGN",:itemList]
--RPLACd by compCapsuleItems and Friends
e := compCapsuleItems(db,itemList,nil,e)
localParList:= $functorLocalParameters
if $addForm ~= nil then
data := ['add,$addForm,data]
code :=
dbForCategory? db => data
buildFunctor(db,$signature,data,localParList,e)
[MKPF([:$getDomainCode,code],"PROGN"),m,e]
--% PROCESS FUNCTOR CODE
compCapsuleItems(db,itemlist,$predl,$e) ==
$signatureOfForm: local := nil
$suffix: local:= 0
for item in itemlist repeat
$e:= compSingleCapsuleItem(db,item,$predl,$e)
$e
compSingleCapsuleItem(db,item,$predl,$e) ==
doIt(db,macroExpand!(item,$e),$predl)
$e
++ subroutine of doIt. Called to generate runtime noop insn.
mutateToNothing item ==
item.op := 'PROGN
item.rest := nil
doIt(db,item,$predl) ==
$GENNO: local:= 0
item is ['SEQ,:l,['exit,1,x]] =>
item.op := "PROGN"
lastNode(item).first := x
for it1 in rest item repeat $e:= compSingleCapsuleItem(db,it1,$predl,$e)
--This will RPLAC as appropriate
isDomainForm(item,$e) =>
-- convert naked top level domains to import.
-- Note: The apparent useless destructing of `item' below is necessary
-- because it is subject to RPLACA/RPLACD, which would create
-- a cycle otherwise.
u:= ["import", [first item,:rest item]]
stackWarning('"Use: import %1p",[[first item,:rest item]])
item.op := u.op
item.rest := rest u
doIt(db,item,$predl)
item is [":=",lhs,rhs,:.] =>
compOrCroak(item,$EmptyMode,$e) isnt [code,.,$e] =>
stackSemanticError(["cannot compile assigned value to",:bright lhs],nil)
not (code is ["%LET",lhs',rhs',:.] and lhs' isnt [.,:.]) =>
code is ["PROGN",:.] =>
stackSemanticError(["multiple assignment ",item," not allowed"],nil)
item.first := first code
item.rest := rest code
lhs:= lhs'
if not symbolMember?(KAR rhs,$NonMentionableDomainNames) and
not symbolMember?(lhs, $functorLocalParameters) then
$functorLocalParameters:= [:$functorLocalParameters,lhs]
if code is ["%LET",.,rhs',:.] and isDomainForm(rhs',$e) then
if lhs="Rep" then
--$Representation bound by compDefineFunctor, used in compNoStacking
$Representation := getRepresentation $e
if $optimizeRep then
registerInlinableDomain $Representation
code is ["%LET",:.] =>
db := currentDB $e
item.op := '%store
rhsCode := rhs'
item.args := [['%tref,'$,getLocalIndex(db,lhs)],rhsCode]
item.op := code.op
item.rest := rest code
item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
item is ["import",:doms] =>
for dom in doms repeat
sayBrightly ['" importing ",:formatUnabbreviated dom]
[.,.,$e] := compOrCroak(item,$EmptyMode,$e)
mutateToNothing item
item is ["%Inline",type] =>
processInlineRequest(type,$e)
mutateToNothing item
item is ["%SignatureImport",:.] =>
[.,.,$e] := compSignatureImport(item,$EmptyMode,$e)
mutateToNothing item
item is ["IF",p,x,y] => doItConditionally(db,item,$predl)
item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e)
item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e)
item is ['DEF,lhs,:.] =>
op := opOf lhs
body := isMacro(item,$e) => $e := putMacro(op,body,$e)
[.,.,$e] := t := compOrCroak(item,$EmptyMode,$e)
item.op := "CodeDefine"
--Note that DescendCode, in CodeDefine, is looking for this
second(item) := [op,$signatureOfForm]
--This is how the signature is updated for buildFunctor to recognise
third(item) := ['%function,t.expr]
item.rest.rest.rest := nil
u := compOrCroak(item,$EmptyMode,$e) =>
([code,.,$e]:= u; item.first := first code; item.rest := rest code)
systemErrorHere ["doIt", item]
isMacro(x,e) ==
x is ['DEF,[op],[nil],body] and
get(op,'modemap,e) = nil and get(op,'mode,e) = nil => body
nil
++ Compile capsule-level `item' which is a conditional expression.
++ OpenAxiom's take on prepositional logical is a constructive
++ interpretation of logical connectives, in terms of IF-expresions.
++ In particular, a negation is positively interpretated by swapping
++ branches, and- and or-expressions are decomposed into nested
++ IF-expressions. -- gdr, 2009-06-15.
doItConditionally(db,item,predl) ==
item isnt ["IF",p,x,y] => systemErrorHere ["doItConditionally",item]
p is ["not",p'] =>
-- swap branches and recurse for positive interpretation.
item.rest.first := p'
item.rest.rest.first := y
item.rest.rest.rest.first := x
doItConditionally(db,item,predl)
p is ["and",p',p''] =>
item.rest.first := p'
item.rest.rest.first := ["IF",p'',x,copyTree y]
doItConditionally(db,item,predl)
p is ["or",p',p''] =>
item.rest.first := p'
item.rest.rest.rest.first := ["IF",p'',copyTree x,y]
doItConditionally(db,item,predl)
doItIf(db,item,predl,$e)
doItIf(db,item is [.,p,x,y],$predl,$e) ==
olde:= $e
[p',.,$e]:= compCompilerPredicate(p,$e) or userError ['"not a Boolean:",p]
oldFLP:=$functorLocalParameters
if x~="%noBranch" then
compSingleCapsuleItem(db,x,[p,:$predl],getSuccessEnvironment(p,$e))
x':=localExtras(oldFLP)
oldFLP:=$functorLocalParameters
if y~="%noBranch" then
compSingleCapsuleItem(db,y,[["not",p],:$predl],getInverseEnvironment(p,olde))
y':=localExtras(oldFLP)
item.op := '%when
item.args := [[p',x,:x'],['%otherwise,y,:y']]
where localExtras(oldFLP) ==
sameObject?(oldFLP,$functorLocalParameters) => nil
flp1:=$functorLocalParameters
oldFLP':=oldFLP
n:=0
while oldFLP' repeat
oldFLP':=rest oldFLP'
flp1:=rest flp1
n:=n+1
-- Now we have to add code to compile all the elements
-- of functorLocalParameters that were added during the
-- conditional compilation
nils:=ans:=[]
for u in flp1 repeat -- is =u form always an atom?
if u isnt [.,:.] or (or/[v is [.,=u,:.] for v in $getDomainCode])
then
nils:=[u,:nils]
else
gv := gensym()
ans:=[["%LET",gv,u],:ans]
nils:=[gv,:nils]
n:=n+1
$functorLocalParameters:=[:oldFLP,:reverse! nils]
reverse! ans
--% CATEGORY AND DOMAIN FUNCTIONS
compJoin(["Join",:argl],m,e) ==
catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl]
catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil)
catList':=
[extract for x in catList] where
extract() ==
isCategoryForm(x,e) =>
parameters:=
union("append"/[getParms(y,e) for y in rest x],parameters)
where getParms(y,e) ==
y isnt [.,:.] =>
isDomainForm(y,e) => [y]
nil
y is [op,y'] and op in '(LENGTH %llength) => [y,y']
[y]
x
x is ["DomainSubstitutionMacro",pl,body] =>
(parameters:= union(pl,parameters); body)
x is ["mkCategory",:.] => x
ident? x and getXmode(x,e) = $Category => x
stackSemanticError(["invalid argument to Join: ",x],nil)
x
T := [['DomainSubstitutionMacro,parameters,["Join",:catList']],$Category,e]
convert(T,m)
compForMode: (%Form,%Mode,%Env) -> %Maybe %Triple
compForMode(x,m,e) ==
$compForModeIfTrue: local:= true
$bootStrapMode and m = $Category =>
op := opOf x
ident? op and (db := constructorDB op) =>
dbConstructorKind db = "category" => [x,m,e]
nil
comp(x,m,e)
comp(x,m,e)
makeCategoryForm(c,e) ==
not isCategoryForm(c,e) => nil
[x,m,e]:= compOrCroak(c,$EmptyMode,e)
[x,e]
mustInstantiate: %Form -> %Thing
mustInstantiate D ==
D is [fn,:.] and
not (symbolMember?(fn,$DummyFunctorNames) or property(fn,"makeFunctionList"))
mkExplicitCategoryFunction(domainOrPackage,sigList,atList) ==
body:=
["mkCategory",MKQ domainOrPackage,['%list,:reverse sigList],
['%list,:reverse atList],MKQ domList,nil] where
domList() ==
("union"/[fn sig for ['QUOTE,[[.,sig,:.],:.]] in sigList]) where
fn sig == [D for D in sig | mustInstantiate D]
parameters:=
removeDuplicates
("append"/
[[x for x in sig | ident? x and x~='_$]
for ['QUOTE,[[.,sig,:.],:.]] in sigList])
['DomainSubstitutionMacro,parameters,body]
DomainSubstitutionFunction(parameters,body) ==
if parameters ~= nil then
(body := Subst(parameters,body)) where
Subst(parameters,body) ==
body isnt [.,:.] =>
objectMember?(body,parameters) => MKQ body
body
listMember?(body,parameters) =>
g := gensym()
$extraParms := [[g,:body],:$extraParms]
--Used in SetVector12 to generate a substitution list
--bound in buildFunctor
--For categories, bound and used in compDefineCategory
MKQ g
first body is 'QUOTE => body
cons? $definition and isFunctor body.op and
body.op ~= $definition.op => quote simplifyVMForm body
[Subst(parameters,u) for u in body]
body isnt ["Join",:.] => body
$definition isnt [.,:.] => body
$definition.args = nil => body
g := gensym()
['%bind,[[g,['constructorDB,quote $definition.op]]],
['%when,[['dbTemplate,g]],
['%otherwise,['%store,['dbTemplate,g],body]]]]
++ Subroutine of compCategoryItem.
++ Compile exported signature `opsig' under predicate `pred' in
++ environment `env'. The parameters `sigs' is a reference to a list
++ of signatures elaborated so far.
compSignature(db,opsig,pred,env,sigs) ==
[op,:sig] := opsig
cons? op =>
for y in op repeat
compSignature(db,[y,:sig],pred,env,sigs)
op in '(per rep) =>
stackSemanticError(['"cannot export signature for", :bright op],nil)
nil
noteExport(db,opsig,pred)
deref(sigs) := [MKQ [opsig,pred],:deref sigs]
++ Subroutine of comCategory.
++ Elaborate a category-level item `x' under the predicates `predl'.
++ The parameters `sigs' and `atts' are references to list of
++ signatures and attributes elaborated so far.
compCategoryItem(db,x,predl,env,sigs,atts) ==
x is nil => nil
--1. if x is a conditional expression, recurse; otherwise, form the predicate
x is ['%when,[p,e]] =>
predl':= [p,:predl]
e is ["PROGN",:l] =>
for y in l repeat compCategoryItem(db,y,predl',env,sigs,atts)
compCategoryItem(db,e,predl',env,sigs,atts)
x is ["IF",a,b,c] =>
a is ["not",p] => compCategoryItem(db,["IF",p,c,b],predl,env,sigs,atts)
a is ["and",p,q] =>
compCategoryItem(db,["IF",p,["IF",q,b,c],copyTree c],predl,env,sigs,atts)
a is ["or",p,q] =>
compCategoryItem(db,["IF",p,b,["IF",q,copyTree b,c]],predl,env,sigs,atts)
predl':= [a,:predl]
if b~="%noBranch" then
b is ["PROGN",:l] =>
for y in l repeat compCategoryItem(db,y,predl',env,sigs,atts)
compCategoryItem(db,b,predl',env,sigs,atts)
c="%noBranch" => nil
predl':= [["not",a],:predl]
c is ["PROGN",:l] =>
for y in l repeat
compCategoryItem(db,y,predl',env,sigs,atts)
compCategoryItem(db,c,predl',env,sigs,atts)
pred := (predl => MKPF(predl,"AND"); true)
--2. if attribute, push it and return
x is ["ATTRIBUTE",y] =>
-- Attribute 'nil' carries no semantics.
y = "nil" => nil
noteExport(db,y,pred)
deref(atts) := [MKQ [y,pred],:deref atts]
--3. it may be a list, with PROGN as the first, and some information as the rest
x is ["PROGN",:l] =>
for u in l repeat
compCategoryItem(db,u,predl,env,sigs,atts)
-- 4. otherwise, x gives a signature for a
-- single operator name or a list of names; if a list of names,
-- recurse
x is ["SIGNATURE",:opsig] => compSignature(db,opsig,pred,env,sigs)
systemErrorHere ["compCategoryItem",x]
compCategory: (%Form,%Mode,%Env) -> %Maybe %Triple
compCategory(x,m,e) ==
clearExportsTable()
db := currentDB e
m := resolve(m,$Category)
m = $Category and x is ['CATEGORY,kind,:l] =>
sigs := ref nil
atts := ref nil
for x in l repeat
compCategoryItem(db,x,nil,e,sigs,atts)
rep := mkExplicitCategoryFunction(kind,deref sigs,deref atts)
--if inside compDefineCategory, provide for category argument substitution
[rep,m,e]
systemErrorHere ["compCategory",x]
--%