diff --git a/changelog b/changelog index 62fcfc1..91bbee5 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090815 tpd src/axiom-website/patches.html 20090815.05.tpd.patch +20090815 tpd src/interp/Makefile move database.boot to database.lisp +20090815 tpd src/interp/database.lisp added, rewritten from database.boot +20090815 tpd src/interp/database.boot removed, rewritten to database.lisp 20090815 tpd src/axiom-website/patches.html 20090815.04.tpd.patch 20090815 tpd src/interp/Makefile move cstream.boot to cstream.lisp 20090815 tpd src/interp/cstream.lisp added, rewritten from cstream.boot diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 62fd26b..86a5d30 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1794,6 +1794,8 @@ src/interp/Makefile remove debugsys
src/input/Makefile add shannonmatrix.regress
20090815.04.tpd.patch cstream.lisp rewrite from boot to lisp
+20090815.05.tpd.patch +database.lisp rewrite from boot to lisp
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 086d19c..586093c 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -419,7 +419,6 @@ DOCFILES=${DOC}/as.boot.dvi \ ${DOC}/cfuns.lisp.dvi \ ${DOC}/compiler.boot.dvi \ ${DOC}/c-util.boot.dvi ${DOC}/daase.lisp.dvi \ - ${DOC}/database.boot.dvi \ ${DOC}/define.boot.dvi \ ${DOC}/fname.lisp.dvi \ ${DOC}/foam_l.lisp.dvi \ @@ -2732,47 +2731,27 @@ ${MID}/compress.lisp: ${IN}/compress.lisp.pamphlet @ -\subsection{database.boot \cite{67}} +\subsection{database.lisp} <>= -${OUT}/database.${O}: ${MID}/database.clisp - @ echo 242 making ${OUT}/database.${O} from ${MID}/database.clisp - @ (cd ${MID} ; \ +${OUT}/database.${O}: ${MID}/database.lisp + @ echo 136 making ${OUT}/database.${O} from ${MID}/database.lisp + @ ( cd ${MID} ; \ if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/database.clisp"' \ + echo '(progn (compile-file "${MID}/database.lisp"' \ ':output-file "${OUT}/database.${O}") (${BYE}))' | ${DEPSYS} ; \ else \ - echo '(progn (compile-file "${MID}/database.clisp"' \ + echo '(progn (compile-file "${MID}/database.lisp"' \ ':output-file "${OUT}/database.${O}") (${BYE}))' | ${DEPSYS} \ >${TMP}/trace ; \ fi ) @ -<>= -${MID}/database.clisp: ${IN}/database.boot.pamphlet - @ echo 243 making ${MID}/database.clisp \ - from ${IN}/database.boot.pamphlet +<>= +${MID}/database.lisp: ${IN}/database.lisp.pamphlet + @ echo 137 making ${MID}/database.lisp from \ + ${IN}/database.lisp.pamphlet @ (cd ${MID} ; \ - ${TANGLE} ${IN}/database.boot.pamphlet >database.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "database.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "database.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm database.boot ) - -@ -<>= -${DOC}/database.boot.dvi: ${IN}/database.boot.pamphlet - @echo 244 making ${DOC}/database.boot.dvi \ - from ${IN}/database.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/database.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} database.boot ; \ - rm -f ${DOC}/database.boot.pamphlet ; \ - rm -f ${DOC}/database.boot.tex ; \ - rm -f ${DOC}/database.boot ) + ${TANGLE} ${IN}/database.lisp.pamphlet >database.lisp ) @ @@ -6751,8 +6730,7 @@ clean: <> <> -<> -<> +<> <> <> @@ -7288,6 +7266,5 @@ pp \bibitem{60} {\bf \$SPAD/src/interp/c-doc.boot.pamphlet} \bibitem{64} {\bf \$SPAD/src/interp/compiler.boot.pamphlet} \bibitem{65} {\bf \$SPAD/src/interp/profile.boot.pamphlet} -\bibitem{67} {\bf \$SPAD/src/interp/database.boot.pamphlet} \end{thebibliography} \end{document} diff --git a/src/interp/database.boot.pamphlet b/src/interp/database.boot.pamphlet deleted file mode 100644 index 7313b12..0000000 --- a/src/interp/database.boot.pamphlet +++ /dev/null @@ -1,609 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp database.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -SETANDFILEQ($getUnexposedOperations,true) - ---% Functions for manipulating MODEMAP DATABASE - -augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == - sl := [["$",:"*1"],:[[a,:p] for a in argl - for p in rest $PatternVariableList]] - form:= SUBLIS(sl,form) - body:= SUBLIS(sl,body) - signature:= SUBLIS(sl,signature) - opAlist:= SUBLIS(sl,$domainShell.(1)) or return nil - nonCategorySigAlist:= - mkAlistOfExplicitCategoryOps substitute("*1","$",body) - domainList:= - [[a,m] for a in rest form for m in rest signature | - isCategoryForm(m,$EmptyEnvironment)] - catPredList:= [['ofCategory,:u] for u in [["*1",form],:domainList]] - for (entry:= [[op,sig,:.],pred,sel]) in opAlist | - MEMBER(sig,LASSOC(op,nonCategorySigAlist)) repeat - pred':= MKPF([pred,:catPredList],'AND) - modemap:= [["*1",:sig],[pred',sel]] - $lisplibModemapAlist:= - [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] - -augmentLisplibModemapsFromFunctor(form,opAlist,signature) == - form:= [formOp,:argl]:= formal2Pattern form - opAlist:= formal2Pattern opAlist - signature:= formal2Pattern signature - for u in form for v in signature repeat - if MEMQ(u,$PatternVariableList) then - -- we are going to be EVALing categories containing these - -- pattern variables - $e:=put(u,'mode,v,$e) - nonCategorySigAlist:= - mkAlistOfExplicitCategoryOps first signature or return nil - for (entry:= [[op,sig,:.],pred,sel]) in opAlist | - or/[(sig in catSig) for catSig in - allLASSOCs(op,nonCategorySigAlist)] repeat - skip:= - argl and CONTAINED("$",rest sig) => 'SKIP - nil - sel:= substitute(form,"$",sel) - patternList:= listOfPatternIds sig - --get relevant predicates - predList:= - [[a,m] for a in argl for m in rest signature - | MEMQ(a,$PatternVariableList)] - sig:= substitute(form,"$",sig) - pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) - l:=listOfPatternIds predList - if "OR"/[null MEMQ(u,l) for u in argl] then - sayMSG ['"cannot handle modemap for",:bright op, - '"by pattern match" ] - skip:= 'SKIP - modemap:= [[form,:sig],[pred',sel,:skip]] - $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], - :$lisplibModemapAlist] - -buildDatabase(filemode,expensive) == - $InteractiveMode: local:= true - $constructorList := nil --looked at by buildLibdb - $ConstructorCache:= MAKE_-HASHTABLE('ID) - SAY '"Making constructor autoload" - makeConstructorsAutoLoad() - SAY '"Building category table" - genCategoryTable() - SAY '"Building libdb.text" - buildLibdb() - SAY '"splitting libdb.text" - dbSplitLibdb() - SAY '"creating browse constructor index" - dbAugmentConstructorDataTable() - SAY '"Building browse.lisp" - buildBrowsedb() - SAY '"Building constructor users database" - mkUsersHashTable() - SAY '"Saving constructor users database" - saveUsersHashTable() - SAY '"Building constructor dependents database" - mkDependentsHashTable() - SAY '"Saving constructor dependents database" - saveDependentsHashTable() - SAY '"Building glossary files" - buildGloss() - -saveUsersHashTable() == - _$ERASE('users,'DATABASE,'a) - stream:= writeLib1('users,'DATABASE,'a) - for k in MSORT HKEYS $usersTb repeat - rwrite(k, HGET($usersTb, k), stream) - RSHUT stream - -saveDependentsHashTable() == - _$ERASE('dependents,'DATABASE,'a) - stream:= writeLib1('dependents,'DATABASE,'a) - for k in MSORT HKEYS $depTb repeat - rwrite(k, HGET($depTb, k), stream) - RSHUT stream - -getUsersOfConstructor(con) == - stream := readLib1('users, 'DATABASE, 'a) - val := rread(con, stream, nil) - RSHUT stream - val - -getDependentsOfConstructor(con) == - stream := readLib1('dependents, 'DATABASE, 'a) - val := rread(con, stream, nil) - RSHUT stream - val - -orderPredicateItems(pred1,sig,skip) == - pred:= signatureTran pred1 - pred is ["AND",:l] => orderPredTran(l,sig,skip) - pred - -orderPredTran(oldList,sig,skip) == - lastPreds:=nil - --(1) make two kinds of predicates appear last: - ----- (op *target ..) when *target does not appear later in sig - ----- (isDomain *1 ..) - for pred in oldList repeat - ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) - and pvar=first sig and ^(pvar in rest sig)) or - (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => - oldList:=DELETE(pred,oldList) - lastPreds:=[pred,:lastPreds] ---sayBrightlyNT "lastPreds=" ---pp lastPreds - - --(2a) lastDependList=list of all variables that lastPred forms depend upon - lastDependList := "UNIONQ"/[listOfPatternIds x for x in lastPreds] ---sayBrightlyNT "lastDependList=" ---pp lastDependList - - --(2b) dependList=list of all variables that isDom/ofCat forms depend upon - dependList := - "UNIONQ"/[listOfPatternIds y for x in oldList | - x is ['isDomain,.,y] or x is ['ofCategory,.,y]] ---sayBrightlyNT "dependList=" ---pp dependList - - --(3a) newList= list of ofCat/isDom entries that don't depend on - for x in oldList repeat - if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then - indepvl:=listOfPatternIds v - depvl:=listOfPatternIds body - else - indepvl := listOfPatternIds x - depvl := nil - (INTERSECTIONQ(indepvl,dependList) = nil) - and INTERSECTIONQ(indepvl,lastDependList) => - somethingDone := true - lastPreds := [:lastPreds,x] - oldList := DELETE(x,oldList) ---if somethingDone then --- sayBrightlyNT "Again lastPreds=" --- pp lastPreds --- sayBrightlyNT "Again oldList=" --- pp oldList - - --(3b) newList= list of ofCat/isDom entries that don't depend on - while oldList repeat - for x in oldList repeat - if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then - indepvl:=listOfPatternIds v - depvl:=listOfPatternIds body - else - indepvl := listOfPatternIds x - depvl := nil - (INTERSECTIONQ(indepvl,dependList) = nil) => - dependList:= setDifference(dependList,depvl) - newList:= [:newList,x] --- sayBrightlyNT "newList=" --- pp newList - - --(4) noldList= what is left over - (noldList:= setDifference(oldList,newList)) = oldList => --- sayMSG '"NOTE: Parameters to domain have circular dependencies" - newList := [:newList,:oldList] - return nil - oldList:=noldList --- sayBrightlyNT "noldList=" --- pp noldList - - for pred in newList repeat - if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then - ids:= listOfPatternIds y - if and/[id in fullDependList for id in ids] then - fullDependList:= insertWOC(x,fullDependList) - fullDependList:= UNIONQ(fullDependList,ids) - - newList:=[:newList,:lastPreds] - ---substitute (isDomain ..) forms as completely as possible to avoid false paths - newList := isDomainSubst newList - answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] ---sayBrightlyNT '"answer=" ---pp answer - -isDomainSubst u == main where - main == - u is [head,:tail] => - nhead := - head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] - head - [nhead,:isDomainSubst rest u] - u - fn(x,alist) == - atom x => - IDENTP x and MEMQ(x,$PatternVariableList) and (s := findSub(x,alist)) => s - x - [CAR x,:[fn(y,alist) for y in CDR x]] - findSub(x,alist) == - null alist => nil - alist is [['isDomain,y,z],:.] and x = y => z - findSub(x,rest alist) - -signatureTran pred == - atom pred => pred - pred is ['has,D,catForm] and isCategoryForm(catForm,$e) => - ['ofCategory,D,catForm] - [signatureTran p for p in pred] - -interactiveModemapForm mm == - -- create modemap form for use by the interpreter. This function - -- replaces all specific domains mentioned in the modemap with pattern - -- variables, and predicates - mm := replaceVars(COPY mm,$PatternVariableList,$FormalMapVariableList) - [pattern:=[dc,:sig],pred] := mm - pred := [fn x for x in pred] where fn x == - x is [a,b,c] and a ^= 'isFreeFunction and atom c => [a,b,[c]] - x ---pp pred - [mmpat, patternAlist, partial, patvars] := - modemapPattern(pattern,sig) ---pp [pattern, mmpat, patternAlist, partial, patvars] - [pred,domainPredicateList] := - substVars(pred,patternAlist,patvars) ---pp [pred,domainPredicateList] - [pred,:dependList]:= - fixUpPredicate(pred,domainPredicateList,partial,rest mmpat) ---pp [pred,dependList] - [cond, :.] := pred - [mmpat, cond] - -modemapPattern(mmPattern,sig) == - -- Returns a list of the pattern of a modemap, an Alist of the - -- substitutions made, a boolean flag indicating whether - -- the result type is partial, and a list of unused pattern variables - patternAlist := nil - mmpat := nil - patvars := $PatternVariableList - partial := false - for xTails in tails mmPattern repeat - x := first xTails - if x is ['Union,dom,tag] and tag = '"failed" and xTails=sig then - x := dom - partial := true - patvar := RASSOC(x,patternAlist) - not null patvar => mmpat := [patvar,:mmpat] - patvar := first patvars - patvars := rest patvars - mmpat := [patvar,:mmpat] - patternAlist := [[patvar,:x],:patternAlist] - [NREVERSE mmpat,patternAlist,partial,patvars] - -substVars(pred,patternAlist,patternVarList) == - --make pattern variable substitutions - domainPredicates := nil - for [[patVar,:value],:.] in tails patternAlist repeat - pred := substitute(patVar,value,pred) - patternAlist := nsubst(patVar,value,patternAlist) - domainPredicates := substitute(patVar,value,domainPredicates) - if ^MEMQ(value,$FormalMapVariableList) then - domainPredicates := [["isDomain",patVar,value],:domainPredicates] - everything := [pred,patternAlist,domainPredicates] - for var in $FormalMapVariableList repeat - CONTAINED(var,everything) => - replacementVar := first patternVarList - patternVarList := rest patternVarList - pred := substitute(replacementVar,var,pred) - domainPredicates := substitute(replacementVar,var,domainPredicates) - [pred, domainPredicates] - -fixUpPredicate(predClause, domainPreds, partial, sig) == - -- merge the predicates in predClause and domainPreds into a - -- single predicate - [predicate, fn, :skip] := predClause - if first predicate = "AND" then - predicates := APPEND(domainPreds,rest predicate) - else if predicate ^= MKQ "T" ---was->then predicates:= REVERSE [predicate, :domainPreds] - then predicates:= [predicate, :domainPreds] - else predicates := domainPreds or [predicate] - if #predicates > 1 then - pred := ["AND",:predicates] - [pred,:dependList]:=orderPredicateItems(pred,sig,skip) - else - pred := orderPredicateItems(first predicates,sig,skip) - dependList:= if pred is ['isDomain,pvar,[.]] then [pvar] else nil - pred := moveORsOutside pred - if partial then pred := ["partial", :pred] - [[pred, fn, :skip],:dependList] - -moveORsOutside p == - p is ['AND,:q] => - q := [moveORsOutside r for r in q] - x := or/[r for r in q | r is ['OR,:s]] => - moveORsOutside(['OR,:[['AND,:SUBST(t,x,q)] for t in CDR x]]) - ['AND,:q] - p - -replaceVars(x,oldvars,newvars) == - -- replace every identifier in oldvars with the corresponding - -- identifier in newvars in the expression x - for old in oldvars for new in newvars repeat - x := substitute(new,old,x) - x - -getDomainFromMm mm == - -- Returns the Domain (or package or category) of origin from a pattern - -- modemap - [., cond] := mm - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - val := - for condition in condList repeat - condition is ['isDomain, "*1", dom] => return opOf dom - condition is ['ofCategory, "*1", cat] => return opOf cat - null val => - keyedSystemError("S2GE0016", - ['"getDomainFromMm",'"Can't find domain in modemap condition"]) - val - -getFirstArgTypeFromMm mm == - -- Returns the type of the first argument or nil - [pats, cond] := mm - [.,.,:args] := pats - null args => nil - arg1 := first args - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - type := nil - for condition in condList while not type repeat - if condition is ['isDomain, a1, dom] and a1=arg1 then type := dom - type - -isFreeFunctionFromMm mm == - -- This returns true is the modemap represents a free function, ie, - -- one not coming from a domain or category. - [., cond] := mm - isFreeFunctionFromMmCond cond - -isFreeFunctionFromMmCond cond == - -- This returns true is the modemap represents a free function, ie, - -- one not coming from a domain or category. - if cond is ['partial, :c] then cond := c - condList := - cond is ['AND, :cl] => cl - cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info - [cond] - iff := false - for condition in condList while not iff repeat - if condition is ['isFreeFunction, :.] then iff := true - iff - -getAllModemapsFromDatabase(op,nargs) == - $getUnexposedOperations: local := true - startTimingProcess 'diskread - ans := getSystemModemaps(op,nargs) - stopTimingProcess 'diskread - ans - -getModemapsFromDatabase(op,nargs) == - $getUnexposedOperations: local := false - startTimingProcess 'diskread - ans := getSystemModemaps(op,nargs) - stopTimingProcess 'diskread - ans - -getSystemModemaps(op,nargs) == - mml:= GETDATABASE(op,'OPERATION) => - mms := NIL - for (x := [[.,:sig],.]) in mml repeat - (NUMBERP nargs) and (nargs ^= #QCDR sig) => 'iterate - $getUnexposedOperations or isFreeFunctionFromMm(x) or - isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] - 'iterate - mms - nil - -getInCoreModemaps(modemapList,op,nargs) == - mml:= LASSOC (op,modemapList) => - mml:= CAR mml - [x for (x:= [[dc,:sig],.]) in mml | - (NUMBERP nargs => nargs=#rest sig; true) and - (cfn := abbreviate (domName := getDomainFromMm x)) and - ($getUnexposedOperations or isExposedConstructor(domName))] - nil - -mkAlistOfExplicitCategoryOps target == - if target is ['add,a,:l] then - target:=a - target is ['Join,:l] => - "UNION"/[mkAlistOfExplicitCategoryOps cat for cat in l] - target is ['CATEGORY,.,:l] => - l:= flattenSignatureList ['PROGN,:l] - u:= - [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] - where - atomizeOp op == - atom op => op - op is [a] => a - keyedSystemError("S2GE0016", - ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) - opList:= REMDUP ASSOCLEFT u - [[x,:fn(x,u)] for x in opList] where - fn(op,u) == - u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) - isCategoryForm(target,$e) => nil - keyedSystemError("S2GE0016", - ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) - -flattenSignatureList(x) == - atom x => nil - x is ['SIGNATURE,:.] => [x] - x is ['IF,cond,b1,b2] => - append(flattenSignatureList b1, flattenSignatureList b2) - x is ['PROGN,:l] => - ll:= [] - for x in l repeat - x is ['SIGNATURE,:.] => ll:=cons(x,ll) - ll:= append(flattenSignatureList x,ll) - ll - nil - -mkDatabasePred [a,t] == - isCategoryForm(t,$e) => ['ofCategory,a,t] - ['ofType,a,t] - -formal2Pattern x == - SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) - -updateDatabase(fname,cname,systemdir?) == - -- for now in NRUNTIME do database update only if forced - not $forceDatabaseUpdate => nil - $newcompMode = 'true => nil - -- these modemaps are never needed in the old scheme - if oldFname := constructor? cname then - clearClams() - clearAllSlams [] - if GET(cname, 'LOADED) then - clearConstructorCaches() - if $forceDatabaseUpdate or not systemdir? then - clearClams() - clearAllSlams [] - -removeCoreModemaps(modemapList,c) == - newUserModemaps:= nil - c := opOf unabbrev c - for [op,mmList] in modemapList repeat - temp:= nil - for mm in mmList repeat - cname := getDomainFromMm mm - if cname ^= c then temp:= [:temp,mm] - if temp then newUserModemaps:= [:newUserModemaps,[op,temp]] - newUserModemaps - -addCoreModemap(modemapList,op,modemap,cname) == - entry:= ASSQ(op,modemapList) => - RPLAC(CADR entry,[modemap,:CADR entry]) - modemapList - modeMapList:= [:modemapList,[op,[ modemap]]] - -REMOVER(lst,item) == - --destructively removes item from lst - not PAIRP lst => - lst=item => nil - lst - first lst=item => rest lst - RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) - -allLASSOCs(op,alist) == - [value for [key,:value] in alist | key = op] - -loadDependents fn == - isExistingFile [fn,$spadLibFT,"*"] => - MEMQ("dependents",RKEYIDS(fn,$spadLibFT)) => - stream:= readLib1(fn,$spadLibFT,"*") - l:= rread('dependents,stream,nil) - RSHUT stream - for x in l repeat - x='SubDomain => nil - loadIfNecessary x - ---% Miscellaneous Stuff - -getOplistForConstructorForm (form := [op,:argl]) == - -- The new form is an op-Alist which has entries ( . signature-Alist) - -- where signature-Alist has entries ( . item) - -- where item has form ( ) - -- where = ELT | CONST | Subsumed | (XLAM..) .. - pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] - opAlist := getOperationAlistFromLisplib op - [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) - for [op,:signatureAlist] in opAlist] - -getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == - alist:= nil - for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat - alist:= insertAlist(SUBLIS(pairlis,[op,sig]), - SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), - alist) - alist - ---% Code For Modemap Insertion - -insertModemap(new,mmList) == - null mmList => [new] ---isMoreSpecific(new,old:= first mmList) => [new,:mmList] ---[old,:insertModemap(new,rest mmList)] - [new,:mmList] - ---% Exposure Group Code - -dropPrefix(fn) == - MEMBER(fn.0,[char "?",char "-",char "+"]) => SUBSTRING(fn,1,nil) - fn - -isExposedConstructor name == - -- this function checks the local exposure data in the frame to - -- see if the given constructor is exposed. The format of - -- $localExposureData is a vector with - -- slot 0: list of groups exposed in the frame - -- slot 1: list of constructors explicitly exposed - -- slot 2: list of constructors explicitly hidden - -- check if it is explicitly hidden - MEMQ(name,'(Union Record Mapping)) => true - MEMQ(name,$localExposureData.2) => false - -- check if it is explicitly exposed - MEMQ(name,$localExposureData.1) => true - -- check if it is in an exposed group - found := NIL - for g in $localExposureData.0 while not found repeat - null (x := GETALIST($globalExposureGroupAlist,g)) => 'iterate - if GETALIST(x,name) then found := true - found - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/database.lisp.pamphlet b/src/interp/database.lisp.pamphlet new file mode 100644 index 0000000..cc633ce --- /dev/null +++ b/src/interp/database.lisp.pamphlet @@ -0,0 +1,2180 @@ +\documentclass{article} +\usepackage{axiom} +\begin{document} +\title{\$SPAD/src/interp database.boot} +\author{The Axiom Team} +\maketitle +\begin{abstract} +\end{abstract} +\eject +\tableofcontents +\eject +<<*>>= +(IN-PACKAGE "BOOT" ) + +;SETANDFILEQ($getUnexposedOperations,true) + +(SETANDFILEQ |$getUnexposedOperations| (QUOTE T)) + +;--% Functions for manipulating MODEMAP DATABASE +;augLisplibModemapsFromCategory(form is [op,:argl],body,signature) == +; sl := [["$",:"*1"],:[[a,:p] for a in argl +; for p in rest $PatternVariableList]] +; form:= SUBLIS(sl,form) +; body:= SUBLIS(sl,body) +; signature:= SUBLIS(sl,signature) +; opAlist:= SUBLIS(sl,$domainShell.(1)) or return nil +; nonCategorySigAlist:= +; mkAlistOfExplicitCategoryOps substitute("*1","$",body) +; domainList:= +; [[a,m] for a in rest form for m in rest signature | +; isCategoryForm(m,$EmptyEnvironment)] +; catPredList:= [['ofCategory,:u] for u in [["*1",form],:domainList]] +; for (entry:= [[op,sig,:.],pred,sel]) in opAlist | +; MEMBER(sig,LASSOC(op,nonCategorySigAlist)) repeat +; pred':= MKPF([pred,:catPredList],'AND) +; modemap:= [["*1",:sig],[pred',sel]] +; $lisplibModemapAlist:= +; [[op,:interactiveModemapForm modemap],:$lisplibModemapAlist] + +(DEFUN |augLisplibModemapsFromCategory| (|form| |body| |signature|) + (PROG (|argl| |sl| |opAlist| |nonCategorySigAlist| |domainList| + |catPredList| |op| |sig| |pred| |sel| |pred'| |modemap|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |sl| + (CONS + (CONS (QUOTE $) (QUOTE *1)) + (PROG (#0=#:G166082) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166088 |argl| (CDR #1#)) + (|a| NIL) + (#2=#:G166089 (CDR |$PatternVariableList|) (CDR #2#)) + (|p| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |a| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |p| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |a| |p|) #0#))))))))) + (SPADLET |form| (SUBLIS |sl| |form|)) + (SPADLET |body| (SUBLIS |sl| |body|)) + (SPADLET |signature| (SUBLIS |sl| |signature|)) + (SPADLET |opAlist| (OR (SUBLIS |sl| (ELT |$domainShell| 1)) (RETURN NIL))) + (SPADLET |nonCategorySigAlist| + (|mkAlistOfExplicitCategoryOps| (MSUBST (QUOTE *1) (QUOTE $) |body|))) + (SPADLET |domainList| + (PROG (#3=#:G166104) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166111 (CDR |form|) (CDR #4#)) + (|a| NIL) + (#5=#:G166112 (CDR |signature|) (CDR #5#)) + (|m| NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ |a| (CAR #4#)) NIL) + (ATOM #5#) + (PROGN (SETQ |m| (CAR #5#)) NIL)) + (NREVERSE0 #3#)) + (SEQ + (EXIT + (COND + ((|isCategoryForm| |m| |$EmptyEnvironment|) + (SETQ #3# (CONS (CONS |a| (CONS |m| NIL)) #3#)))))))))) + (SPADLET |catPredList| + (PROG (#6=#:G166125) + (SPADLET #6# NIL) + (RETURN + (DO ((#7=#:G166130 + (CONS + (CONS (QUOTE *1) (CONS |form| NIL)) + |domainList|) + (CDR #7#)) + (|u| NIL)) + ((OR (ATOM #7#) (PROGN (SETQ |u| (CAR #7#)) NIL)) + (NREVERSE0 #6#)) + (SEQ (EXIT (SETQ #6# (CONS (CONS (QUOTE |ofCategory|) |u|) #6#)))))))) + (DO ((#8=#:G166144 |opAlist| (CDR #8#)) (|entry| NIL)) + ((OR (ATOM #8#) + (PROGN (SETQ |entry| (CAR #8#)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR |entry|)) + (SPADLET |sig| (CADAR |entry|)) + (SPADLET |pred| (CADR |entry|)) + (SPADLET |sel| (CADDR |entry|)) + |entry|) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((|member| |sig| (LASSOC |op| |nonCategorySigAlist|)) + (PROGN + (SPADLET |pred'| (MKPF (CONS |pred| |catPredList|) (QUOTE AND))) + (SPADLET |modemap| + (CONS + (CONS (QUOTE *1) |sig|) + (CONS (CONS |pred'| (CONS |sel| NIL)) NIL))) + (SPADLET |$lisplibModemapAlist| + (CONS + (CONS |op| (|interactiveModemapForm| |modemap|)) + |$lisplibModemapAlist|))))))))))))) + +;augmentLisplibModemapsFromFunctor(form,opAlist,signature) == +; form:= [formOp,:argl]:= formal2Pattern form +; opAlist:= formal2Pattern opAlist +; signature:= formal2Pattern signature +; for u in form for v in signature repeat +; if MEMQ(u,$PatternVariableList) then +; -- we are going to be EVALing categories containing these +; -- pattern variables +; $e:=put(u,'mode,v,$e) +; nonCategorySigAlist:= +; mkAlistOfExplicitCategoryOps first signature or return nil +; for (entry:= [[op,sig,:.],pred,sel]) in opAlist | +; or/[(sig in catSig) for catSig in +; allLASSOCs(op,nonCategorySigAlist)] repeat +; skip:= +; argl and CONTAINED("$",rest sig) => 'SKIP +; nil +; sel:= substitute(form,"$",sel) +; patternList:= listOfPatternIds sig +; --get relevant predicates +; predList:= +; [[a,m] for a in argl for m in rest signature +; | MEMQ(a,$PatternVariableList)] +; sig:= substitute(form,"$",sig) +; pred':= MKPF([pred,:[mkDatabasePred y for y in predList]],'AND) +; l:=listOfPatternIds predList +; if "OR"/[null MEMQ(u,l) for u in argl] then +; sayMSG ['"cannot handle modemap for",:bright op, +; '"by pattern match" ] +; skip:= 'SKIP +; modemap:= [[form,:sig],[pred',sel,:skip]] +; $lisplibModemapAlist:= [[op,:interactiveModemapForm modemap], +; :$lisplibModemapAlist] + +(DEFUN |augmentLisplibModemapsFromFunctor| (|form| |opAlist| |signature|) + (PROG (|LETTMP#1| |formOp| |argl| |nonCategorySigAlist| |op| |pred| |sel| + |patternList| |predList| |sig| |pred'| |l| |skip| |modemap|) + (RETURN + (SEQ + (PROGN + (SPADLET |form| + (PROGN + (SPADLET |LETTMP#1| (|formal2Pattern| |form|)) + (SPADLET |formOp| (CAR |LETTMP#1|)) + (SPADLET |argl| (CDR |LETTMP#1|)) + |LETTMP#1|)) + (SPADLET |opAlist| (|formal2Pattern| |opAlist|)) + (SPADLET |signature| (|formal2Pattern| |signature|)) + (DO ((#0=#:G166194 |form| (CDR #0#)) + (|u| NIL) + (#1=#:G166195 |signature| (CDR #1#)) + (|v| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |u| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |v| (CAR #1#)) NIL)) + NIL) + (SEQ + (EXIT + (COND + ((MEMQ |u| |$PatternVariableList|) + (SPADLET |$e| (|put| |u| (QUOTE |mode|) |v| |$e|))) + ((QUOTE T) NIL))))) + (SPADLET |nonCategorySigAlist| + (OR (|mkAlistOfExplicitCategoryOps| (CAR |signature|)) (RETURN NIL))) + (DO ((#2=#:G166219 |opAlist| (CDR #2#)) (|entry| NIL)) + ((OR (ATOM #2#) + (PROGN (SETQ |entry| (CAR #2#)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAAR |entry|)) + (SPADLET |sig| (CADAR |entry|)) + (SPADLET |pred| (CADR |entry|)) + (SPADLET |sel| (CADDR |entry|)) + |entry|) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((PROG (#3=#:G166226) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166232 NIL #3#) + (#5=#:G166233 + (|allLASSOCs| |op| |nonCategorySigAlist|) (CDR #5#)) + (|catSig| NIL)) + ((OR #4# (ATOM #5#) (PROGN (SETQ |catSig| (CAR #5#)) NIL)) #3#) + (SEQ (EXIT (SETQ #3# (OR #3# (|member| |sig| |catSig|)))))))) + (PROGN + (SPADLET |skip| + (COND + ((AND |argl| (CONTAINED (QUOTE $) (CDR |sig|))) (QUOTE SKIP)) + ((QUOTE T) NIL))) + (SPADLET |sel| (MSUBST |form| (QUOTE $) |sel|)) + (SPADLET |patternList| (|listOfPatternIds| |sig|)) + (SPADLET |predList| + (PROG (#6=#:G166246) + (SPADLET #6# NIL) + (RETURN + (DO ((#7=#:G166253 |argl| (CDR #7#)) + (|a| NIL) + (#8=#:G166254 (CDR |signature|) (CDR #8#)) + (|m| NIL)) + ((OR (ATOM #7#) + (PROGN (SETQ |a| (CAR #7#)) NIL) + (ATOM #8#) + (PROGN (SETQ |m| (CAR #8#)) NIL)) + (NREVERSE0 #6#)) + (SEQ + (EXIT + (COND + ((MEMQ |a| |$PatternVariableList|) + (SETQ #6# (CONS (CONS |a| (CONS |m| NIL)) #6#)))))))))) + (SPADLET |sig| (MSUBST |form| (QUOTE $) |sig|)) + (SPADLET |pred'| + (MKPF + (CONS + |pred| + (PROG (#9=#:G166267) + (SPADLET #9# NIL) + (RETURN + (DO ((#10=#:G166272 |predList| (CDR #10#)) (|y| NIL)) + ((OR (ATOM #10#) + (PROGN (SETQ |y| (CAR #10#)) NIL)) + (NREVERSE0 #9#)) + (SEQ + (EXIT + (SETQ #9# (CONS (|mkDatabasePred| |y|) #9#)))))))) + (QUOTE AND))) + (SPADLET |l| (|listOfPatternIds| |predList|)) + (COND + ((PROG (#11=#:G166278) + (SPADLET #11# NIL) + (RETURN + (DO ((#12=#:G166284 NIL #11#) + (#13=#:G166285 |argl| (CDR #13#)) + (|u| NIL)) + ((OR #12# + (ATOM #13#) + (PROGN (SETQ |u| (CAR #13#)) NIL)) + #11#) + (SEQ (EXIT (SETQ #11# (OR #11# (NULL (MEMQ |u| |l|))))))))) + (|sayMSG| + (CONS + "cannot handle modemap for" + (APPEND (|bright| |op|) (CONS "by pattern match" NIL)))) + (SPADLET |skip| (QUOTE SKIP)))) + (SPADLET |modemap| + (CONS + (CONS |form| |sig|) + (CONS (CONS |pred'| (CONS |sel| |skip|)) NIL))) + (SPADLET |$lisplibModemapAlist| + (CONS + (CONS |op| (|interactiveModemapForm| |modemap|)) + |$lisplibModemapAlist|))))))))))))) + +;buildDatabase(filemode,expensive) == +; $InteractiveMode: local:= true +; $constructorList := nil --looked at by buildLibdb +; $ConstructorCache:= MAKE_-HASHTABLE('ID) +; SAY '"Making constructor autoload" +; makeConstructorsAutoLoad() +; SAY '"Building category table" +; genCategoryTable() +; SAY '"Building libdb.text" +; buildLibdb() +; SAY '"splitting libdb.text" +; dbSplitLibdb() +; SAY '"creating browse constructor index" +; dbAugmentConstructorDataTable() +; SAY '"Building browse.lisp" +; buildBrowsedb() +; SAY '"Building constructor users database" +; mkUsersHashTable() +; SAY '"Saving constructor users database" +; saveUsersHashTable() +; SAY '"Building constructor dependents database" +; mkDependentsHashTable() +; SAY '"Saving constructor dependents database" +; saveDependentsHashTable() +; SAY '"Building glossary files" +; buildGloss() + +(DEFUN |buildDatabase| (|filemode| |expensive|) + (PROG (|$InteractiveMode|) + (DECLARE (SPECIAL |$InteractiveMode|)) + (RETURN + (PROGN + (SPADLET |$InteractiveMode| (QUOTE T)) + (SPADLET |$constructorList| NIL) + (SPADLET |$ConstructorCache| (MAKE-HASHTABLE (QUOTE ID))) + (SAY (MAKESTRING "Making constructor autoload")) + (|makeConstructorsAutoLoad|) + (SAY (MAKESTRING "Building category table")) + (|genCategoryTable|) + (SAY (MAKESTRING "Building libdb.text")) + (|buildLibdb|) + (SAY (MAKESTRING "splitting libdb.text")) + (|dbSplitLibdb|) + (SAY (MAKESTRING "creating browse constructor index")) + (|dbAugmentConstructorDataTable|) + (SAY (MAKESTRING "Building browse.lisp")) + (|buildBrowsedb|) + (SAY (MAKESTRING "Building constructor users database")) + (|mkUsersHashTable|) + (SAY (MAKESTRING "Saving constructor users database")) + (|saveUsersHashTable|) + (SAY (MAKESTRING "Building constructor dependents database")) + (|mkDependentsHashTable|) + (SAY (MAKESTRING "Saving constructor dependents database")) + (|saveDependentsHashTable|) + (SAY (MAKESTRING "Building glossary files")) + (|buildGloss|))))) + +;saveUsersHashTable() == +; _$ERASE('users,'DATABASE,'a) +; stream:= writeLib1('users,'DATABASE,'a) +; for k in MSORT HKEYS $usersTb repeat +; rwrite(k, HGET($usersTb, k), stream) +; RSHUT stream + +(DEFUN |saveUsersHashTable| () + (PROG (|stream|) + (RETURN + (SEQ + (PROGN + ($ERASE (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|)) + (SPADLET |stream| + (|writeLib1| (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|))) + (DO ((#0=#:G166334 (MSORT (HKEYS |$usersTb|)) (CDR #0#)) (|k| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |k| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|rwrite| |k| (HGET |$usersTb| |k|) |stream|)))) + (RSHUT |stream|)))))) + +;saveDependentsHashTable() == +; _$ERASE('dependents,'DATABASE,'a) +; stream:= writeLib1('dependents,'DATABASE,'a) +; for k in MSORT HKEYS $depTb repeat +; rwrite(k, HGET($depTb, k), stream) +; RSHUT stream + +(DEFUN |saveDependentsHashTable| () + (PROG (|stream|) + (RETURN + (SEQ + (PROGN + ($ERASE (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|)) + (SPADLET |stream| + (|writeLib1| (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|))) + (DO ((#0=#:G166348 (MSORT (HKEYS |$depTb|)) (CDR #0#)) (|k| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |k| (CAR #0#)) NIL)) NIL) + (SEQ (EXIT (|rwrite| |k| (HGET |$depTb| |k|) |stream|)))) + (RSHUT |stream|)))))) + +;getUsersOfConstructor(con) == +; stream := readLib1('users, 'DATABASE, 'a) +; val := rread(con, stream, nil) +; RSHUT stream +; val + +(DEFUN |getUsersOfConstructor| (|con|) + (PROG (|stream| |val|) + (RETURN + (PROGN + (SPADLET |stream| + (|readLib1| (QUOTE |users|) (QUOTE DATABASE) (QUOTE |a|))) + (SPADLET |val| (|rread| |con| |stream| NIL)) + (RSHUT |stream|) |val|)))) +;getDependentsOfConstructor(con) == +; stream := readLib1('dependents, 'DATABASE, 'a) +; val := rread(con, stream, nil) +; RSHUT stream +; val + +(DEFUN |getDependentsOfConstructor| (|con|) + (PROG (|stream| |val|) + (RETURN + (PROGN + (SPADLET |stream| + (|readLib1| (QUOTE |dependents|) (QUOTE DATABASE) (QUOTE |a|))) + (SPADLET |val| (|rread| |con| |stream| NIL)) + (RSHUT |stream|) + |val|)))) + +;orderPredicateItems(pred1,sig,skip) == +; pred:= signatureTran pred1 +; pred is ["AND",:l] => orderPredTran(l,sig,skip) +; pred + +(DEFUN |orderPredicateItems| (|pred1| |sig| |skip|) + (PROG (|pred| |l|) + (RETURN + (PROGN + (SPADLET |pred| (|signatureTran| |pred1|)) + (COND + ((AND (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE AND)) + (PROGN (SPADLET |l| (QCDR |pred|)) (QUOTE T))) + (|orderPredTran| |l| |sig| |skip|)) + ((QUOTE T) |pred|)))))) + +;orderPredTran(oldList,sig,skip) == +; lastPreds:=nil +; --(1) make two kinds of predicates appear last: +; ----- (op *target ..) when *target does not appear later in sig +; ----- (isDomain *1 ..) +; for pred in oldList repeat +; ((pred is [op,pvar,.] and MEMQ(op,'(isDomain ofCategory)) +; and pvar=first sig and ^(pvar in rest sig)) or +; (^skip and pred is ['isDomain,pvar,.] and pvar="*1")) => +; oldList:=DELETE(pred,oldList) +; lastPreds:=[pred,:lastPreds] +;--sayBrightlyNT "lastPreds=" +;--pp lastPreds +; --(2a) lastDependList=list of all variables that lastPred forms depend upon +; lastDependList := "UNIONQ"/[listOfPatternIds x for x in lastPreds] +;--sayBrightlyNT "lastDependList=" +;--pp lastDependList +; --(2b) dependList=list of all variables that isDom/ofCat forms depend upon +; dependList := +; "UNIONQ"/[listOfPatternIds y for x in oldList | +; x is ['isDomain,.,y] or x is ['ofCategory,.,y]] +;--sayBrightlyNT "dependList=" +;--pp dependList +; --(3a) newList= list of ofCat/isDom entries that don't depend on +; for x in oldList repeat +; if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then +; indepvl:=listOfPatternIds v +; depvl:=listOfPatternIds body +; else +; indepvl := listOfPatternIds x +; depvl := nil +; (INTERSECTIONQ(indepvl,dependList) = nil) +; and INTERSECTIONQ(indepvl,lastDependList) => +; somethingDone := true +; lastPreds := [:lastPreds,x] +; oldList := DELETE(x,oldList) +;--if somethingDone then +;-- sayBrightlyNT "Again lastPreds=" +;-- pp lastPreds +;-- sayBrightlyNT "Again oldList=" +;-- pp oldList +; --(3b) newList= list of ofCat/isDom entries that don't depend on +; while oldList repeat +; for x in oldList repeat +; if (x is ['ofCategory,v,body]) or (x is ['isDomain,v,body]) then +; indepvl:=listOfPatternIds v +; depvl:=listOfPatternIds body +; else +; indepvl := listOfPatternIds x +; depvl := nil +; (INTERSECTIONQ(indepvl,dependList) = nil) => +; dependList:= setDifference(dependList,depvl) +; newList:= [:newList,x] +;-- sayBrightlyNT "newList=" +;-- pp newList +; --(4) noldList= what is left over +; (noldList:= setDifference(oldList,newList)) = oldList => +;-- sayMSG '"NOTE: Parameters to domain have circular dependencies" +; newList := [:newList,:oldList] +; return nil +; oldList:=noldList +;-- sayBrightlyNT "noldList=" +;-- pp noldList +; for pred in newList repeat +; if pred is ['isDomain,x,y] or x is ['ofCategory,x,y] then +; ids:= listOfPatternIds y +; if and/[id in fullDependList for id in ids] then +; fullDependList:= insertWOC(x,fullDependList) +; fullDependList:= UNIONQ(fullDependList,ids) +; newList:=[:newList,:lastPreds] +;--substitute (isDomain ..) forms as completely as possible to avoid false paths +; newList := isDomainSubst newList +; answer := [['AND,:newList],:INTERSECTIONQ(fullDependList,sig)] + +(DEFUN |orderPredTran| (|oldList| |sig| |skip|) + (PROG (|op| |pvar| |lastDependList| |somethingDone| |lastPreds| |v| |body| + |indepvl| |depvl| |dependList| |noldList| |ISTMP#1| |x| |ISTMP#2| + |y| |ids| |fullDependList| |newList| |answer|) + (RETURN + (SEQ + (PROGN + (SPADLET |lastPreds| NIL) + (SEQ + (DO ((#0=#:G166547 |oldList| (CDR #0#)) (|pred| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |pred| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((OR + (AND + (PAIRP |pred|) + (PROGN + (SPADLET |op| (QCAR |pred|)) + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) + (MEMQ |op| (QUOTE (|isDomain| |ofCategory|))) + (BOOT-EQUAL |pvar| (CAR |sig|)) + (NULL (|member| |pvar| (CDR |sig|)))) + (AND + (NULL |skip|) + (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL))))) + (BOOT-EQUAL |pvar| (QUOTE *1)))) + (EXIT + (PROGN + (SPADLET |oldList| (|delete| |pred| |oldList|)) + (SPADLET |lastPreds| (CONS |pred| |lastPreds|))))))))) + (SPADLET |lastDependList| + (PROG (#1=#:G166553) + (SPADLET #1# NIL) + (RETURN + (DO ((#2=#:G166558 |lastPreds| (CDR #2#)) (|x| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |x| (CAR #2#)) NIL)) #1#) + (SEQ (EXIT (SETQ #1# (UNIONQ #1# (|listOfPatternIds| |x|))))))))) + (SPADLET |dependList| + (PROG (#3=#:G166564) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G166570 |oldList| (CDR #4#)) (|x| NIL)) + ((OR (ATOM #4#) (PROGN (SETQ |x| (CAR #4#)) NIL)) #3#) + (SEQ + (EXIT + (COND + ((OR + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T)))))))) + (SETQ #3# (UNIONQ #3# (|listOfPatternIds| |y|))))))))))) + (DO ((#5=#:G166598 |oldList| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((OR + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T)))))))) + (SPADLET |indepvl| (|listOfPatternIds| |v|)) + (SPADLET |depvl| (|listOfPatternIds| |body|))) + ((QUOTE T) + (SPADLET |indepvl| (|listOfPatternIds| |x|)) + (SPADLET |depvl| NIL))) + (COND + ((AND + (NULL (INTERSECTIONQ |indepvl| |dependList|)) + (INTERSECTIONQ |indepvl| |lastDependList|)) + (PROGN + (SPADLET |somethingDone| (QUOTE T)) + (SPADLET |lastPreds| (APPEND |lastPreds| (CONS |x| NIL))) + (SPADLET |oldList| (|delete| |x| |oldList|))))))))) + (DO () + ((NULL |oldList|) NIL) + (SEQ + (EXIT + (PROGN + (DO + ((#6=#:G166651 |oldList| (CDR #6#)) (|x| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |x| (CAR #6#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (COND + ((OR + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |body| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |v| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |body| (QCAR |ISTMP#2|)) + (QUOTE T)))))))) + (SPADLET |indepvl| (|listOfPatternIds| |v|)) + (SPADLET |depvl| (|listOfPatternIds| |body|))) + ((QUOTE T) + (SPADLET |indepvl| (|listOfPatternIds| |x|)) + (SPADLET |depvl| NIL))) + (COND + ((NULL (INTERSECTIONQ |indepvl| |dependList|)) + (PROGN + (SPADLET |dependList| (SETDIFFERENCE |dependList| |depvl|)) + (SPADLET |newList| (APPEND |newList| (CONS |x| NIL)))))))))) + (COND + ((BOOT-EQUAL + (SPADLET |noldList| (SETDIFFERENCE |oldList| |newList|)) + |oldList|) + (SPADLET |newList| (APPEND |newList| |oldList|)) (RETURN NIL)) + ((QUOTE T) (SPADLET |oldList| |noldList|))))))) + (DO ((#7=#:G166674 |newList| (CDR #7#)) (|pred| NIL)) + ((OR (ATOM #7#) (PROGN (SETQ |pred| (CAR #7#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((OR + (AND + (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T)))))))) + (SPADLET |ids| (|listOfPatternIds| |y|)) + (COND + ((PROG (#8=#:G166680) + (SPADLET #8# (QUOTE T)) + (RETURN + (DO ((#9=#:G166686 NIL (NULL #8#)) + (#10=#:G166687 |ids| (CDR #10#)) + (|id| NIL)) + ((OR #9# + (ATOM #10#) + (PROGN (SETQ |id| (CAR #10#)) NIL)) + #8#) + (SEQ + (EXIT + (SETQ #8# (AND #8# (|member| |id| |fullDependList|)))))))) + (SPADLET |fullDependList| (|insertWOC| |x| |fullDependList|)))) + (SPADLET |fullDependList| (UNIONQ |fullDependList| |ids|))) + ((QUOTE T) NIL))))) + (SPADLET |newList| (APPEND |newList| |lastPreds|)) + (SPADLET |newList| (|isDomainSubst| |newList|)) + (SPADLET |answer| + (CONS + (CONS (QUOTE AND) |newList|) + (INTERSECTIONQ |fullDependList| |sig|))))))))) + +;--sayBrightlyNT '"answer=" +;--pp answer +;isDomainSubst u == main where +; main == +; u is [head,:tail] => +; nhead := +; head is ['isDomain,x,y] => ['isDomain,x,fn(y,tail)] +; head +; [nhead,:isDomainSubst rest u] +; u +; fn(x,alist) == +; atom x => +; IDENTP x and MEMQ(x,$PatternVariableList) and (s := findSub(x,alist)) => s +; x +; [CAR x,:[fn(y,alist) for y in CDR x]] +; findSub(x,alist) == +; null alist => nil +; alist is [['isDomain,y,z],:.] and x = y => z +; findSub(x,rest alist) + +(DEFUN |isDomainSubst,findSub| (|x| |alist|) + (PROG (|ISTMP#1| |ISTMP#2| |y| |ISTMP#3| |z|) + (RETURN + (SEQ + (IF (NULL |alist|) (EXIT NIL)) + (IF + (AND + (AND + (PAIRP |alist|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |alist|)) + (AND + (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |y| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND + (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN (SPADLET |z| (QCAR |ISTMP#3|)) (QUOTE T))))))))) + (BOOT-EQUAL |x| |y|)) + (EXIT |z|)) + (EXIT (|isDomainSubst,findSub| |x| (CDR |alist|))))))) + +(DEFUN |isDomainSubst,fn| (|x| |alist|) + (PROG (|s|) + (RETURN + (SEQ + (IF (ATOM |x|) + (EXIT + (SEQ + (IF + (AND + (AND (IDENTP |x|) (MEMQ |x| |$PatternVariableList|)) + (SPADLET |s| (|isDomainSubst,findSub| |x| |alist|))) + (EXIT |s|)) + (EXIT |x|)))) + (EXIT + (CONS + (CAR |x|) + (PROG (#0=#:G166826) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166831 (CDR |x|) (CDR #1#)) (|y| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |y| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT + (SETQ #0# (CONS (|isDomainSubst,fn| |y| |alist|) #0#))))))))))))) + +(DEFUN |isDomainSubst| (|u|) + (PROG (|head| |tail| |ISTMP#1| |x| |ISTMP#2| |y| |nhead|) + (RETURN + (COND + ((AND (PAIRP |u|) + (PROGN + (SPADLET |head| (QCAR |u|)) + (SPADLET |tail| (QCDR |u|)) + (QUOTE T))) + (SPADLET |nhead| + (COND + ((AND + (PAIRP |head|) + (EQ (QCAR |head|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |head|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |x| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (CONS + (QUOTE |isDomain|) + (CONS |x| (CONS (|isDomainSubst,fn| |y| |tail|) NIL)))) + ((QUOTE T) |head|))) + (CONS |nhead| (|isDomainSubst| (CDR |u|)))) + ((QUOTE T) |u|))))) + +;signatureTran pred == +; atom pred => pred +; pred is ['has,D,catForm] and isCategoryForm(catForm,$e) => +; ['ofCategory,D,catForm] +; [signatureTran p for p in pred] + +(DEFUN |signatureTran| (|pred|) + (PROG (|ISTMP#1| D |ISTMP#2| |catForm|) + (RETURN + (SEQ + (COND + ((ATOM |pred|) |pred|) + ((AND + (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |has|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET D (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |catForm| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (|isCategoryForm| |catForm| |$e|)) + (CONS (QUOTE |ofCategory|) (CONS D (CONS |catForm| NIL)))) + ((QUOTE T) + (PROG (#0=#:G166884) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166889 |pred| (CDR #1#)) (|p| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |p| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|signatureTran| |p|) #0#))))))))))))) + +;interactiveModemapForm mm == +; -- create modemap form for use by the interpreter. This function +; -- replaces all specific domains mentioned in the modemap with pattern +; -- variables, and predicates +; mm := replaceVars(COPY mm,$PatternVariableList,$FormalMapVariableList) +; [pattern:=[dc,:sig],pred] := mm +; pred := [fn x for x in pred] where fn x == +; x is [a,b,c] and a ^= 'isFreeFunction and atom c => [a,b,[c]] +; x +;--pp pred +; [mmpat, patternAlist, partial, patvars] := +; modemapPattern(pattern,sig) +;--pp [pattern, mmpat, patternAlist, partial, patvars] +; [pred,domainPredicateList] := +; substVars(pred,patternAlist,patvars) +;--pp [pred,domainPredicateList] +; [pred,:dependList]:= +; fixUpPredicate(pred,domainPredicateList,partial,rest mmpat) +;--pp [pred,dependList] +; [cond, :.] := pred +; [mmpat, cond] + +(DEFUN |interactiveModemapForm,fn| (|x|) + (PROG (|a| |ISTMP#1| |b| |ISTMP#2| |c|) + (RETURN + (SEQ + (IF + (AND + (AND + (AND + (PAIRP |x|) + (PROGN + (SPADLET |a| (QCAR |x|)) + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |b| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |c| (QCAR |ISTMP#2|)) (QUOTE T))))))) + (NEQUAL |a| (QUOTE |isFreeFunction|))) + (ATOM |c|)) + (EXIT (CONS |a| (CONS |b| (CONS (CONS |c| NIL) NIL))))) + (EXIT |x|))))) + +(DEFUN |interactiveModemapForm| (|mm|) + (PROG (|pattern| |dc| |sig| |mmpat| |patternAlist| |partial| |patvars| + |domainPredicateList| |LETTMP#1| |pred| |dependList| |cond|) + (RETURN + (SEQ + (PROGN + (SPADLET |mm| + (|replaceVars| + (COPY |mm|) + |$PatternVariableList| + |$FormalMapVariableList|)) + (SPADLET |pattern| (CAR |mm|)) + (SPADLET |dc| (CAAR |mm|)) + (SPADLET |sig| (CDAR |mm|)) + (SPADLET |pred| (CADR |mm|)) + (SPADLET |pred| + (PROG (#0=#:G166974) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G166979 |pred| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |x| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ + (EXIT (SETQ #0# (CONS (|interactiveModemapForm,fn| |x|) #0#)))))))) + (SPADLET |LETTMP#1| (|modemapPattern| |pattern| |sig|)) + (SPADLET |mmpat| (CAR |LETTMP#1|)) + (SPADLET |patternAlist| (CADR |LETTMP#1|)) + (SPADLET |partial| (CADDR |LETTMP#1|)) + (SPADLET |patvars| (CADDDR |LETTMP#1|)) + (SPADLET |LETTMP#1| (|substVars| |pred| |patternAlist| |patvars|)) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |domainPredicateList| (CADR |LETTMP#1|)) + (SPADLET |LETTMP#1| + (|fixUpPredicate| |pred| |domainPredicateList| |partial| (CDR |mmpat|))) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |dependList| (CDR |LETTMP#1|)) + (SPADLET |cond| (CAR |pred|)) + (CONS |mmpat| (CONS |cond| NIL))))))) + +;modemapPattern(mmPattern,sig) == +; -- Returns a list of the pattern of a modemap, an Alist of the +; -- substitutions made, a boolean flag indicating whether +; -- the result type is partial, and a list of unused pattern variables +; patternAlist := nil +; mmpat := nil +; patvars := $PatternVariableList +; partial := false +; for xTails in tails mmPattern repeat +; x := first xTails +; if x is ['Union,dom,tag] and tag = '"failed" and xTails=sig then +; x := dom +; partial := true +; patvar := RASSOC(x,patternAlist) +; not null patvar => mmpat := [patvar,:mmpat] +; patvar := first patvars +; patvars := rest patvars +; mmpat := [patvar,:mmpat] +; patternAlist := [[patvar,:x],:patternAlist] +; [NREVERSE mmpat,patternAlist,partial,patvars] + +(DEFUN |modemapPattern| (|mmPattern| |sig|) + (PROG (|ISTMP#1| |dom| |ISTMP#2| |tag| |x| |partial| |patvar| + |patvars| |mmpat| |patternAlist|) + (RETURN + (SEQ + (PROGN + (SPADLET |patternAlist| NIL) + (SPADLET |mmpat| NIL) + (SPADLET |patvars| |$PatternVariableList|) + (SPADLET |partial| NIL) + (DO ((|xTails| |mmPattern| (CDR |xTails|))) + ((ATOM |xTails|) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |x| (CAR |xTails|)) + (COND + ((AND + (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE |Union|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN (SPADLET |tag| (QCAR |ISTMP#2|)) (QUOTE T)))))) + (BOOT-EQUAL |tag| (MAKESTRING "failed")) + (BOOT-EQUAL |xTails| |sig|)) + (SPADLET |x| |dom|) (SPADLET |partial| (QUOTE T)))) + (SPADLET |patvar| (|rassoc| |x| |patternAlist|)) + (COND + ((NULL (NULL |patvar|)) + (SPADLET |mmpat| (CONS |patvar| |mmpat|))) + ((QUOTE T) + (SPADLET |patvar| (CAR |patvars|)) + (SPADLET |patvars| (CDR |patvars|)) + (SPADLET |mmpat| (CONS |patvar| |mmpat|)) + (SPADLET |patternAlist| + (CONS (CONS |patvar| |x|) |patternAlist|)))))))) + (CONS + (NREVERSE |mmpat|) + (CONS |patternAlist| (CONS |partial| (CONS |patvars| NIL))))))))) + +;substVars(pred,patternAlist,patternVarList) == +; --make pattern variable substitutions +; domainPredicates := nil +; for [[patVar,:value],:.] in tails patternAlist repeat +; pred := substitute(patVar,value,pred) +; patternAlist := nsubst(patVar,value,patternAlist) +; domainPredicates := substitute(patVar,value,domainPredicates) +; if ^MEMQ(value,$FormalMapVariableList) then +; domainPredicates := [["isDomain",patVar,value],:domainPredicates] +; everything := [pred,patternAlist,domainPredicates] +; for var in $FormalMapVariableList repeat +; CONTAINED(var,everything) => +; replacementVar := first patternVarList +; patternVarList := rest patternVarList +; pred := substitute(replacementVar,var,pred) +; domainPredicates := substitute(replacementVar,var,domainPredicates) +; [pred, domainPredicates] + +(DEFUN |substVars| (|pred| |patternAlist| |patternVarList|) + (PROG (|patVar| |value| |everything| |replacementVar| |domainPredicates|) + (RETURN + (SEQ + (PROGN + (SPADLET |domainPredicates| NIL) + (DO ((#0=#:G167064 |patternAlist| (CDR #0#))) + ((OR (ATOM #0#) (PROGN (PROGN (SPADLET |patVar| (CAAR #0#)) (SPADLET |value| (CDAR #0#)) #0#) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |pred| (MSUBST |patVar| |value| |pred|)) + (SPADLET |patternAlist| (|nsubst| |patVar| |value| |patternAlist|)) + (SPADLET |domainPredicates| + (MSUBST |patVar| |value| |domainPredicates|)) + (COND + ((NULL (MEMQ |value| |$FormalMapVariableList|)) + (SPADLET |domainPredicates| + (CONS + (CONS (QUOTE |isDomain|) (CONS |patVar| (CONS |value| NIL))) + |domainPredicates|))) + ((QUOTE T) NIL)))))) + (SPADLET |everything| + (CONS |pred| (CONS |patternAlist| (CONS |domainPredicates| NIL)))) + (SEQ + (DO ((#1=#:G167089 |$FormalMapVariableList| (CDR #1#)) (|var| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |var| (CAR #1#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((CONTAINED |var| |everything|) + (EXIT + (PROGN + (SPADLET |replacementVar| (CAR |patternVarList|)) + (SPADLET |patternVarList| (CDR |patternVarList|)) + (SPADLET |pred| (MSUBST |replacementVar| |var| |pred|)) + (SPADLET |domainPredicates| + (MSUBST |replacementVar| |var| |domainPredicates|))))))))) + (CONS |pred| (CONS |domainPredicates| NIL)))))))) + +;fixUpPredicate(predClause, domainPreds, partial, sig) == +; -- merge the predicates in predClause and domainPreds into a +; -- single predicate +; [predicate, fn, :skip] := predClause +; if first predicate = "AND" then +; predicates := APPEND(domainPreds,rest predicate) +; else if predicate ^= MKQ "T" +;--was->then predicates:= REVERSE [predicate, :domainPreds] +; then predicates:= [predicate, :domainPreds] +; else predicates := domainPreds or [predicate] +; if #predicates > 1 then +; pred := ["AND",:predicates] +; [pred,:dependList]:=orderPredicateItems(pred,sig,skip) +; else +; pred := orderPredicateItems(first predicates,sig,skip) +; dependList:= if pred is ['isDomain,pvar,[.]] then [pvar] else nil +; pred := moveORsOutside pred +; if partial then pred := ["partial", :pred] +; [[pred, fn, :skip],:dependList] + +(DEFUN |fixUpPredicate| (|predClause| |domainPreds| |partial| |sig|) + (PROG (|predicate| |fn| |skip| |predicates| |LETTMP#1| |ISTMP#1| |pvar| + |ISTMP#2| |ISTMP#3| |dependList| |pred|) + (RETURN + (PROGN + (SPADLET |predicate| (CAR |predClause|)) + (SPADLET |fn| (CADR |predClause|)) + (SPADLET |skip| (CDDR |predClause|)) + (COND + ((BOOT-EQUAL (CAR |predicate|) (QUOTE AND)) + (SPADLET |predicates| (APPEND |domainPreds| (CDR |predicate|)))) + ((NEQUAL |predicate| (MKQ (QUOTE T))) + (SPADLET |predicates| (CONS |predicate| |domainPreds|))) + ((QUOTE T) + (SPADLET |predicates| (OR |domainPreds| (CONS |predicate| NIL))))) + (COND + ((> (|#| |predicates|) 1) + (SPADLET |pred| (CONS (QUOTE AND) |predicates|)) + (SPADLET |LETTMP#1| (|orderPredicateItems| |pred| |sig| |skip|)) + (SPADLET |pred| (CAR |LETTMP#1|)) + (SPADLET |dependList| (CDR |LETTMP#1|)) |LETTMP#1|) + ((QUOTE T) + (SPADLET |pred| (|orderPredicateItems| (CAR |predicates|) |sig| |skip|)) + (SPADLET |dependList| + (COND + ((AND + (PAIRP |pred|) + (EQ (QCAR |pred|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |pred|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |pvar| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND + (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) (EQ (QCDR |ISTMP#3|) NIL)))))))) + (CONS |pvar| NIL)) + ((QUOTE T) NIL))))) + (SPADLET |pred| (|moveORsOutside| |pred|)) + (COND (|partial| (SPADLET |pred| (CONS (QUOTE |partial|) |pred|)))) + (CONS (CONS |pred| (CONS |fn| |skip|)) |dependList|))))) + +;moveORsOutside p == +; p is ['AND,:q] => +; q := [moveORsOutside r for r in q] +; x := or/[r for r in q | r is ['OR,:s]] => +; moveORsOutside(['OR,:[['AND,:SUBST(t,x,q)] for t in CDR x]]) +; ['AND,:q] +; p + +(DEFUN |moveORsOutside| (|p|) + (PROG (|q| |s| |x|) + (RETURN + (SEQ + (COND + ((AND (PAIRP |p|) + (EQ (QCAR |p|) (QUOTE AND)) + (PROGN (SPADLET |q| (QCDR |p|)) (QUOTE T))) + (SPADLET |q| + (PROG (#0=#:G167169) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167174 |q| (CDR #1#)) (|r| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |r| (CAR #1#)) NIL)) (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (|moveORsOutside| |r|) #0#)))))))) + (COND + ((SPADLET |x| + (PROG (#2=#:G167180) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167187 NIL #2#) (#4=#:G167188 |q| (CDR #4#)) (|r| NIL)) + ((OR #3# (ATOM #4#) (PROGN (SETQ |r| (CAR #4#)) NIL)) #2#) + (SEQ + (EXIT + (COND + ((AND + (PAIRP |r|) + (EQ (QCAR |r|) (QUOTE OR)) + (PROGN (SPADLET |s| (QCDR |r|)) (QUOTE T))) + (SETQ #2# (OR #2# |r|)))))))))) + (|moveORsOutside| + (CONS + (QUOTE OR) + (PROG (#5=#:G167199) + (SPADLET #5# NIL) + (RETURN + (DO ((#6=#:G167204 (CDR |x|) (CDR #6#)) (|t| NIL)) + ((OR (ATOM #6#) (PROGN (SETQ |t| (CAR #6#)) NIL)) + (NREVERSE0 #5#)) + (SEQ + (EXIT + (SETQ #5# + (CONS (CONS (QUOTE AND) (MSUBST |t| |x| |q|)) #5#)))))))))) + ((QUOTE T) (CONS (QUOTE AND) |q|)))) + ((QUOTE T) |p|)))))) + +;replaceVars(x,oldvars,newvars) == +; -- replace every identifier in oldvars with the corresponding +; -- identifier in newvars in the expression x +; for old in oldvars for new in newvars repeat +; x := substitute(new,old,x) +; x + +(DEFUN |replaceVars| (|x| |oldvars| |newvars|) + (SEQ + (PROGN + (DO ((#0=#:G167225 |oldvars| (CDR #0#)) + (|old| NIL) + (#1=#:G167226 |newvars| (CDR #1#)) + (|new| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |old| (CAR #0#)) NIL) + (ATOM #1#) + (PROGN (SETQ |new| (CAR #1#)) NIL)) + NIL) + (SEQ (EXIT (SPADLET |x| (MSUBST |new| |old| |x|))))) |x|))) + +;getDomainFromMm mm == +; -- Returns the Domain (or package or category) of origin from a pattern +; -- modemap +; [., cond] := mm +; if cond is ['partial, :c] then cond := c +; condList := +; cond is ['AND, :cl] => cl +; cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info +; [cond] +; val := +; for condition in condList repeat +; condition is ['isDomain, "*1", dom] => return opOf dom +; condition is ['ofCategory, "*1", cat] => return opOf cat +; null val => +; keyedSystemError("S2GE0016", +; ['"getDomainFromMm",'"Can't find domain in modemap condition"]) +; val + +(DEFUN |getDomainFromMm| (|mm|) + (PROG (|c| |cond| |cl| |condList| |dom| |ISTMP#1| |ISTMP#2| |cat| |val|) + (RETURN + (SEQ + (PROGN + (SPADLET |cond| (CADR |mm|)) + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |partial|)) + (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) + |cl|) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE AND)) + (PROGN (SPADLET |cl| (QCDR |ISTMP#2|)) (QUOTE T))))))) + |cl|) + ((QUOTE T) + (CONS |cond| NIL)))) + (SPADLET |val| + (DO ((#0=#:G167289 |condList| (CDR #0#)) (|condition| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |condition| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE *1)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (RETURN (|opOf| |dom|))) + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) (QUOTE |ofCategory|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (EQ (QCAR |ISTMP#1|) (QUOTE *1)) + (PROGN + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |cat| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (RETURN (|opOf| |cat|)))))))) + (COND + ((NULL |val|) + (|keyedSystemError| 'S2GE0016 + (CONS "getDomainFromMm" + (CONS "Can't find domain in modemap condition" NIL)))) + ((QUOTE T) |val|))))))) + +;getFirstArgTypeFromMm mm == +; -- Returns the type of the first argument or nil +; [pats, cond] := mm +; [.,.,:args] := pats +; null args => nil +; arg1 := first args +; if cond is ['partial, :c] then cond := c +; condList := +; cond is ['AND, :cl] => cl +; cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info +; [cond] +; type := nil +; for condition in condList while not type repeat +; if condition is ['isDomain, a1, dom] and a1=arg1 then type := dom +; type + +(DEFUN |getFirstArgTypeFromMm| (|mm|) + (PROG (|pats| |args| |arg1| |c| |cond| |cl| |condList| |ISTMP#1| |a1| + |ISTMP#2| |dom| |type|) + (RETURN + (SEQ + (PROGN + (SPADLET |pats| (CAR |mm|)) + (SPADLET |cond| (CADR |mm|)) + (SPADLET |args| (CDDR |pats|)) + (COND + ((NULL |args|) NIL) + ((QUOTE T) + (SPADLET |arg1| (CAR |args|)) + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |partial|)) + (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) + |cl|) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE AND)) + (PROGN + (SPADLET |cl| (QCDR |ISTMP#2|)) + (QUOTE T))))))) + |cl|) + ((QUOTE T) + (CONS |cond| NIL)))) + (SPADLET |type| NIL) + (DO ((#0=#:G167357 |condList| (CDR #0#)) (|condition| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |condition| (CAR #0#)) NIL) + (NULL (NULL |type|))) + NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) (QUOTE |isDomain|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |condition|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a1| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCDR |ISTMP#2|) NIL) + (PROGN + (SPADLET |dom| (QCAR |ISTMP#2|)) + (QUOTE T)))))) + (BOOT-EQUAL |a1| |arg1|)) + (SPADLET |type| |dom|)) + ((QUOTE T) NIL))))) + |type|))))))) + +;isFreeFunctionFromMm mm == +; -- This returns true is the modemap represents a free function, ie, +; -- one not coming from a domain or category. +; [., cond] := mm +; isFreeFunctionFromMmCond cond + +(DEFUN |isFreeFunctionFromMm| (|mm|) + (PROG (|cond|) + (RETURN + (PROGN + (SPADLET |cond| (CADR |mm|)) + (|isFreeFunctionFromMmCond| |cond|))))) + +;isFreeFunctionFromMmCond cond == +; -- This returns true is the modemap represents a free function, ie, +; -- one not coming from a domain or category. +; if cond is ['partial, :c] then cond := c +; condList := +; cond is ['AND, :cl] => cl +; cond is ['OR, ['AND, :cl],:.] => cl --all cl's should give same info +; [cond] +; iff := false +; for condition in condList while not iff repeat +; if condition is ['isFreeFunction, :.] then iff := true +; iff + +(DEFUN |isFreeFunctionFromMmCond| (|cond|) + (PROG (|c| |ISTMP#1| |ISTMP#2| |cl| |condList| |iff|) + (RETURN + (SEQ + (PROGN + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE |partial|)) + (PROGN (SPADLET |c| (QCDR |cond|)) (QUOTE T))) + (SPADLET |cond| |c|))) + (SPADLET |condList| + (COND + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE AND)) + (PROGN (SPADLET |cl| (QCDR |cond|)) (QUOTE T))) + |cl|) + ((AND (PAIRP |cond|) + (EQ (QCAR |cond|) (QUOTE OR)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |cond|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (EQ (QCAR |ISTMP#2|) (QUOTE AND)) + (PROGN (SPADLET |cl| (QCDR |ISTMP#2|)) (QUOTE T))))))) + |cl|) + ((QUOTE T) (CONS |cond| NIL)))) + (SPADLET |iff| NIL) + (DO ((#0=#:G167407 |condList| (CDR #0#)) (|condition| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |condition| (CAR #0#)) NIL) + (NULL (NULL |iff|))) + NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |condition|) + (EQ (QCAR |condition|) (QUOTE |isFreeFunction|))) + (SPADLET |iff| (QUOTE T))) + ((QUOTE T) NIL))))) + |iff|))))) + +;getAllModemapsFromDatabase(op,nargs) == +; $getUnexposedOperations: local := true +; startTimingProcess 'diskread +; ans := getSystemModemaps(op,nargs) +; stopTimingProcess 'diskread +; ans + +(DEFUN |getAllModemapsFromDatabase| (|op| |nargs|) + (PROG (|$getUnexposedOperations| |ans|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (PROGN + (SPADLET |$getUnexposedOperations| (QUOTE T)) + (|startTimingProcess| (QUOTE |diskread|)) + (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) + (|stopTimingProcess| (QUOTE |diskread|)) + |ans|)))) + +;getModemapsFromDatabase(op,nargs) == +; $getUnexposedOperations: local := false +; startTimingProcess 'diskread +; ans := getSystemModemaps(op,nargs) +; stopTimingProcess 'diskread +; ans + +(DEFUN |getModemapsFromDatabase| (|op| |nargs|) + (PROG (|$getUnexposedOperations| |ans|) + (DECLARE (SPECIAL |$getUnexposedOperations|)) + (RETURN + (PROGN + (SPADLET |$getUnexposedOperations| NIL) + (|startTimingProcess| (QUOTE |diskread|)) + (SPADLET |ans| (|getSystemModemaps| |op| |nargs|)) + (|stopTimingProcess| (QUOTE |diskread|)) + |ans|)))) + +;getSystemModemaps(op,nargs) == +; mml:= GETDATABASE(op,'OPERATION) => +; mms := NIL +; for (x := [[.,:sig],.]) in mml repeat +; (NUMBERP nargs) and (nargs ^= #QCDR sig) => 'iterate +; $getUnexposedOperations or isFreeFunctionFromMm(x) or +; isExposedConstructor(getDomainFromMm(x)) => mms := [x,:mms] +; 'iterate +; mms +; nil + +(DEFUN |getSystemModemaps| (|op| |nargs|) + (PROG (|mml| |sig| |mms|) + (RETURN + (SEQ + (COND + ((SPADLET |mml| (GETDATABASE |op| (QUOTE OPERATION))) + (SPADLET |mms| NIL) + (DO ((#0=#:G167451 |mml| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |x| (CAR #0#)) NIL) + (PROGN (PROGN (SPADLET |sig| (CDAR |x|)) |x|) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (NUMBERP |nargs|) (NEQUAL |nargs| (|#| (QCDR |sig|)))) + (QUOTE |iterate|)) + ((OR |$getUnexposedOperations| + (|isFreeFunctionFromMm| |x|) + (|isExposedConstructor| (|getDomainFromMm| |x|))) + (SPADLET |mms| (CONS |x| |mms|))) + ((QUOTE T) (QUOTE |iterate|)))))) + |mms|) + ((QUOTE T) NIL)))))) + +;getInCoreModemaps(modemapList,op,nargs) == +; mml:= LASSOC (op,modemapList) => +; mml:= CAR mml +; [x for (x:= [[dc,:sig],.]) in mml | +; (NUMBERP nargs => nargs=#rest sig; true) and +; (cfn := abbreviate (domName := getDomainFromMm x)) and +; ($getUnexposedOperations or isExposedConstructor(domName))] +; nil + +(DEFUN |getInCoreModemaps| (|modemapList| |op| |nargs|) + (PROG (|mml| |dc| |sig| |domName| |cfn|) + (RETURN + (SEQ + (COND + ((SPADLET |mml| (LASSOC |op| |modemapList|)) + (SPADLET |mml| (CAR |mml|)) + (PROG (#0=#:G167477) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167484 |mml| (CDR #1#)) (|x| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |x| (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |dc| (CAAR |x|)) + (SPADLET |sig| (CDAR |x|)) + |x|) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((AND + (COND + ((NUMBERP |nargs|) (BOOT-EQUAL |nargs| (|#| (CDR |sig|)))) + ((QUOTE T) (QUOTE T))) + (SPADLET |cfn| + (|abbreviate| (SPADLET |domName| (|getDomainFromMm| |x|)))) + (OR + |$getUnexposedOperations| + (|isExposedConstructor| |domName|))) + (SETQ #0# (CONS |x| #0#)))))))))) + ((QUOTE T) NIL)))))) + +;mkAlistOfExplicitCategoryOps target == +; if target is ['add,a,:l] then +; target:=a +; target is ['Join,:l] => +; "UNION"/[mkAlistOfExplicitCategoryOps cat for cat in l] +; target is ['CATEGORY,.,:l] => +; l:= flattenSignatureList ['PROGN,:l] +; u:= +; [[atomizeOp op,:sig] for x in l | x is ['SIGNATURE,op,sig,:.]] +; where +; atomizeOp op == +; atom op => op +; op is [a] => a +; keyedSystemError("S2GE0016", +; ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) +; opList:= REMDUP ASSOCLEFT u +; [[x,:fn(x,u)] for x in opList] where +; fn(op,u) == +; u is [[a,:b],:c] => (a=op => [b,:fn(op,c)]; fn(op,c)) +; isCategoryForm(target,$e) => nil +; keyedSystemError("S2GE0016", +; ['"mkAlistOfExplicitCategoryOps",'"bad signature"]) + +(DEFUN |mkAlistOfExplicitCategoryOps,atomizeOp| (|op|) + (PROG (|a|) + (RETURN + (SEQ + (IF (ATOM |op|) (EXIT |op|)) + (IF + (AND (PAIRP |op|) + (EQ (QCDR |op|) NIL) + (PROGN (SPADLET |a| (QCAR |op|)) (QUOTE T))) + (EXIT |a|)) + (EXIT + (|keyedSystemError| 'S2GE0016 + (CONS "mkAlistOfExplicitCategoryOps" (CONS "bad signature" NIL)))))))) + +(DEFUN |mkAlistOfExplicitCategoryOps,fn| (|op| |u|) + (PROG (|ISTMP#1| |a| |b| |c|) + (RETURN + (SEQ + (IF + (AND + (PAIRP |u|) + (PROGN + (SPADLET |ISTMP#1| (QCAR |u|)) + (AND + (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |b| (QCDR |ISTMP#1|)) + (QUOTE T)))) + (PROGN (SPADLET |c| (QCDR |u|)) (QUOTE T))) + (EXIT + (SEQ + (IF (BOOT-EQUAL |a| |op|) + (EXIT (CONS |b| (|mkAlistOfExplicitCategoryOps,fn| |op| |c|)))) + (EXIT (|mkAlistOfExplicitCategoryOps,fn| |op| |c|))))))))) + +(DEFUN |mkAlistOfExplicitCategoryOps| (|target|) + (PROG (|a| |l| |ISTMP#1| |op| |ISTMP#2| |sig| |u| |opList|) + (RETURN + (SEQ + (PROGN + (COND + ((AND (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |add|)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |a| (QCAR |ISTMP#1|)) + (SPADLET |l| (QCDR |ISTMP#1|)) + (QUOTE T))))) + (SPADLET |target| |a|))) + (COND + ((AND (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE |Join|)) + (PROGN (SPADLET |l| (QCDR |target|)) (QUOTE T))) + (PROG (#0=#:G167561) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167566 |l| (CDR #1#)) (|cat| NIL)) + ((OR (ATOM #1#) (PROGN (SETQ |cat| (CAR #1#)) NIL)) #0#) + (SEQ + (EXIT + (SETQ #0# + (|union| #0# (|mkAlistOfExplicitCategoryOps| |cat|))))))))) + ((AND (PAIRP |target|) + (EQ (QCAR |target|) (QUOTE CATEGORY)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |target|)) + (AND (PAIRP |ISTMP#1|) + (PROGN (SPADLET |l| (QCDR |ISTMP#1|)) (QUOTE T))))) + (SPADLET |l| (|flattenSignatureList| (CONS (QUOTE PROGN) |l|))) + (SPADLET |u| + (PROG (#2=#:G167577) + (SPADLET #2# NIL) + (RETURN + (DO ((#3=#:G167583 |l| (CDR #3#)) (|x| NIL)) + ((OR (ATOM #3#) + (PROGN (SETQ |x| (CAR #3#)) NIL)) + (NREVERSE0 #2#)) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE SIGNATURE)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |op| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |sig| (QCAR |ISTMP#2|)) + (QUOTE T))))))) + (SETQ #2# + (CONS + (CONS (|mkAlistOfExplicitCategoryOps,atomizeOp| |op|) |sig|) + #2#)))))))))) + (SPADLET |opList| (REMDUP (ASSOCLEFT |u|))) + (PROG (#4=#:G167593) + (SPADLET #4# NIL) + (RETURN + (DO ((#5=#:G167598 |opList| (CDR #5#)) (|x| NIL)) + ((OR (ATOM #5#) (PROGN (SETQ |x| (CAR #5#)) NIL)) (NREVERSE0 #4#)) + (SEQ + (EXIT + (SETQ #4# + (CONS + (CONS |x| (|mkAlistOfExplicitCategoryOps,fn| |x| |u|)) + #4#)))))))) + ((|isCategoryForm| |target| |$e|) NIL) + ((QUOTE T) + (|keyedSystemError| 'S2GE0016 + (CONS + "mkAlistOfExplicitCategoryOps" + (CONS "bad signature" NIL)))))))))) + +;flattenSignatureList(x) == +; atom x => nil +; x is ['SIGNATURE,:.] => [x] +; x is ['IF,cond,b1,b2] => +; append(flattenSignatureList b1, flattenSignatureList b2) +; x is ['PROGN,:l] => +; ll:= [] +; for x in l repeat +; x is ['SIGNATURE,:.] => ll:=cons(x,ll) +; ll:= append(flattenSignatureList x,ll) +; ll +; nil + +(DEFUN |flattenSignatureList| (|x|) + (PROG (|ISTMP#1| |cond| |ISTMP#2| |b1| |ISTMP#3| |b2| |l| |ll|) + (RETURN + (SEQ + (COND + ((ATOM |x|) NIL) + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE SIGNATURE))) (CONS |x| NIL)) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE IF)) + (PROGN + (SPADLET |ISTMP#1| (QCDR |x|)) + (AND (PAIRP |ISTMP#1|) + (PROGN + (SPADLET |cond| (QCAR |ISTMP#1|)) + (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) + (AND (PAIRP |ISTMP#2|) + (PROGN + (SPADLET |b1| (QCAR |ISTMP#2|)) + (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) + (AND (PAIRP |ISTMP#3|) + (EQ (QCDR |ISTMP#3|) NIL) + (PROGN + (SPADLET |b2| (QCAR |ISTMP#3|)) + (QUOTE T))))))))) + (APPEND (|flattenSignatureList| |b1|) (|flattenSignatureList| |b2|))) + ((AND (PAIRP |x|) + (EQ (QCAR |x|) (QUOTE PROGN)) + (PROGN (SPADLET |l| (QCDR |x|)) (QUOTE T))) + (SPADLET |ll| NIL) + (DO ((#0=#:G167664 |l| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((AND (PAIRP |x|) (EQ (QCAR |x|) (QUOTE SIGNATURE))) + (SPADLET |ll| (CONS |x| |ll|))) + ((QUOTE T) + (SPADLET |ll| (APPEND (|flattenSignatureList| |x|) |ll|))))))) + |ll|) + ((QUOTE T) NIL)))))) + +;mkDatabasePred [a,t] == +; isCategoryForm(t,$e) => ['ofCategory,a,t] +; ['ofType,a,t] + +(DEFUN |mkDatabasePred| (#0=#:G167684) + (PROG (|a| |t|) + (RETURN + (PROGN + (SPADLET |a| (CAR #0#)) + (SPADLET |t| (CADR #0#)) + (COND + ((|isCategoryForm| |t| |$e|) + (CONS (QUOTE |ofCategory|) (CONS |a| (CONS |t| NIL)))) + ((QUOTE T) + (CONS (QUOTE |ofType|) (CONS |a| (CONS |t| NIL))))))))) + +;formal2Pattern x == +; SUBLIS(pairList($FormalMapVariableList,rest $PatternVariableList),x) + +(DEFUN |formal2Pattern| (|x|) + (SUBLIS + (|pairList| |$FormalMapVariableList| (CDR |$PatternVariableList|)) + |x|)) + +;updateDatabase(fname,cname,systemdir?) == +; -- for now in NRUNTIME do database update only if forced +; not $forceDatabaseUpdate => nil +; $newcompMode = 'true => nil +; -- these modemaps are never needed in the old scheme +; if oldFname := constructor? cname then +; clearClams() +; clearAllSlams [] +; if GET(cname, 'LOADED) then +; clearConstructorCaches() +; if $forceDatabaseUpdate or not systemdir? then +; clearClams() +; clearAllSlams [] + +(DEFUN |updateDatabase| (|fname| |cname| |systemdir?|) + (PROG (|oldFname|) + (RETURN + (COND + ((NULL |$forceDatabaseUpdate|) NIL) + ((BOOT-EQUAL |$newcompMode| (QUOTE |true|)) NIL) + ((QUOTE T) + (COND + ((SPADLET |oldFname| (|constructor?| |cname|)) + (|clearClams|) + (|clearAllSlams| NIL) + (COND + ((GETL |cname| (QUOTE LOADED)) (|clearConstructorCaches|)) + ((QUOTE T) NIL)))) + (COND + ((OR |$forceDatabaseUpdate| (NULL |systemdir?|)) + (|clearClams|) + (|clearAllSlams| NIL)) + ((QUOTE T) NIL))))))) + +;removeCoreModemaps(modemapList,c) == +; newUserModemaps:= nil +; c := opOf unabbrev c +; for [op,mmList] in modemapList repeat +; temp:= nil +; for mm in mmList repeat +; cname := getDomainFromMm mm +; if cname ^= c then temp:= [:temp,mm] +; if temp then newUserModemaps:= [:newUserModemaps,[op,temp]] +; newUserModemaps + +(DEFUN |removeCoreModemaps| (|modemapList| |c|) + (PROG (|op| |mmList| |cname| |temp| |newUserModemaps|) + (RETURN + (SEQ + (PROGN + (SPADLET |newUserModemaps| NIL) + (SPADLET |c| (|opOf| (|unabbrev| |c|))) + (DO ((#0=#:G167724 |modemapList| (CDR #0#)) (#1=#:G167710 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR #1#)) + (SPADLET |mmList| (CADR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |temp| NIL) + (DO ((#2=#:G167736 |mmList| (CDR #2#)) (|mm| NIL)) + ((OR (ATOM #2#) (PROGN (SETQ |mm| (CAR #2#)) NIL)) NIL) + (SEQ + (EXIT + (PROGN + (SPADLET |cname| (|getDomainFromMm| |mm|)) + (COND + ((NEQUAL |cname| |c|) + (SPADLET |temp| (APPEND |temp| (CONS |mm| NIL)))) + ((QUOTE T) NIL)))))) + (COND + (|temp| + (SPADLET |newUserModemaps| + (APPEND |newUserModemaps| + (CONS (CONS |op| (CONS |temp| NIL)) NIL)))) + ((QUOTE T) NIL)))))) + |newUserModemaps|))))) + +;addCoreModemap(modemapList,op,modemap,cname) == +; entry:= ASSQ(op,modemapList) => +; RPLAC(CADR entry,[modemap,:CADR entry]) +; modemapList +; modeMapList:= [:modemapList,[op,[ modemap]]] + +(DEFUN |addCoreModemap| (|modemapList| |op| |modemap| |cname|) + (PROG (|entry| |modeMapList|) + (RETURN + (COND + ((SPADLET |entry| (ASSQ |op| |modemapList|)) + (RPLAC (CADR |entry|) (CONS |modemap| (CADR |entry|))) |modemapList|) + ((QUOTE T) + (SPADLET |modeMapList| + (APPEND |modemapList| + (CONS (CONS |op| (CONS (CONS |modemap| NIL) NIL)) NIL)))))))) + +;REMOVER(lst,item) == +; --destructively removes item from lst +; not PAIRP lst => +; lst=item => nil +; lst +; first lst=item => rest lst +; RPLNODE(lst,REMOVER(first lst,item),REMOVER(rest lst,item)) + +(DEFUN REMOVER (|lst| |item|) + (COND + ((NULL (PAIRP |lst|)) + (COND ((BOOT-EQUAL |lst| |item|) NIL) ((QUOTE T) |lst|))) + ((BOOT-EQUAL (CAR |lst|) |item|) (CDR |lst|)) + ((QUOTE T) + (RPLNODE |lst| + (REMOVER (CAR |lst|) |item|) + (REMOVER (CDR |lst|) |item|))))) + +;allLASSOCs(op,alist) == +; [value for [key,:value] in alist | key = op] + +(DEFUN |allLASSOCs| (|op| |alist|) + (PROG (|key| |value|) + (RETURN + (SEQ + (PROG (#0=#:G167775) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167782 |alist| (CDR #1#)) (#2=#:G167765 NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ #2# (CAR #1#)) NIL) + (PROGN + (PROGN + (SPADLET |key| (CAR #2#)) + (SPADLET |value| (CDR #2#)) + #2#) + NIL)) + (NREVERSE0 #0#)) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |key| |op|) (SETQ #0# (CONS |value| #0#))))))))))))) + +;loadDependents fn == +; isExistingFile [fn,$spadLibFT,"*"] => +; MEMQ("dependents",RKEYIDS(fn,$spadLibFT)) => +; stream:= readLib1(fn,$spadLibFT,"*") +; l:= rread('dependents,stream,nil) +; RSHUT stream +; for x in l repeat +; x='SubDomain => nil +; loadIfNecessary x + +(DEFUN |loadDependents| (|fn|) + (PROG (|stream| |l|) + (RETURN + (SEQ + (COND + ((|isExistingFile| (CONS |fn| (CONS |$spadLibFT| (CONS (QUOTE *) NIL)))) + (EXIT + (COND + ((MEMQ (QUOTE |dependents|) (RKEYIDS |fn| |$spadLibFT|)) + (EXIT + (PROGN + (SPADLET |stream| (|readLib1| |fn| |$spadLibFT| (QUOTE *))) + (SPADLET |l| (|rread| (QUOTE |dependents|) |stream| NIL)) + (RSHUT |stream|) + (DO ((#0=#:G167800 |l| (CDR #0#)) (|x| NIL)) + ((OR (ATOM #0#) (PROGN (SETQ |x| (CAR #0#)) NIL)) NIL) + (SEQ + (EXIT + (COND + ((BOOT-EQUAL |x| (QUOTE |SubDomain|)) NIL) + ((QUOTE T) (|loadIfNecessary| |x|))))))))))))))))) + +;--% Miscellaneous Stuff +;getOplistForConstructorForm (form := [op,:argl]) == +; -- The new form is an op-Alist which has entries ( . signature-Alist) +; -- where signature-Alist has entries ( . item) +; -- where item has form ( ) +; -- where = ELT | CONST | Subsumed | (XLAM..) .. +; pairlis:= [[fv,:arg] for fv in $FormalMapVariableList for arg in argl] +; opAlist := getOperationAlistFromLisplib op +; [:getOplistWithUniqueSignatures(op,pairlis,signatureAlist) +; for [op,:signatureAlist] in opAlist] + +(DEFUN |getOplistForConstructorForm| (|form|) + (PROG (|argl| |pairlis| |opAlist| |op| |signatureAlist|) + (RETURN + (SEQ + (PROGN + (SPADLET |op| (CAR |form|)) + (SPADLET |argl| (CDR |form|)) + (SPADLET |pairlis| + (PROG (#0=#:G167832) + (SPADLET #0# NIL) + (RETURN + (DO ((#1=#:G167838 |$FormalMapVariableList| (CDR #1#)) + (|fv| NIL) + (#2=#:G167839 |argl| (CDR #2#)) + (|arg| NIL)) + ((OR (ATOM #1#) + (PROGN (SETQ |fv| (CAR #1#)) NIL) + (ATOM #2#) + (PROGN (SETQ |arg| (CAR #2#)) NIL)) + (NREVERSE0 #0#)) + (SEQ (EXIT (SETQ #0# (CONS (CONS |fv| |arg|) #0#)))))))) + (SPADLET |opAlist| (|getOperationAlistFromLisplib| |op|)) + (PROG (#3=#:G167848) + (SPADLET #3# NIL) + (RETURN + (DO ((#4=#:G167854 |opAlist| (CDR #4#)) (#5=#:G167811 NIL)) + ((OR (ATOM #4#) + (PROGN (SETQ #5# (CAR #4#)) NIL) + (PROGN + (PROGN + (SPADLET |op| (CAR #5#)) + (SPADLET |signatureAlist| (CDR #5#)) + #5#) + NIL)) + #3#) + (SEQ + (EXIT + (SETQ #3# + (APPEND #3# + (|getOplistWithUniqueSignatures| + |op| + |pairlis| + |signatureAlist|))))))))))))) + +;getOplistWithUniqueSignatures(op,pairlis,signatureAlist) == +; alist:= nil +; for [sig,:[slotNumber,pred,kind]] in signatureAlist | kind ^= 'Subsumed repeat +; alist:= insertAlist(SUBLIS(pairlis,[op,sig]), +; SUBLIS(pairlis,[pred,[kind,nil,slotNumber]]), +; alist) +; alist + +(DEFUN |getOplistWithUniqueSignatures| (|op| |pairlis| |signatureAlist|) + (PROG (|sig| |slotNumber| |pred| |kind| |alist|) + (RETURN + (SEQ + (PROGN + (SPADLET |alist| NIL) + (DO ((#0=#:G167884 |signatureAlist| (CDR #0#)) (#1=#:G167872 NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ #1# (CAR #0#)) NIL) + (PROGN + (PROGN + (SPADLET |sig| (CAR #1#)) + (SPADLET |slotNumber| (CADR #1#)) + (SPADLET |pred| (CADDR #1#)) + (SPADLET |kind| (CADDDR #1#)) + #1#) + NIL)) + NIL) + (SEQ + (EXIT + (COND + ((NEQUAL |kind| (QUOTE |Subsumed|)) + (SPADLET |alist| + (|insertAlist| + (SUBLIS |pairlis| (CONS |op| (CONS |sig| NIL))) + (SUBLIS |pairlis| + (CONS + |pred| + (CONS (CONS |kind| (CONS NIL (CONS |slotNumber| NIL))) NIL))) + |alist|))))))) + |alist|))))) + +;--% Code For Modemap Insertion +;insertModemap(new,mmList) == +; null mmList => [new] +;--isMoreSpecific(new,old:= first mmList) => [new,:mmList] +;--[old,:insertModemap(new,rest mmList)] +; [new,:mmList] + +(DEFUN |insertModemap| (|new| |mmList|) + (COND + ((NULL |mmList|) (CONS |new| NIL)) + ((QUOTE T) (CONS |new| |mmList|)))) + +;--% Exposure Group Code +;dropPrefix(fn) == +; MEMBER(fn.0,[char "?",char "-",char "+"]) => SUBSTRING(fn,1,nil) +; fn + +(DEFUN |dropPrefix| (|fn|) + (COND + ((|member| + (ELT |fn| 0) + (CONS + (|char| (QUOTE ?)) + (CONS + (|char| (QUOTE -)) + (CONS + (|char| (QUOTE +)) + NIL)))) + (SUBSTRING |fn| 1 NIL)) + ((QUOTE T) |fn|))) + +;isExposedConstructor name == +; -- this function checks the local exposure data in the frame to +; -- see if the given constructor is exposed. The format of +; -- $localExposureData is a vector with +; -- slot 0: list of groups exposed in the frame +; -- slot 1: list of constructors explicitly exposed +; -- slot 2: list of constructors explicitly hidden +; -- check if it is explicitly hidden +; MEMQ(name,'(Union Record Mapping)) => true +; MEMQ(name,$localExposureData.2) => false +; -- check if it is explicitly exposed +; MEMQ(name,$localExposureData.1) => true +; -- check if it is in an exposed group +; found := NIL +; for g in $localExposureData.0 while not found repeat +; null (x := GETALIST($globalExposureGroupAlist,g)) => 'iterate +; if GETALIST(x,name) then found := true +; found + +(DEFUN |isExposedConstructor| (|name|) + (PROG (|x| |found|) + (RETURN + (SEQ + (COND + ((MEMQ |name| (QUOTE (|Union| |Record| |Mapping|))) (QUOTE T)) + ((MEMQ |name| (ELT |$localExposureData| 2)) NIL) + ((MEMQ |name| (ELT |$localExposureData| 1)) (QUOTE T)) + ((QUOTE T) + (SPADLET |found| NIL) + (DO ((#0=#:G167914 (ELT |$localExposureData| 0) (CDR #0#)) (|g| NIL)) + ((OR (ATOM #0#) + (PROGN (SETQ |g| (CAR #0#)) NIL) + (NULL (NULL |found|))) + NIL) + (SEQ + (EXIT + (COND + ((NULL (SPADLET |x| (GETALIST |$globalExposureGroupAlist| |g|))) + (QUOTE |iterate|)) + ((GETALIST |x| |name|) + (SPADLET |found| (QUOTE T))) ((QUOTE T) NIL))))) + |found|)))))) + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document}