From ab8cc85adde879fb963c94d15675783f2cf4b183 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 14 Aug 2007 05:14:52 +0000 Subject: Initial population. --- src/interp/lisplib.boot.pamphlet | 712 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 712 insertions(+) create mode 100644 src/interp/lisplib.boot.pamphlet (limited to 'src/interp/lisplib.boot.pamphlet') diff --git a/src/interp/lisplib.boot.pamphlet b/src/interp/lisplib.boot.pamphlet new file mode 100644 index 00000000..bffb777e --- /dev/null +++ b/src/interp/lisplib.boot.pamphlet @@ -0,0 +1,712 @@ +\documentclass{article} +\usepackage{axiom} + +\title{\File{src/interp/lisplib.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\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. + +@ +<<*>>= +<> + +--% Standard Library Creation Functions + +readLib(fn,ft) == readLib1(fn,ft,"*") + +readLib1(fn,ft,fm) == + -- see if it exists first + p := pathname [fn,ft,fm] + readLibPathFast p + +readLibPathFast p == + -- assumes 1) p is a valid pathname + -- 2) file has already been checked for existence + RDEFIOSTREAM([['FILE,:p], '(MODE . INPUT)],false) + +writeLib(fn,ft) == writeLib1(fn,ft,"*") + +writeLib1(fn,ft,fm) == RDEFIOSTREAM [['FILE,fn,ft,fm],'(MODE . OUTPUT)] + +putFileProperty(fn,ft,id,val) == + fnStream:= writeLib1(fn,ft,"*") + val:= rwrite( id,val,fnStream) + RSHUT fnStream + val + +lisplibWrite(prop,val,filename) == + -- this may someday not write NIL keys, but it will now + if $LISPLIB then + rwrite128(prop,val,filename) + +rwrite128(key,value,stream) == + rwrite(key,value,stream) + +evalAndRwriteLispForm(key,form) == + eval form + rwriteLispForm(key,form) + +rwriteLispForm(key,form) == + if $LISPLIB then + rwrite( key,form,$libFile) + LAM_,FILEACTQ(key,form) + +getLisplib(name,id) == + -- this version does cache the returned value + getFileProperty(name,$spadLibFT,id,true) + +getLisplibNoCache(name,id) == + -- this version does not cache the returned value + getFileProperty(name,$spadLibFT,id,false) + +getFileProperty(fn,ft,id,cache) == + fn in '(DOMAIN SUBDOM MODE) => nil + p := pathname [fn,ft,'"*"] + cache => hasFileProperty(p,id,fn) + hasFilePropertyNoCache(p,id,fn) + +hasFilePropertyNoCache(p,id,abbrev) == + -- it is assumed that the file exists and is a proper pathname + -- startTimingProcess 'diskread + fnStream:= readLibPathFast p + NULL fnStream => NIL + -- str:= object2String id + val:= rread(id,fnStream, nil) + RSHUT fnStream + -- stopTimingProcess 'diskread + val + +--% Uninstantiating + +unInstantiate(clist) == + for c in clist repeat + clearConstructorCache(c) + killNestedInstantiations(clist) + +killNestedInstantiations(deps) == + for key in HKEYS($ConstructorCache) + repeat + for [arg,count,:inst] in HGET($ConstructorCache,key) repeat + isNestedInstantiation(inst.0,deps) => + HREMPROP($ConstructorCache,key,arg) + +isNestedInstantiation(form,deps) == + form is [op,:argl] => + op in deps => true + or/[isNestedInstantiation(x,deps) for x in argl] + false + +--% Loading + +loadLibIfNotLoaded libName == + -- replaces old SpadCondLoad + -- loads is library is not already loaded + $PrintOnly = 'T => NIL + GETL(libName,'LOADED) => NIL + loadLib libName + +loadLib cname == + startTimingProcess 'load + fullLibName := GETDATABASE(cname,'OBJECT) or return nil + systemdir? := isSystemDirectory(pathnameDirectory fullLibName) + update? := $forceDatabaseUpdate or not systemdir? + not update? => + loadLibNoUpdate(cname, cname, fullLibName) + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + LOAD(fullLibName) + clearConstructorCache cname + updateDatabase(cname,cname,systemdir?) + installConstructor(cname,kind) + u := GETDATABASE(cname, 'CONSTRUCTORMODEMAP) + updateCategoryTable(cname,kind) + coSig := + u => + [[.,:sig],:.] := u + CONS(NIL,[categoryForm?(x) for x in CDR sig]) + NIL + -- in following, add property value false or NIL to possibly clear + -- old value + if null CDR GETDATABASE(cname,'CONSTRUCTORFORM) then + MAKEPROP(cname,'NILADIC,'T) + else + REMPROP(cname,'NILADIC) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadLibNoUpdate(cname, libName, fullLibName) == + kind := GETDATABASE(cname,'CONSTRUCTORKIND) + if $printLoadMsgs then + sayKeyedMsg("S2IL0002",[namestring fullLibName,kind,cname]) + if CATCH('VERSIONCHECK,LOAD(fullLibName)) = -1 + then + PRINC('" wrong library version...recompile ") + PRINC(fullLibName) + TERPRI() + TOPLEVEL() + else + clearConstructorCache cname + installConstructor(cname,kind) + MAKEPROP(cname,'LOADED,fullLibName) + if $InteractiveMode then $CategoryFrame := [[nil]] + stopTimingProcess 'load + 'T + +loadIfNecessary u == loadLibIfNecessary(u,true) + +loadIfNecessaryAndExists u == loadLibIfNecessary(u,nil) + +loadLibIfNecessary(u,mustExist) == + u = '$EmptyMode => u + null atom u => loadLibIfNecessary(first u,mustExist) + value:= + functionp(u) or macrop(u) => u + GETL(u,'LOADED) => u + loadLib u => u + null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) + or (null LASSOC('isFunctor,y)) and (null LASSOC('isCategory,y))) => + y:= GETDATABASE(u,'CONSTRUCTORKIND) => + y = 'category => + updateCategoryFrameForCategory u + updateCategoryFrameForConstructor u + throwKeyedMsg("S2IL0005",[u]) + value + +convertOpAlist2compilerInfo(opalist) == + "append"/[[formatSig(op,sig) for sig in siglist] + for [op,:siglist] in opalist] where + formatSig(op, [typelist, slot,:stuff]) == + pred := if stuff then first stuff else 'T + impl := if CDR stuff then CADR stuff else 'ELT -- handles 'CONST + [[op, typelist], pred, [impl, '$, slot]] + +updateCategoryFrameForConstructor(constructor) == + opAlist := GETDATABASE(constructor, 'OPERATIONALIST) + [[dc,:sig],[pred,impl]] := GETDATABASE(constructor, 'CONSTRUCTORMODEMAP) + $CategoryFrame := put(constructor,'isFunctor, + convertOpAlist2compilerInfo(opAlist), + addModemap(constructor, dc, sig, pred, impl, + put(constructor, 'mode, ['Mapping,:sig], $CategoryFrame))) + +updateCategoryFrameForCategory(category) == + [[dc,:sig],[pred,impl]] := GETDATABASE(category, 'CONSTRUCTORMODEMAP) + $CategoryFrame := + put(category, 'isCategory, 'T, + addModemap(category, dc, sig, pred, impl, $CategoryFrame)) + +loadFunctor u == + null atom u => loadFunctor first u + loadLibIfNotLoaded u + u + +makeConstructorsAutoLoad() == + for cnam in allConstructors() repeat + REMPROP(cnam,'LOADED) +-- fn:=GETDATABASE(cnam,'ABBREVIATION) + if GETDATABASE(cnam,'NILADIC) + then PUT(cnam,'NILADIC,'T) + else REMPROP(cnam,'NILADIC) + systemDependentMkAutoload(cnam,cnam) + +systemDependentMkAutoload(fn,cnam) == + FBOUNDP(cnam) => "next" + asharpName := GETDATABASE(cnam, 'ASHARP?) => + kind := GETDATABASE(cnam, 'CONSTRUCTORKIND) + cosig := GETDATABASE(cnam, 'COSIG) + file := GETDATABASE(cnam, 'OBJECT) + SET_-LIB_-FILE_-GETTER(file, cnam) + kind = 'category => + ASHARPMKAUTOLOADCATEGORY(file, cnam, asharpName, cosig) + ASHARPMKAUTOLOADFUNCTOR(file, cnam, asharpName, cosig) + SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam)) + +autoLoad(abb,cname) == + if not GETL(cname,'LOADED) then loadLib cname + SYMBOL_-FUNCTION cname + +setAutoLoadProperty(name) == +-- abb := constructor? name + REMPROP(name,'LOADED) + SETF(SYMBOL_-FUNCTION name,mkAutoLoad(name, name)) + +--% Compilation + +compileConstructorLib(l,op,editFlag,traceFlag) == + --this file corresponds to /C,1 + MEMQ('_?,l) => return editFile '(_/C TELL _*) + optionList:= _/OPTIONS l + funList:= TRUNCLIST(l,optionList) or [_/FN] + options:= [[UPCASE CAR x,:CDR x] for x in optionList] + infile:= _/MKINFILENAM _/GETOPTION(options,'FROM_=) + outfile:= _/MKINFILENAM _/GETOPTION(options,'TO_=) + res:= [compConLib1(fn,infile,outfile,op,editFlag,traceFlag) + for fn in funList] + SHUT INPUTSTREAM + res + +compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == + $PRETTYPRINT: local := 'T + $LISPLIB: local := 'T + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL + $lisplibForm: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: local := NIL + $lisplibKind: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibSlot1 : local := NIL --used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibOpAlist: local:= NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL + $lisplibSignatureAlist: local := NIL + if null atom fun and null CDR fun then fun:= CAR fun -- unwrap nullary + libName:= getConstructorAbbreviation fun + infile:= infileOrNil or getFunctionSourceFile fun or + throwKeyedMsg("S2IL0004",[fun]) + SETQ(_/EDITFILE,infile) + outfile := outfileOrNil or + [libName,'OUTPUT,$listingDirectory] --always QUIET + _$ERASE(libName,'OUTPUT,$listingDirectory) + outstream:= DEFSTREAM(outfile,'OUTPUT) + val:= _/D_,2_,LIB(fun,infile,outstream,auxOp,editFlag,traceFlag) + val + +compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == + --fn= compDefineCategory OR compDefineFunctor + sayMSG fillerSpaces(72,'"-") + $LISPLIB: local := 'T + $op: local := op + $lisplibAttributes: local := NIL + $lisplibPredicates: local := NIL -- set by makePredicateBitVector + $lisplibCategoriesExtended: local := NIL -- this is always nil. why? (tpd) + $lisplibForm: local := NIL + $lisplibKind: local := NIL + $lisplibAbbreviation: local := NIL + $lisplibParents: local := NIL + $lisplibAncestors: local := NIL + $lisplibModemap: local := NIL + $lisplibModemapAlist: local := NIL + $lisplibSlot1 : local := NIL -- used by NRT mechanisms + $lisplibOperationAlist: local := NIL + $lisplibSuperDomain: local := NIL + $libFile: local := NIL + $lisplibVariableAlist: local := NIL +-- $lisplibRelatedDomains: local := NIL --from ++ Related Domains: see c-doc + $lisplibCategory: local := nil + --for categories, is rhs of definition; otherwise, is target of functor + --will eventually become the "constructorCategory" property in lisplib + --set in compDefineCategory1 if category, otherwise in finalizeLisplib + libName := getConstructorAbbreviation op + BOUNDP '$compileDocumentation and $compileDocumentation => + compileDocumentation libName + sayMSG ['" initializing ",$spadLibFT,:bright libName, + '"for",:bright op] + initializeLisplib libName + sayMSG ['" compiling into ",$spadLibFT,:bright libName] + -- res:= FUNCALL(fn,df,m,e,prefix,fal) + -- sayMSG ['" finalizing ",$spadLibFT,:bright libName] + -- finalizeLisplib libName + -- following guarantee's compiler output files get closed. + ok := false; + UNWIND_-PROTECT( + PROGN(res:= FUNCALL(fn,df,m,e,prefix,fal), + sayMSG ['" finalizing ",$spadLibFT,:bright libName], + finalizeLisplib libName, + ok := true), + RSHUT $libFile) + if ok then lisplibDoRename(libName) + filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) + RPACKFILE filearg + FRESH_-LINE $algebraOutputStream + sayMSG fillerSpaces(72,'"-") + unloadOneConstructor(op,libName) + LOCALDATABASE(LIST GETDATABASE(op,'ABBREVIATION),NIL) + $newConlist := [op, :$newConlist] ----------> bound in function "compiler" + if $lisplibKind = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + res + +compileDocumentation libName == + filename := MAKE_-INPUT_-FILENAME(libName,$spadLibFT) + $FCOPY(filename,[libName,'DOCLB]) + stream := RDEFIOSTREAM [['FILE,libName,'DOCLB],['MODE, :'O]] + lisplibWrite('"documentation",finalizeDocumentation(),stream) +-- if $lisplibRelatedDomains then +-- lisplibWrite('"relatedDomains",$lisplibRelatedDomains,stream) + RSHUT(stream) + RPACKFILE([libName,'DOCLB]) + $REPLACE([libName,$spadLibFT],[libName,'DOCLB]) + ['dummy, $EmptyMode, $e] + +getLisplibVersion libName == + stream := RDEFIOSTREAM [['FILE,libName,$spadLibFT],['MODE, :'I]] + version:= CADR rread('VERSION, stream,nil) + RSHUT(stream) + version + +initializeLisplib libName == + _$ERASE(libName,'ERRORLIB,$libraryDirectory) + SETQ(ERRORS,0) -- ERRORS is a fluid variable for the compiler + $libFile:= writeLib1(libName,'ERRORLIB,$libraryDirectory) + ADDOPTIONS('FILE,$libFile) + $lisplibForm := nil --defining form for lisplib + $lisplibModemap := nil --modemap for constructor form + $lisplibKind := nil --category, domain, or package + $lisplibModemapAlist := nil --changed in "augmentLisplibModemapsFromCategory" + $lisplibAbbreviation := nil + $lisplibAncestors := nil + $lisplibOpAlist := nil --operations alist for new runtime system + $lisplibOperationAlist := nil --old list of operations for functor/package + $lisplibSuperDomain:= nil + -- next var changed in "augmentLisplibDependents" + $lisplibVariableAlist := nil --this and the next are used by "luke" + $lisplibSignatureAlist := nil + if pathnameTypeId(_/EDITFILE) = 'SPAD + then LAM_,FILEACTQ('VERSION,['_/VERSIONCHECK,_/MAJOR_-VERSION]) + +finalizeLisplib libName == + lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) + lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) + lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) + $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget + -- set to target of modemap for package/domain constructors; + -- to the right-hand sides (the definition) for category constructors + lisplibWrite('"constructorCategory",$lisplibCategory,$libFile) + lisplibWrite('"sourceFile",namestring _/EDITFILE,$libFile) + lisplibWrite('"modemaps",removeZeroOne $lisplibModemapAlist,$libFile) + opsAndAtts:= getConstructorOpsAndAtts( + $lisplibForm,kind,$lisplibModemap) + lisplibWrite('"operationAlist",removeZeroOne CAR opsAndAtts,$libFile) + --lisplibWrite('"attributes",CDR opsAndAtts,$libFile) + --if kind='category then NRTgenInitialAttributeAlist CDR opsAndAtts + if kind='category then + $pairlis : local := [[a,:v] for a in rest $lisplibForm + for v in $FormalMapVariableList] + $NRTslot1PredicateList : local := [] + NRTgenInitialAttributeAlist CDR opsAndAtts + lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) + lisplibWrite('"signaturesAndLocals", + removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, + $lisplibVariableAlist),$libFile) + lisplibWrite('"attributes",removeZeroOne $lisplibAttributes,$libFile) + lisplibWrite('"predicates",removeZeroOne $lisplibPredicates,$libFile) + lisplibWrite('"abbreviation",$lisplibAbbreviation,$libFile) + lisplibWrite('"parents",removeZeroOne $lisplibParents,$libFile) + lisplibWrite('"ancestors",removeZeroOne $lisplibAncestors,$libFile) + lisplibWrite('"documentation",finalizeDocumentation(),$libFile) + lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) + if $profileCompiler then profileWrite() + if $lisplibForm and null CDR $lisplibForm then + MAKEPROP(CAR $lisplibForm,'NILADIC,'T) + ERRORS ^=0 => -- ERRORS is a fluid variable for the compiler + sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] + sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] + +lisplibDoRename(libName) == + _$REPLACE([libName,$spadLibFT,$libraryDirectory], + [libName,'ERRORLIB,$libraryDirectory]) + +lisplibError(cname,fname,type,cn,fn,typ,error) == + sayMSG bright ['" Illegal ",$spadLibFT] + error in '(duplicateAbb wrongType) => + sayKeyedMsg("S2IL0007", + [namestring [fname,$spadLibFT],type,cname,typ,cn]) + error is 'abbIsName => + throwKeyedMsg("S2IL0008",[fname,typ,namestring [fn,$spadLibFT]]) + +getPartialConstructorModemapSig(c) == + (s := getConstructorSignature c) => rest s + throwEvalTypeMsg("S2IL0015",[c]) + +mergeSignatureAndLocalVarAlists(signatureAlist, localVarAlist) == + -- this function makes a single Alist for both signatures + -- and local variable types, to be stored in the LISPLIB + -- for the function being compiled + [[funcName,:[signature,:LASSOC(funcName,localVarAlist)]] for + [funcName, :signature] in signatureAlist] + +Operators u == + ATOM u => [] + ATOM first u => + answer:="union"/[Operators v for v in rest u] + MEMQ(first u,answer) => answer + [first u,:answer] + "union"/[Operators v for v in u] + +getConstructorOpsAndAtts(form,kind,modemap) == + kind is 'category => getCategoryOpsAndAtts(form) + getFunctorOpsAndAtts(form,modemap) + +getCategoryOpsAndAtts(catForm) == + -- returns [operations,:attributes] of CAR catForm + [transformOperationAlist getSlotFromCategoryForm(catForm,1), + :getSlotFromCategoryForm(catForm,2)] + +getFunctorOpsAndAtts(form,modemap) == + [transformOperationAlist getSlotFromFunctor(form,1,modemap), + :getSlotFromFunctor(form,2,modemap)] + +getSlotFromFunctor([name,:args],slot,[[.,target,:argMml],:.]) == + slot = 1 => $lisplibOperationAlist + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlotFromFunctor" + t.expr.slot + +getSlot1 domainName == + $e: local:= $CategoryFrame + fn:= getLisplibName domainName + p := pathname [fn,$spadLibFT,'"*"] + not isExistingFile(p) => + sayKeyedMsg("S2IL0003",[namestring p]) + NIL + (sig := getConstructorSignature domainName) => + [.,target,:argMml] := sig + for a in $FormalMapVariableList for m in argMml repeat + $e:= put(a,'mode,m,$e) + t := compMakeCategoryObject(target,$e) or + systemErrorHere '"getSlot1" + t.expr.1 + sayKeyedMsg("S2IL0022",[namestring p,'"constructor modemap"]) + NIL + +transformOperationAlist operationAlist == + -- this transforms the operationAlist which is written out onto LISPLIBs. + -- The original form of this list is a list of items of the form: + -- (( ) ( (ELT $ n))) + -- The new form is an op-Alist which has entries ( . signature-Alist) + -- where signature-Alist has entries ( . item) + -- where item has form ( ) + -- where = + -- NIL => function + -- CONST => constant ... and others + newAlist:= nil + for [[op,sig,:.],condition,implementation] in operationAlist repeat + kind:= + implementation is [eltEtc,.,n] and eltEtc in '(CONST ELT) => eltEtc + implementation is [impOp,:.] => + impOp = 'XLAM => implementation + impOp in '(CONST Subsumed) => impOp + keyedSystemError("S2IL0025",[impOp]) + implementation = 'mkRecord => 'mkRecord + keyedSystemError("S2IL0025",[implementation]) + signatureItem:= + if u:= ASSOC([op,sig],$functionLocations) then n := [n,:rest u] + kind = 'ELT => + condition = 'T => [sig,n] + [sig,n,condition] + [sig,n,condition,kind] + itemList:= [signatureItem,:LASSQ(op,newAlist)] + newAlist:= insertAlist(op,itemList,newAlist) + newAlist + +sayNonUnique x == + sayBrightlyNT '"Non-unique:" + pp x + +-- flattenOperationAlist operationAlist == +-- --new form is ( ) +-- [:[[op,:x] for x in y] for [op,:y] in operationAlist] + +getSlotFromDomain(dom,op,oldSig) == + -- returns the slot number in the domain where the function whose + -- signature is oldSig may be found in the domain dom + oldSig:= removeOPT oldSig + dom:= removeOPT dom + sig:= SUBST("$",dom,oldSig) + loadIfNecessary first dom + isPackageForm dom => getSlotFromPackage(dom,op,oldSig) + domain:= evalDomain dom + n:= findConstructorSlotNumber(dom,domain,op,sig) => + (slot:= domain.n).0 = Undef => + throwKeyedMsg("S2IL0023A",[op,formatSignature sig,dom]) + slot + throwKeyedMsg("S2IL0024A",[op,formatSignature sig,dom]) + +findConstructorSlotNumber(domainForm,domain,op,sig) == + null domain.1 => getSlotNumberFromOperationAlist(domainForm,op,sig) + sayMSG ['" using slot 1 of ",domainForm] + constructorArglist:= rest domainForm + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + and/[compare for a in sig for b in sig1]] where compare == + a=b => true + FIXP b => a=constructorArglist.b + isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findSlotNumber" + +bustUnion d == + d is ["Union",domain,utype] and utype='"failed" => domain + d + +getSlotNumberFromOperationAlist(domainForm,op,sig) == + constructorName:= CAR domainForm + constructorArglist:= CDR domainForm + operationAlist:= + GETDATABASE(constructorName, 'OPERATIONALIST) or + keyedSystemError("S2IL0026",[constructorName]) + entryList:= QLASSQ(op,operationAlist) or return nil + tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => + first tail + nil + +sigsMatch(sig,sig1,domainForm) == + -- does signature "sig" match "sig1", where integers 1,2,.. in + -- sig1 designate corresponding arguments of domainForm + while sig and sig1 repeat + partsMatch:= + (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration + FIXP item1 => item = domainForm.item1 --item1=n means nth arg + isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) + null partsMatch => return nil + sig:= rest sig; sig1 := rest sig1 + sig or sig1 => nil + true + +findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain + nsig:=#sig + tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and + and/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + for a in sig for b in sig1]] + tail is [.,["ELT",.,n]] => n + systemErrorHere '"findDomainSlotNumber" + + +getConstructorModemap form == + GETDATABASE(opOf form, 'CONSTRUCTORMODEMAP) + +getConstructorSignature form == + (mm := GETDATABASE(opOf(form),'CONSTRUCTORMODEMAP)) => + [[.,:sig],:.] := mm + sig + NIL + +--% from MODEMAP BOOT + +augModemapsFromDomain1(name,functorForm,e) == + GETL(KAR functorForm,"makeFunctionList") => + addConstructorModemaps(name,functorForm,e) + atom functorForm and (catform:= getmode(functorForm,e)) => + augModemapsFromCategory(name,name,functorForm,catform,e) + mappingForm:= getmodeOrMapping(KAR functorForm,e) => + ["Mapping",categoryForm,:functArgTypes]:= mappingForm + catform:= substituteCategoryArguments(rest functorForm,categoryForm) + augModemapsFromCategory(name,name,functorForm,catform,e) + stackMessage [functorForm," is an unknown mode"] + e + +getSlotFromCategoryForm ([op,:argl],index) == + u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] + null VECP u => + systemErrorHere '"getSlotFromCategoryForm" + u . index + + +--% constructor evaluation +-- The following functions are used by the compiler but are modified +-- here for use with new LISPLIB scheme + +mkEvalableCategoryForm c == --from DEFINE + c is [op,:argl] => + op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] + op is "DomainSubstitutionMacro" => + --$extraParms :local + --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms + --mkEvalableCategoryForm sublisV($extraParms, catobj) + mkEvalableCategoryForm CADR argl + op is "mkCategory" => c + MEMQ(op,$CategoryNames) => + ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) + --loadIfNecessary op + GETDATABASE(op,'CONSTRUCTORKIND) = 'category or + get(op,"isCategory",$CategoryFrame) => + [op,:[quotifyCategoryArgument x for x in argl]] + [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) + m=$Category => x + MKQ c + +isDomainForm(D,e) == + --added for MPOLY 3/83 by RDJ + MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or + -- ((D is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + ((getmode(D,e) is ['Mapping,target,:.]) and isCategoryForm(target,e)) or + isCategoryForm(getmode(D,e),e) or isDomainConstructorForm(D,e) + +isDomainConstructorForm(D,e) == + D is [op,:argl] and (u:= get(op,"value",e)) and + u is [.,["Mapping",target,:.],:.] and + isCategoryForm(EQSUBSTLIST(argl,$FormalMapVariableList,target),e) + +isFunctor x == + op:= opOf x + not IDENTP op => false + $InteractiveMode => + MEMQ(op,'(Union SubDomain Mapping Record)) => true + MEMQ(GETDATABASE(op,'CONSTRUCTORKIND),'(domain package)) + u:= get(op,'isFunctor,$CategoryFrame) + or MEMQ(op,'(SubDomain Union Record)) => u + constructor? op => + prop := get(op,'isFunctor,$CategoryFrame) => prop + if GETDATABASE(op,'CONSTRUCTORKIND) = 'category + then updateCategoryFrameForCategory op + else updateCategoryFrameForConstructor op + get(op,'isFunctor,$CategoryFrame) + nil + + + +@ +\eject +\begin{thebibliography}{99} +\bibitem{1} nothing +\end{thebibliography} +\end{document} -- cgit v1.2.3