From 196d1d9eb5cd8195b6e52a7cbc3581d63e2b2943 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sun, 18 Nov 2007 19:36:05 +0000 Subject: remove more pamphlets --- src/interp/nrunopt.boot | 908 ++++++++++++++++++++++++++++++++++++++ src/interp/nrunopt.boot.pamphlet | 932 --------------------------------------- 2 files changed, 908 insertions(+), 932 deletions(-) create mode 100644 src/interp/nrunopt.boot delete mode 100644 src/interp/nrunopt.boot.pamphlet (limited to 'src') diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot new file mode 100644 index 00000000..5ca437b3 --- /dev/null +++ b/src/interp/nrunopt.boot @@ -0,0 +1,908 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +import '"c-util" +)package "BOOT" + +--======================================================================= +-- Generate Code to Create Infovec +--======================================================================= +getInfovecCode() == +--Function called by compDefineFunctor1 to create infovec at compile time + ['LIST, + MKQ makeDomainTemplate $template, + MKQ makeCompactDirect $NRTslot1Info, + MKQ NRTgenFinalAttributeAlist(), + NRTmakeCategoryAlist(), + MKQ $lookupFunction] + +--======================================================================= +-- Generation of Domain Vector Template (Compile Time) +--======================================================================= +makeDomainTemplate vec == +--NOTES: This function is called at compile time to create the template +-- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 + newVec := GETREFV SIZE vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + newVec.index := + atom item => item + null atom first item => makeGoGetSlot(item,index) + item + $byteVec := "append"/NREVERSE $byteVec + newVec + +makeGoGetSlot(item,index) == +--NOTES: creates byte vec strings for LATCH slots +--these parts of the $byteVec are created first; see also makeCompactDirect + [sig,whereToGo,op,:flag] := item + n := #sig - 1 + newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] + $byteVec := [newcode,:$byteVec] + curAddress := $byteAddress + $byteAddress := $byteAddress + n + 4 + [curAddress,:op] + +--======================================================================= +-- Generate OpTable at Compile Time +--======================================================================= +--> called by getInfovecCode (see top of this file) from compDefineFunctor1 +makeCompactDirect u == + $predListLength :local := LENGTH $NRTslot1PredicateList + $byteVecAcc: local := nil + [nam,[addForm,:opList]] := u + --pp opList + d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] + $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] + LIST2VEC ("append"/d) + +makeCompactDirect1(op,items) == +--NOTES: creates byte codes for ops implemented by the domain + curAddress := $byteAddress + $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) + newcodes := + "append"/[u for y in orderBySubsumption items | u := fn y] or return nil + $byteVecAcc := [newcodes,:$byteVecAcc] + curAddress + where fn y == + [sig,:r] := y + r = ['Subsumed] => + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature + --identified by a 0 in slot position + if r is [n,:s] then + slot := + n is [p,:.] => p --the CDR is linenumber of function definition + n + predCode := + s is [pred,:.] => predicateBitIndex pred + 0 + --> drop items which are not present (predCode = -1) + predCode = -1 => return nil + --> drop items with NIL slots if lookup function is incomplete + if null slot then + $lookupFunction = 'lookupIncomplete => return nil + slot := 1 --signals that operation is not present + n := #sig - 1 + $byteAddress := $byteAddress + n + 4 + res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] + res + +orderBySubsumption items == + acc := subacc := nil + for x in items repeat + not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] + acc := [x,:acc] + y := z := nil + for [a,b,:.] in subacc | b repeat + --NOTE: b = nil means that the signature a will appear in acc, that this + -- entry is be ignored (e.g. init: -> $ in ULS) + while (u := assoc(b,subacc)) repeat b := CADR u + u := assoc(b,acc) or systemError nil + if null CADR u then u := [CAR u,1] --mark as missing operation + y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed + z := insert(b,z) --mark a signature as already present + [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming + +makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where +--$isOpPackageName = true only for an exported operation of a default package + fn() == + x = '_$_$ => 2 + x = '$ => 0 + not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] +-- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages + x + +--======================================================================= +-- Instantiation Code (Stuffslots) +--======================================================================= +stuffDomainSlots dollar == + domname := devaluate dollar + infovec := GETL(opOf domname,'infovec) + lookupFunction := getLookupFun infovec + lookupFunction := + lookupFunction = 'lookupIncomplete => function lookupIncomplete + function lookupComplete + template := infovec.0 + if template.5 then stuffSlot(dollar,5,template.5) + for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat + stuffSlot(dollar,i,item) + dollar.1 := LIST(lookupFunction,dollar,infovec.1) + dollar.2 := infovec.2 + proto4 := infovec.3 + dollar.4 := + VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style + bitVector := dollar.3 + predvec := CAR proto4 + packagevec := CADR proto4 + auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() == + null testBitVector(bitVector,predvec.i) => nil + packagevec.i or true + [auxvec,:CDDR proto4] + +getLookupFun infovec == + MAXINDEX infovec = 4 => infovec.4 + 'lookupIncomplete + +stuffSlot(dollar,i,item) == + dollar.i := + atom item => [SYMBOL_-FUNCTION item,:dollar] + item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] + item is ['CONS,.,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil +-- [dollar,i,:item] --old form +-- $isOpPackageName = 'T => SUBST(0,6,item) + item --new form +--======================================================================= +-- Generate Slot 2 Attribute Alist +--======================================================================= +NRTgenInitialAttributeAlist attributeList == + --alist has form ((item pred)...) where some items are constructor forms + alist := [x for x in attributeList | -- throw out constructors + not MEMQ(opOf first x,allConstructors())] + $lisplibAttributes := simplifyAttributeAlist + [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] + +simplifyAttributeAlist al == + al is [[a,:b],:r] => + u := [x for x in r | x is [=a,:b]] + null u => [first al,:simplifyAttributeAlist rest al] + pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + s := [x for x in r | x isnt [=a,:b]] + [[a,:pred],:simplifyAttributeAlist s] + nil + +NRTgenFinalAttributeAlist() == + [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] + +predicateBitIndex x == + pn(x,false) where + pn(x,flag) == + u := simpBool transHasCode x + u = 'T => 0 + u = nil => -1 + p := POSN1(u,$NRTslot1PredicateList) => p + 1 + not flag => pn(predicateBitIndexRemop x,true) + systemError nil + +predicateBitIndexRemop p== +--transform attribute predicates taken out by removeAttributePredicates + p is [op,:argl] and op in '(AND and OR or NOT not) => + simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) + p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) + p + +predicateBitRef x == + x = 'T => 'T + ['testBitVector,'pv_$,predicateBitIndex x] + +makePrefixForm(u,op) == + u := MKPF(u,op) + u = ''T => 'T + u +--======================================================================= +-- Generate Slot 3 Predicate Vector +--======================================================================= +makePredicateBitVector pl == --called by NRTbuildFunctor + if $insideCategoryPackageIfTrue then + pl := union(pl,$categoryPredicateList) + $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas + for p in removeAttributePredicates pl repeat + pred := simpBool transHasCode p + atom pred => 'skip --skip over T and NIL + if isHasDollarPred pred then + lasts := insert(pred,lasts) + for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) + else + firsts := insert(pred,firsts) + firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) + lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) + firstCode:= + ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] + lastCode := augmentPredCode(# firstPl,lastPl) + $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates + [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 + +augmentPredCode(n,lastPl) == + ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) + delta := 2 ** n + l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); + delta:=2 * delta; u) for x in pl] + +augmentPredVector(dollar,value) == + QSETREFV(dollar,3,value + QVELT(dollar,3)) + +isHasDollarPred pred == + pred is [op,:r] => + MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] + MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ + false + +stripOutNonDollarPreds pred == + pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => + "append"/[stripOutNonDollarPreds x for x in r] + not isHasDollarPred pred => [pred] + nil + +removeAttributePredicates pl == + [fn p for p in pl] where + fn p == + p is [op,:argl] and op in '(AND and OR or NOT not) => + makePrefixForm(fnl argl,op) + p is ['has,'$,['ATTRIBUTE,a]] => + sayBrightlyNT '"Predicate: " + PRINT p + sayBrightlyNT '" replaced by: " + PRINT LASSOC(a,$NRTattributeAlist) + p + fnl p == [fn x for x in p] + +transHasCode x == + atom x => x + op := QCAR x + MEMQ(op,'(HasCategory HasAttribute)) => x + EQ(op,'has) => compHasFormat x + [transHasCode y for y in x] + +mungeAddGensyms(u,gal) == + ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == + atom x => x + g := LASSOC(x,gal) => + n = 0 => ['LET,g,x] + g + [first x,:[fn(y,gal,n + 1) for y in rest x]] + +orderByContainment pl == + null pl or null rest pl => pl + max := first pl + for x in rest pl repeat + if (y := CONTAINED(max,x)) then + if null assoc(max,$predGensymAlist) + then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] + else if CONTAINED(x,max) + then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] + if y then max := x + [max,:orderByContainment delete(max,pl)] + +buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == + null l => n + n := n + n + if QCAR l then n := n + 1 + fn(rest l,n) + +buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == + null l => acc + if CAR l then acc := acc + n + fn(acc,n + n,rest l) + +testBitVector(vec,i) == +--bit vector indices are always 1 larger than position in vector + i = 0 => true + LOGBITP(i - 1,vec) + +bitsOf n == + n = 0 => 0 + 1 + bitsOf (n/2) + +--======================================================================= +-- Generate Slot 4 Constructor Vectors +--======================================================================= +NRTmakeCategoryAlist() == + $depthAssocCache: local := MAKE_-HASHTABLE 'ID + $catAncestorAlist: local := NIL + pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] + $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] + opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) + newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] + slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) + | (k := predicateBitIndex b) ^= -1] + slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] + sixEtc := [5 + i for i in 1..#$pairlis] + formals := ASSOCRIGHT $pairlis + for x in slot1 repeat + RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x)) + -----------code to make a new style slot4 ----------------- + predList := ASSOCRIGHT slot1 --is list of predicate indices + maxPredList := "MAX"/predList + catformvec := ASSOCLEFT slot1 + maxElement := "MAX"/$byteVec + ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], + ['CONS, MKQ LIST2VEC slot0, + ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], + ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] + --NOTE: this is new form: old form satisfies VECP CDDR form + +encodeCatform x == + k := NRTassocIndex x => k + atom x or atom rest x => x + [first x,:[encodeCatform y for y in rest x]] + +NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) + +hasDefaultPackage catname == + defname := INTERN STRCONC(catname,'"&") + constructor? defname => defname +--MEMQ(defname,allConstructors()) => defname + nil + + +--======================================================================= +-- Generate Category Level Alist +--======================================================================= +orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) + +depthAssocList u == + u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 + REMDUP ("append"/[depthAssoc(y) for y in u]) + +depthAssoc x == + y := HGET($depthAssocCache,x) => y + x is ['Join,:u] or (u := getCatAncestors x) => + v := depthAssocList u + HPUT($depthAssocCache,x,[[x,:n],:v]) + where n() == 1 + "MAX"/[rest y for y in v] + HPUT($depthAssocCache,x,[[x,:0]]) + +getCatAncestors x == [CAAR y for y in parentsOf opOf x] + +listOfEntries form == + atom form => form + form is [op,:l] => + op = 'Join => "append"/[listOfEntries x for x in l] + op = 'CATEGORY => listOfCategoryEntries rest l + op = 'PROGN => listOfCategoryEntries l + op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] + op in '(ATTRIBUTE SIGNATURE) => nil + [form] + categoryFormatError() + +listOfCategoryEntries l == + null l => nil + l is [[op,:u],:v] => + firstItemList:= + op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => + [first u] + MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil + op = 'IF and u is [pred,conseq,alternate] => + listOfCategoryEntriesIf(pred,conseq,alternate) + categoryFormatError() + [:firstItemList,:listOfCategoryEntries v] + l is ['PROGN,:l] => listOfCategoryEntries l + l is '(NIL) => nil + sayBrightly '"unexpected category format encountered:" + pp l + +listOfCategoryEntriesIf(pred,conseq,alternate) == + alternate in '(noBranch NIL) => + conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) + [fn for x in listOfEntries conseq] where fn() == + x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] + ['IF,pred,x] + notPred := makePrefixForm(pred,'NOT) + conseq is ['IF,p,c,a] => + listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) + [gn for x in listOfEntries conseq] where gn() == + x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] + ['IF,notPred,x] + +--======================================================================= +-- Display Template +--======================================================================= +dc(:r) == + con := KAR r + options := KDR r + ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) + null ok => + sayBrightly '"Format is: dc(,option)" + sayBrightly + '"options are: all (default), slots, atts, cats, data, ops, optable" + option := KAR options + option = 'all or null option => dcAll con + option = 'slots => dcSlots con + option = 'atts => dcAtts con + option = 'cats => dcCats con + option = 'data => dcData con + option = 'ops => dcOps con + option = 'size => dcSize( con,'full) + option = 'optable => dcOpTable con + +dcSlots con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + for i in 5..MAXINDEX template repeat + sayBrightlyNT bright i + item := template.i + item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) + null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] + atom item => sayBrightly ['"fun ",item] + item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] + sayBrightly concat('"lazy ",form2String formatSlotDomain i) + +dcOpLatchPrint(op,index) == + numvec := getCodeVector() + numOfArgs := numvec.index + whereNumber := numvec.(index := index + 1) + signumList := dcSig(numvec,index + 1,numOfArgs) + index := index + numOfArgs + 1 + namePart := concat(bright "from", + dollarPercentTran form2String formatSlotDomain whereNumber) + sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] + +getInfovec name == + u := GETL(name,'infovec) => u + GETL(name,'LOADED) => nil + fullLibName := GETDATABASE(name,'OBJECT) or return nil + startTimingProcess 'load + loadLibNoUpdate(name, name, fullLibName) + GETL(name,'infovec) + +getOpSegment index == + numOfArgs := (vec := getCodeVector()).index + [vec.i for i in index..(index + numOfArgs + 3)] + +getCodeVector() == + proto4 := $infovec.3 + u := CDDR proto4 + VECP u => u --old style + CDR u --new style + +formatSlotDomain x == + x = 0 => ["$"] + x = 2 => ["$$"] + INTEGERP x => + val := $infovec.0.x + null val => [STRCONC('"#",STRINGIMAGE (x - 5))] + formatSlotDomain val + atom x => x + x is ['NRTEVAL,y] => (atom y => [y]; y) + [first x,:[formatSlotDomain y for y in rest x]] + +--======================================================================= +-- Display OpTable +--======================================================================= +dcOpTable con == + name := abbreviation? con or con + $infovec: local := getInfovec name + template := $infovec.0 + $predvec: local := GETDATABASE(con,'PREDICATES) + opTable := $infovec.1 + for i in 0..MAXINDEX opTable repeat + op := opTable.i + i := i + 1 + startIndex := opTable.i + stopIndex := + i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() + opTable.(i + 2) + curIndex := startIndex + while curIndex < stopIndex repeat + curIndex := dcOpPrint(op,curIndex) + +dcOpPrint(op,index) == + numvec := getCodeVector() + segment := getOpSegment index + numOfArgs := numvec.index + index := index + 1 + predNumber := numvec.index + index := index + 1 + signumList := dcSig(numvec,index,numOfArgs) + index := index + numOfArgs + 1 + slotNumber := numvec.index + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + namePart := bright + slotNumber = 0 => '"subsumed by next entry" + slotNumber = 1 => '"missing" + name := $infovec.0.slotNumber + atom name => name + '"looked up" + sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] + index + 1 + +dcSig(numvec,index,numOfArgs) == + [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] + +dcPreds con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + for i in 0..MAXINDEX $predvec repeat + sayBrightlyNT bright (i + 1) + sayBrightly pred2English $predvec.i + +dcAtts con == + name := abbreviation? con or con + $infovec: local := getInfovec name + $predvec:= GETDATABASE(con,'PREDICATES) + attList := $infovec.2 + for [a,:predNumber] in attList for i in 0.. repeat + sayBrightlyNT bright i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + sayBrightly [a,:suffix] + +dcCats con == + name := abbreviation? con or con + $infovec: local := getInfovec name + u := $infovec.3 + VECP CDDR u => dcCats1 con --old style slot4 + $predvec:= GETDATABASE(con,'PREDICATES) + catpredvec := CAR u + catinfo := CADR u + catvec := CADDR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + form := catvec.i + predNumber := catpredvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcCats1 con == + $predvec:= GETDATABASE(con,'PREDICATES) + u := $infovec.3 + catvec := CADR u + catinfo := CAR u + for i in 0..MAXINDEX catvec repeat + sayBrightlyNT bright i + [form,:predNumber] := catvec.i + suffix := + predNumber = 0 => nil + [:bright '"if",:pred2English $predvec.(predNumber - 1)] + extra := + null (info := catinfo.i) => nil + IDENTP info => bright '"package" + bright '"instantiated" + sayBrightly concat(form2String formatSlotDomain form,suffix,extra) + +dcData con == + name := abbreviation? con or con + $infovec: local := getInfovec name + sayBrightly '"Operation data from slot 1" + PRINT_-FULL $infovec.1 + vec := getCodeVector() + vec := (PAIRP vec => CDR vec; vec) + sayBrightly ['"Information vector has ",SIZE vec,'" entries"] + dcData1 vec + +dcData1 vec == + n := MAXINDEX vec + tens := n / 10 + for i in 0..tens repeat + start := 10*i + sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) + sayBrightlyNT '" |" + for j in start..MIN(start + 9,n) repeat + sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) + sayNewLine() + vec + +dcSize(:options) == + con := KAR options + options := rest options + null con => dcSizeAll() + quiet := MEMQ('quiet,options) + full := MEMQ('full,options) + name := abbreviation? con or con + infovec := getInfovec name + template := infovec.0 + maxindex := MAXINDEX template + latch := 0 --# of go get slots + lazy := 0 --# of lazy domain slots + fun := 0 --# of function slots + lazyNodes := 0 --# of nodes needed for lazy domain slots + for i in 5..maxindex repeat + atom (item := template.i) => fun := fun + 1 + INTEGERP first item => latch := latch + 1 + 'T => + lazy := lazy + 1 + lazyNodes := lazyNodes + numberOfNodes item + tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) + -- functions are free in the template vector + oSize := vectorSize(SIZE infovec.1) + aSize := numberOfNodes infovec.2 + slot4 := infovec.3 + catvec := + VECP CDDR slot4 => CADR slot4 + CADDR slot4 + n := MAXINDEX catvec + cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), + nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) + codeVector := + VECP CDDR slot4 => CDDR slot4 + CDDDR slot4 + vSize := halfWordSize(SIZE codeVector) + itotal := sum(tSize,oSize,aSize,cSize,vSize) + if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] + if null quiet then + lookupFun := getLookupFun infovec + suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") + sayBrightly ['"template = ",tSize] + sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] + sayBrightly ['"attributes = ",aSize] + sayBrightly ['"categories = ",cSize] + sayBrightly ['"data vector = ",vSize] + if null quiet then + sayBrightly ['"number of function slots (one extra node) = ",fun] + sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] + sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] + sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] + vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) + vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) + --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm + if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] + etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) + if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] + vtotal + +dcSizeAll() == + count := 0 + total := 0 + for x in allConstructors() | null atom GETL(x,'infovec) repeat + count := count + 1 + s := dcSize(x,'quiet) + sayBrightly [s,'" : ",x] + total := total + s + sayBrightly '"------------total-------------" + sayBrightly [count," constructors; ",total," BYTES"] + +sum(:l) == +/l + +nodeSize(n) == 12 * n + +vectorSize(n) == 4 * (1 + n) + +halfWordSize(n) == + n < 128 => n / 2 + n < 256 => n + 2 * n + +numberOfNodes(x) == + atom x => 0 + 1 + numberOfNodes first x + numberOfNodes rest x + +template con == + con := abbreviation? con or con + ppTemplate (getInfovec con).0 + +ppTemplate vec == + for i in 0..MAXINDEX vec repeat + sayBrightlyNT bright i + pp vec.i + +infovec con == + con := abbreviation? con or con + u := getInfovec con + sayBrightly '"---------------slot 0 is template-------------------" + ppTemplate u.0 + sayBrightly '"---------------slot 1 is op table-------------------" + PRINT_-FULL u.1 + sayBrightly '"---------------slot 2 is attribute list-------------" + PRINT_-FULL u.2 + sayBrightly '"---------------slot 3.0 is catpredvec---------------" + PRINT_-FULL u.3.0 + sayBrightly '"---------------slot 3.1 is catinfovec---------------" + PRINT_-FULL u.3.1 + sayBrightly '"---------------slot 3.2 is catvec-------------------" + PRINT_-FULL u.3.2 + sayBrightly '"---------------tail of slot 3 is datavector---------" + dcData1 CDDDR u.3 + 'done + +dcAll con == + con := abbreviation? con or con + $infovec : local := getInfovec con + complete? := + #$infovec = 4 => false + $infovec.4 = 'lookupComplete + sayBrightly '"----------------Template-----------------" + dcSlots con + sayBrightly + complete? => '"----------Complete Ops----------------" + '"----------Incomplete Ops---------------" + dcOpTable con + sayBrightly '"----------------Atts-----------------" + dcAtts con + sayBrightly '"----------------Preds-----------------" + dcPreds con + sayBrightly '"----------------Cats-----------------" + dcCats con + sayBrightly '"----------------Data------------------" + dcData con + sayBrightly '"----------------Size------------------" + dcSize(con,'full) + 'done + +dcOps conname == + for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat + for [sig,slot,pred,key,:.] in u repeat + suffix := + atom pred => nil + concat('" if ",pred2English pred) + key = 'Subsumed => + sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] + sayBrightly [:formatOpSignature(op,sig),:suffix] + +--======================================================================= +-- Compute the lookup function (complete or incomplete) +--======================================================================= +NRTgetLookupFunction(domform,exCategory,addForm) == + domform := SUBLIS($pairlis,domform) + addForm := SUBLIS($pairlis,addForm) + $why: local := nil + atom addForm => 'lookupComplete + extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) + if null extends then + [u,msg,:v] := $why + sayBrightly '"--------------non extending category----------------------" + sayBrightlyNT ['"..",:bright form2String domform,"of cat "] + PRINT u + sayBrightlyNT bright msg + if v then PRINT CAR v else TERPRI() + extends => 'lookupIncomplete + 'lookupComplete + +getExportCategory form == + [op,:argl] := form + op = 'Record => ['RecordCategory,:argl] + op = 'Union => ['UnionCategory,:argl] + functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) + [[.,target,:tl],:.] := functorModemap + EQSUBSTLIST(argl,$FormalMapVariableList,target) + +NRTextendsCategory1(domform,exCategory,addForm) == + addForm is ['Tuple,:r] => + and/[extendsCategory(domform,exCategory,x) for x in r] + extendsCategory(domform,exCategory,addForm) + +--======================================================================= +-- Compute if a domain constructor is forgetful functor +--======================================================================= +extendsCategory(dom,u,v) == + --does category u extend category v (yes iff u contains everything in v) + --is dom of category u also of category v? + u=v => true + v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] + v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) + v := substSlotNumbers(v,$template,$functorForm) + extendsCategoryBasic0(dom,u,v) => true + $why := + v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] + [u,'" has no",v] + nil + +extendsCategoryBasic0(dom,u,v) == + v is ['IF,p,['ATTRIBUTE,c],.] => + uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr + null atom c and isCategoryForm(c,nil) => + slot4 := uVec.4 + LASSOC(c,CADR slot4) is [=p,:.] + slot2 := uVec.2 + LASSOC(c,slot2) is [=p,:.] + extendsCategoryBasic(dom,u,v) + +extendsCategoryBasic(dom,u,v) == + u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] + u = v => true + uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr + isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) + v is ['SIGNATURE,op,sig] => + or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] + u is ['CATEGORY,.,:l] => + v is ['IF,:.] => member(v,l) + nil + nil + +catExtendsCat?(u,v,uvec) == + u = v => true + uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr + slot4 := uvec.4 + prinAncestorList := CAR slot4 + member(v,prinAncestorList) => true + vOp := KAR v + if similarForm := assoc(vOp,prinAncestorList) then + PRINT u + sayBrightlyNT '" extends " + PRINT similarForm + sayBrightlyNT '" but not " + PRINT v + or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] + +substSlotNumbers(form,template,domain) == + form is [op,:.] and + MEMQ(op,allConstructors()) => expandType(form,template,domain) + form is ['SIGNATURE,op,sig] => + ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] + form is ['CATEGORY,k,:u] => + ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] + expandType(form,template,domain) + +expandType(lazyt,template,domform) == + atom lazyt => expandTypeArgs(lazyt,template,domform) + [functorName,:argl] := lazyt + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] + for [.,tag,dom] in argl]] + lazyt is ['local,x] => + n := POSN1(x,$FormalMapVariableList) + ELT(domform,1 + n) + [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] + +expandTypeArgs(u,template,domform) == + u = '$ => u --template.0 -------eliminate this as $ is rep by 0 + INTEGERP u => expandType(templateVal(template, domform, u), template,domform) + u is ['NRTEVAL,y] => y --eval y + u is ['QUOTE,y] => y + atom u => u + expandType(u,template,domform) + +templateVal(template,domform,index) == +--returns a domform or a lazy slot + index = 0 => harhar() --template + template.index + diff --git a/src/interp/nrunopt.boot.pamphlet b/src/interp/nrunopt.boot.pamphlet deleted file mode 100644 index 5f4fb366..00000000 --- a/src/interp/nrunopt.boot.pamphlet +++ /dev/null @@ -1,932 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/nrunopt.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. - -@ -<<*>>= -<> - -import '"c-util" -)package "BOOT" - ---======================================================================= --- Generate Code to Create Infovec ---======================================================================= -getInfovecCode() == ---Function called by compDefineFunctor1 to create infovec at compile time - ['LIST, - MKQ makeDomainTemplate $template, - MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist(), - NRTmakeCategoryAlist(), - MKQ $lookupFunction] - ---======================================================================= --- Generation of Domain Vector Template (Compile Time) ---======================================================================= -makeDomainTemplate vec == ---NOTES: This function is called at compile time to create the template --- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 - newVec := GETREFV SIZE vec - for index in 0..MAXINDEX vec repeat - item := vec.index - null item => nil - newVec.index := - atom item => item - null atom first item => makeGoGetSlot(item,index) - item - $byteVec := "append"/NREVERSE $byteVec - newVec - -makeGoGetSlot(item,index) == ---NOTES: creates byte vec strings for LATCH slots ---these parts of the $byteVec are created first; see also makeCompactDirect - [sig,whereToGo,op,:flag] := item - n := #sig - 1 - newcode := [n,whereToGo,:makeCompactSigCode(sig,nil),index] - $byteVec := [newcode,:$byteVec] - curAddress := $byteAddress - $byteAddress := $byteAddress + n + 4 - [curAddress,:op] - ---======================================================================= --- Generate OpTable at Compile Time ---======================================================================= ---> called by getInfovecCode (see top of this file) from compDefineFunctor1 -makeCompactDirect u == - $predListLength :local := LENGTH $NRTslot1PredicateList - $byteVecAcc: local := nil - [nam,[addForm,:opList]] := u - --pp opList - d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] - $byteVec := [:$byteVec,:"append"/NREVERSE $byteVecAcc] - LIST2VEC ("append"/d) - -makeCompactDirect1(op,items) == ---NOTES: creates byte codes for ops implemented by the domain - curAddress := $byteAddress - $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) - newcodes := - "append"/[u for y in orderBySubsumption items | u := fn y] or return nil - $byteVecAcc := [newcodes,:$byteVecAcc] - curAddress - where fn y == - [sig,:r] := y - r = ['Subsumed] => - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - [n,0,:makeCompactSigCode(sig,$isOpPackageName),0] --always followed by subsuming signature - --identified by a 0 in slot position - if r is [n,:s] then - slot := - n is [p,:.] => p --the CDR is linenumber of function definition - n - predCode := - s is [pred,:.] => predicateBitIndex pred - 0 - --> drop items which are not present (predCode = -1) - predCode = -1 => return nil - --> drop items with NIL slots if lookup function is incomplete - if null slot then - $lookupFunction = 'lookupIncomplete => return nil - slot := 1 --signals that operation is not present - n := #sig - 1 - $byteAddress := $byteAddress + n + 4 - res := [n,predCode,:makeCompactSigCode(sig,$isOpPackageName),slot] - res - -orderBySubsumption items == - acc := subacc := nil - for x in items repeat - not MEMQ($op,'(Zero One)) and x is [.,.,.,'Subsumed] => subacc := [x,:subacc] - acc := [x,:acc] - y := z := nil - for [a,b,:.] in subacc | b repeat - --NOTE: b = nil means that the signature a will appear in acc, that this - -- entry is be ignored (e.g. init: -> $ in ULS) - while (u := assoc(b,subacc)) repeat b := CADR u - u := assoc(b,acc) or systemError nil - if null CADR u then u := [CAR u,1] --mark as missing operation - y := [[a,'Subsumed],u,:y] --makes subsuming signature follow one subsumed - z := insert(b,z) --mark a signature as already present - [:y,:[w for (w := [c,:.]) in acc | not member(c,z)]] --add those not subsuming - -makeCompactSigCode(sig,$isOpPackageName) == [fn for x in sig] where ---$isOpPackageName = true only for an exported operation of a default package - fn() == - x = '_$_$ => 2 - x = '$ => 0 - not INTEGERP x => systemError ['"code vector slot is ",x,"; must be number"] --- x = 6 and $isOpPackageName => 0 --treat slot 6 as $ for default packages - x - ---======================================================================= --- Instantiation Code (Stuffslots) ---======================================================================= -stuffDomainSlots dollar == - domname := devaluate dollar - infovec := GETL(opOf domname,'infovec) - lookupFunction := getLookupFun infovec - lookupFunction := - lookupFunction = 'lookupIncomplete => function lookupIncomplete - function lookupComplete - template := infovec.0 - if template.5 then stuffSlot(dollar,5,template.5) - for i in (6 + # rest domname)..MAXINDEX template | item := template.i repeat - stuffSlot(dollar,i,item) - dollar.1 := LIST(lookupFunction,dollar,infovec.1) - dollar.2 := infovec.2 - proto4 := infovec.3 - dollar.4 := - VECP CDDR proto4 => [COPY_-SEQ CAR proto4,:CDR proto4] --old style - bitVector := dollar.3 - predvec := CAR proto4 - packagevec := CADR proto4 - auxvec := LIST2VEC [fn for i in 0..MAXINDEX predvec] where fn() == - null testBitVector(bitVector,predvec.i) => nil - packagevec.i or true - [auxvec,:CDDR proto4] - -getLookupFun infovec == - MAXINDEX infovec = 4 => infovec.4 - 'lookupIncomplete - -stuffSlot(dollar,i,item) == - dollar.i := - atom item => [SYMBOL_-FUNCTION item,:dollar] - item is [n,:op] and INTEGERP n => ['newGoGet,dollar,:item] - item is ['CONS,.,['FUNCALL,a,b]] => - b = '$ => ['makeSpadConstant,eval a,dollar,i] - sayBrightlyNT '"Unexpected constant environment!!" - pp devaluate b - nil --- [dollar,i,:item] --old form --- $isOpPackageName = 'T => SUBST(0,6,item) - item --new form ---======================================================================= --- Generate Slot 2 Attribute Alist ---======================================================================= -NRTgenInitialAttributeAlist attributeList == - --alist has form ((item pred)...) where some items are constructor forms - alist := [x for x in attributeList | -- throw out constructors - not MEMQ(opOf first x,allConstructors())] - $lisplibAttributes := simplifyAttributeAlist - [[a,:b] for [a,b] in SUBLIS($pairlis,alist) | a ^= 'nothing] - -simplifyAttributeAlist al == - al is [[a,:b],:r] => - u := [x for x in r | x is [=a,:b]] - null u => [first al,:simplifyAttributeAlist rest al] - pred := simpBool makePrefixForm([b,:ASSOCRIGHT u],'OR) - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - s := [x for x in r | x isnt [=a,:b]] - [[a,:pred],:simplifyAttributeAlist s] - nil - -NRTgenFinalAttributeAlist() == - [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b)) ^= -1] - -predicateBitIndex x == - pn(x,false) where - pn(x,flag) == - u := simpBool transHasCode x - u = 'T => 0 - u = nil => -1 - p := POSN1(u,$NRTslot1PredicateList) => p + 1 - not flag => pn(predicateBitIndexRemop x,true) - systemError nil - -predicateBitIndexRemop p== ---transform attribute predicates taken out by removeAttributePredicates - p is [op,:argl] and op in '(AND and OR or NOT not) => - simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op) - p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist) - p - -predicateBitRef x == - x = 'T => 'T - ['testBitVector,'pv_$,predicateBitIndex x] - -makePrefixForm(u,op) == - u := MKPF(u,op) - u = ''T => 'T - u ---======================================================================= --- Generate Slot 3 Predicate Vector ---======================================================================= -makePredicateBitVector pl == --called by NRTbuildFunctor - if $insideCategoryPackageIfTrue then - pl := union(pl,$categoryPredicateList) - $predGensymAlist := nil --bound by NRTbuildFunctor, used by optHas - for p in removeAttributePredicates pl repeat - pred := simpBool transHasCode p - atom pred => 'skip --skip over T and NIL - if isHasDollarPred pred then - lasts := insert(pred,lasts) - for q in stripOutNonDollarPreds pred repeat firsts := insert(q,firsts) - else - firsts := insert(pred,firsts) - firstPl := SUBLIS($pairlis,NREVERSE orderByContainment firsts) - lastPl := SUBLIS($pairlis,NREVERSE orderByContainment lasts) - firstCode:= - ['buildPredVector,0,0,mungeAddGensyms(firstPl,$predGensymAlist)] - lastCode := augmentPredCode(# firstPl,lastPl) - $lisplibPredicates := [:firstPl,:lastPl] --what is stored under 'predicates - [$lisplibPredicates,firstCode,:lastCode] --$pairlis set by compDefineFunctor1 - -augmentPredCode(n,lastPl) == - ['LIST,:pl] := mungeAddGensyms(lastPl,$predGensymAlist) - delta := 2 ** n - l := [(u := MKPF([x,['augmentPredVector,$,delta]],'AND); - delta:=2 * delta; u) for x in pl] - -augmentPredVector(dollar,value) == - QSETREFV(dollar,3,value + QVELT(dollar,3)) - -isHasDollarPred pred == - pred is [op,:r] => - MEMQ(op,'(AND and OR or NOT not)) => or/[isHasDollarPred x for x in r] - MEMQ(op,'(HasCategory HasAttribute)) => CAR r = '$ - false - -stripOutNonDollarPreds pred == - pred is [op,:r] and MEMQ(op,'(AND and OR or NOT not)) => - "append"/[stripOutNonDollarPreds x for x in r] - not isHasDollarPred pred => [pred] - nil - -removeAttributePredicates pl == - [fn p for p in pl] where - fn p == - p is [op,:argl] and op in '(AND and OR or NOT not) => - makePrefixForm(fnl argl,op) - p is ['has,'$,['ATTRIBUTE,a]] => - sayBrightlyNT '"Predicate: " - PRINT p - sayBrightlyNT '" replaced by: " - PRINT LASSOC(a,$NRTattributeAlist) - p - fnl p == [fn x for x in p] - -transHasCode x == - atom x => x - op := QCAR x - MEMQ(op,'(HasCategory HasAttribute)) => x - EQ(op,'has) => compHasFormat x - [transHasCode y for y in x] - -mungeAddGensyms(u,gal) == - ['LIST,:[fn(x,gal,0) for x in u]] where fn(x,gal,n) == - atom x => x - g := LASSOC(x,gal) => - n = 0 => ['LET,g,x] - g - [first x,:[fn(y,gal,n + 1) for y in rest x]] - -orderByContainment pl == - null pl or null rest pl => pl - max := first pl - for x in rest pl repeat - if (y := CONTAINED(max,x)) then - if null assoc(max,$predGensymAlist) - then $predGensymAlist := [[max,:GENSYM()],:$predGensymAlist] - else if CONTAINED(x,max) - then if null assoc(x,$predGensymAlist) then $predGensymAlist := [[x,:GENSYM()],:$predGensymAlist] - if y then max := x - [max,:orderByContainment delete(max,pl)] - -buildBitTable(:l) == fn(REVERSE l,0) where fn(l,n) == - null l => n - n := n + n - if QCAR l then n := n + 1 - fn(rest l,n) - -buildPredVector(init,n,l) == fn(init,2 ** n,l) where fn(acc,n,l) == - null l => acc - if CAR l then acc := acc + n - fn(acc,n + n,rest l) - -testBitVector(vec,i) == ---bit vector indices are always 1 larger than position in vector - i = 0 => true - LOGBITP(i - 1,vec) - -bitsOf n == - n = 0 => 0 - 1 + bitsOf (n/2) - ---======================================================================= --- Generate Slot 4 Constructor Vectors ---======================================================================= -NRTmakeCategoryAlist() == - $depthAssocCache: local := MAKE_-HASHTABLE 'ID - $catAncestorAlist: local := NIL - pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] - $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] - opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) - newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] - slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) - | (k := predicateBitIndex b) ^= -1] - slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] - sixEtc := [5 + i for i in 1..#$pairlis] - formals := ASSOCRIGHT $pairlis - for x in slot1 repeat - RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x)) - -----------code to make a new style slot4 ----------------- - predList := ASSOCRIGHT slot1 --is list of predicate indices - maxPredList := "MAX"/predList - catformvec := ASSOCLEFT slot1 - maxElement := "MAX"/$byteVec - ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], - ['CONS, MKQ LIST2VEC slot0, - ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], - ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] - --NOTE: this is new form: old form satisfies VECP CDDR form - -encodeCatform x == - k := NRTassocIndex x => k - atom x or atom rest x => x - [first x,:[encodeCatform y for y in rest x]] - -NRTcatCompare [catform,:pred] == LASSOC(first catform,$levelAlist) - -hasDefaultPackage catname == - defname := INTERN STRCONC(catname,'"&") - constructor? defname => defname ---MEMQ(defname,allConstructors()) => defname - nil - - ---======================================================================= --- Generate Category Level Alist ---======================================================================= -orderCatAnc x == NREVERSE ASSOCLEFT SORTBY('CDR,CDR depthAssoc x) - -depthAssocList u == - u := delete('DomainSubstitutionMacro,u) --hack by RDJ 8/90 - REMDUP ("append"/[depthAssoc(y) for y in u]) - -depthAssoc x == - y := HGET($depthAssocCache,x) => y - x is ['Join,:u] or (u := getCatAncestors x) => - v := depthAssocList u - HPUT($depthAssocCache,x,[[x,:n],:v]) - where n() == 1 + "MAX"/[rest y for y in v] - HPUT($depthAssocCache,x,[[x,:0]]) - -getCatAncestors x == [CAAR y for y in parentsOf opOf x] - -listOfEntries form == - atom form => form - form is [op,:l] => - op = 'Join => "append"/[listOfEntries x for x in l] - op = 'CATEGORY => listOfCategoryEntries rest l - op = 'PROGN => listOfCategoryEntries l - op = 'ATTRIBUTE and first l is [f,:.] and constructor? f => [first l] - op in '(ATTRIBUTE SIGNATURE) => nil - [form] - categoryFormatError() - -listOfCategoryEntries l == - null l => nil - l is [[op,:u],:v] => - firstItemList:= - op = 'ATTRIBUTE and first u is [f,:.] and constructor? f => - [first u] - MEMQ(op,'(ATTRIBUTE SIGNATURE)) => nil - op = 'IF and u is [pred,conseq,alternate] => - listOfCategoryEntriesIf(pred,conseq,alternate) - categoryFormatError() - [:firstItemList,:listOfCategoryEntries v] - l is ['PROGN,:l] => listOfCategoryEntries l - l is '(NIL) => nil - sayBrightly '"unexpected category format encountered:" - pp l - -listOfCategoryEntriesIf(pred,conseq,alternate) == - alternate in '(noBranch NIL) => - conseq is ['IF,p,c,a] => listOfCategoryEntriesIf(makePrefixForm([pred,p],'AND),c,a) - [fn for x in listOfEntries conseq] where fn() == - x is ['IF,a,b] => ['IF,makePrefixForm([pred,a],'AND),b] - ['IF,pred,x] - notPred := makePrefixForm(pred,'NOT) - conseq is ['IF,p,c,a] => - listOfCategoryEntriesIf(makePrefixForm([notPred,p],'AND),c,a) - [gn for x in listOfEntries conseq] where gn() == - x is ['IF,a,b] => ['IF,makePrefixForm([notPred,a],'AND),b] - ['IF,notPred,x] - ---======================================================================= --- Display Template ---======================================================================= -dc(:r) == - con := KAR r - options := KDR r - ok := MEMQ(con,allConstructors()) or (con := abbreviation? con) - null ok => - sayBrightly '"Format is: dc(,option)" - sayBrightly - '"options are: all (default), slots, atts, cats, data, ops, optable" - option := KAR options - option = 'all or null option => dcAll con - option = 'slots => dcSlots con - option = 'atts => dcAtts con - option = 'cats => dcCats con - option = 'data => dcData con - option = 'ops => dcOps con - option = 'size => dcSize( con,'full) - option = 'optable => dcOpTable con - -dcSlots con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - for i in 5..MAXINDEX template repeat - sayBrightlyNT bright i - item := template.i - item is [n,:op] and INTEGERP n => dcOpLatchPrint(op,n) - null item and i > 5 => sayBrightly ['"arg ",STRCONC('"#",STRINGIMAGE(i - 5))] - atom item => sayBrightly ['"fun ",item] - item is ['CONS,.,['FUNCALL,[.,a],b]] => sayBrightly ['"constant ",a] - sayBrightly concat('"lazy ",form2String formatSlotDomain i) - -dcOpLatchPrint(op,index) == - numvec := getCodeVector() - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) - signumList := dcSig(numvec,index + 1,numOfArgs) - index := index + numOfArgs + 1 - namePart := concat(bright "from", - dollarPercentTran form2String formatSlotDomain whereNumber) - sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] - -getInfovec name == - u := GETL(name,'infovec) => u - GETL(name,'LOADED) => nil - fullLibName := GETDATABASE(name,'OBJECT) or return nil - startTimingProcess 'load - loadLibNoUpdate(name, name, fullLibName) - GETL(name,'infovec) - -getOpSegment index == - numOfArgs := (vec := getCodeVector()).index - [vec.i for i in index..(index + numOfArgs + 3)] - -getCodeVector() == - proto4 := $infovec.3 - u := CDDR proto4 - VECP u => u --old style - CDR u --new style - -formatSlotDomain x == - x = 0 => ["$"] - x = 2 => ["$$"] - INTEGERP x => - val := $infovec.0.x - null val => [STRCONC('"#",STRINGIMAGE (x - 5))] - formatSlotDomain val - atom x => x - x is ['NRTEVAL,y] => (atom y => [y]; y) - [first x,:[formatSlotDomain y for y in rest x]] - ---======================================================================= --- Display OpTable ---======================================================================= -dcOpTable con == - name := abbreviation? con or con - $infovec: local := getInfovec name - template := $infovec.0 - $predvec: local := GETDATABASE(con,'PREDICATES) - opTable := $infovec.1 - for i in 0..MAXINDEX opTable repeat - op := opTable.i - i := i + 1 - startIndex := opTable.i - stopIndex := - i + 1 > MAXINDEX opTable => MAXINDEX getCodeVector() - opTable.(i + 2) - curIndex := startIndex - while curIndex < stopIndex repeat - curIndex := dcOpPrint(op,curIndex) - -dcOpPrint(op,index) == - numvec := getCodeVector() - segment := getOpSegment index - numOfArgs := numvec.index - index := index + 1 - predNumber := numvec.index - index := index + 1 - signumList := dcSig(numvec,index,numOfArgs) - index := index + numOfArgs + 1 - slotNumber := numvec.index - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - namePart := bright - slotNumber = 0 => '"subsumed by next entry" - slotNumber = 1 => '"missing" - name := $infovec.0.slotNumber - atom name => name - '"looked up" - sayBrightly [:formatOpSignature(op,signumList),:namePart, :suffix] - index + 1 - -dcSig(numvec,index,numOfArgs) == - [formatSlotDomain numvec.(index + i) for i in 0..numOfArgs] - -dcPreds con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - for i in 0..MAXINDEX $predvec repeat - sayBrightlyNT bright (i + 1) - sayBrightly pred2English $predvec.i - -dcAtts con == - name := abbreviation? con or con - $infovec: local := getInfovec name - $predvec:= GETDATABASE(con,'PREDICATES) - attList := $infovec.2 - for [a,:predNumber] in attList for i in 0.. repeat - sayBrightlyNT bright i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - sayBrightly [a,:suffix] - -dcCats con == - name := abbreviation? con or con - $infovec: local := getInfovec name - u := $infovec.3 - VECP CDDR u => dcCats1 con --old style slot4 - $predvec:= GETDATABASE(con,'PREDICATES) - catpredvec := CAR u - catinfo := CADR u - catvec := CADDR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - form := catvec.i - predNumber := catpredvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcCats1 con == - $predvec:= GETDATABASE(con,'PREDICATES) - u := $infovec.3 - catvec := CADR u - catinfo := CAR u - for i in 0..MAXINDEX catvec repeat - sayBrightlyNT bright i - [form,:predNumber] := catvec.i - suffix := - predNumber = 0 => nil - [:bright '"if",:pred2English $predvec.(predNumber - 1)] - extra := - null (info := catinfo.i) => nil - IDENTP info => bright '"package" - bright '"instantiated" - sayBrightly concat(form2String formatSlotDomain form,suffix,extra) - -dcData con == - name := abbreviation? con or con - $infovec: local := getInfovec name - sayBrightly '"Operation data from slot 1" - PRINT_-FULL $infovec.1 - vec := getCodeVector() - vec := (PAIRP vec => CDR vec; vec) - sayBrightly ['"Information vector has ",SIZE vec,'" entries"] - dcData1 vec - -dcData1 vec == - n := MAXINDEX vec - tens := n / 10 - for i in 0..tens repeat - start := 10*i - sayBrightlyNT rightJustifyString(STRINGIMAGE start,6) - sayBrightlyNT '" |" - for j in start..MIN(start + 9,n) repeat - sayBrightlyNT rightJustifyString(STRINGIMAGE vec.j,6) - sayNewLine() - vec - -dcSize(:options) == - con := KAR options - options := rest options - null con => dcSizeAll() - quiet := MEMQ('quiet,options) - full := MEMQ('full,options) - name := abbreviation? con or con - infovec := getInfovec name - template := infovec.0 - maxindex := MAXINDEX template - latch := 0 --# of go get slots - lazy := 0 --# of lazy domain slots - fun := 0 --# of function slots - lazyNodes := 0 --# of nodes needed for lazy domain slots - for i in 5..maxindex repeat - atom (item := template.i) => fun := fun + 1 - INTEGERP first item => latch := latch + 1 - 'T => - lazy := lazy + 1 - lazyNodes := lazyNodes + numberOfNodes item - tSize := sum(vectorSize(1 + maxindex),nodeSize(lazyNodes + latch)) - -- functions are free in the template vector - oSize := vectorSize(SIZE infovec.1) - aSize := numberOfNodes infovec.2 - slot4 := infovec.3 - catvec := - VECP CDDR slot4 => CADR slot4 - CADDR slot4 - n := MAXINDEX catvec - cSize := sum(nodeSize(2),vectorSize(SIZE CAR slot4),vectorSize(n + 1), - nodeSize(+/[numberOfNodes catvec.i for i in 0..n])) - codeVector := - VECP CDDR slot4 => CDDR slot4 - CDDDR slot4 - vSize := halfWordSize(SIZE codeVector) - itotal := sum(tSize,oSize,aSize,cSize,vSize) - if null quiet then sayBrightly ['"infovec total = ",itotal,'" BYTES"] - if null quiet then - lookupFun := getLookupFun infovec - suffix := (lookupFun = 'lookupIncomplete => '"incomplete"; '"complete") - sayBrightly ['"template = ",tSize] - sayBrightly ['"operations = ",oSize,'" (",suffix,'")"] - sayBrightly ['"attributes = ",aSize] - sayBrightly ['"categories = ",cSize] - sayBrightly ['"data vector = ",vSize] - if null quiet then - sayBrightly ['"number of function slots (one extra node) = ",fun] - sayBrightly ['"number of latch slots (2 extra nodes) = ",latch] - sayBrightly ['"number of lazy slots (no extra nodes) = ",lazy] - sayBrightly ['"size of domain vectors = ",1 + maxindex,'" slots"] - vtotal := itotal + nodeSize(fun) --fun slot is ($ . function) - vtotal := vtotal + nodeSize(2 * latch) --latch slot is (newGoGet $ . code) - --NOTE: lazy slots require no cost --lazy slot is lazyDomainForm - if null quiet then sayBrightly ['"domain size = ",vtotal,'" BYTES"] - etotal := nodeSize(fun + 2 * latch) + vectorSize(1 + maxindex) - if null quiet then sayBrightly ['"cost per instantiation = ",etotal,'" BYTES"] - vtotal - -dcSizeAll() == - count := 0 - total := 0 - for x in allConstructors() | null atom GETL(x,'infovec) repeat - count := count + 1 - s := dcSize(x,'quiet) - sayBrightly [s,'" : ",x] - total := total + s - sayBrightly '"------------total-------------" - sayBrightly [count," constructors; ",total," BYTES"] - -sum(:l) == +/l - -nodeSize(n) == 12 * n - -vectorSize(n) == 4 * (1 + n) - -halfWordSize(n) == - n < 128 => n / 2 - n < 256 => n - 2 * n - -numberOfNodes(x) == - atom x => 0 - 1 + numberOfNodes first x + numberOfNodes rest x - -template con == - con := abbreviation? con or con - ppTemplate (getInfovec con).0 - -ppTemplate vec == - for i in 0..MAXINDEX vec repeat - sayBrightlyNT bright i - pp vec.i - -infovec con == - con := abbreviation? con or con - u := getInfovec con - sayBrightly '"---------------slot 0 is template-------------------" - ppTemplate u.0 - sayBrightly '"---------------slot 1 is op table-------------------" - PRINT_-FULL u.1 - sayBrightly '"---------------slot 2 is attribute list-------------" - PRINT_-FULL u.2 - sayBrightly '"---------------slot 3.0 is catpredvec---------------" - PRINT_-FULL u.3.0 - sayBrightly '"---------------slot 3.1 is catinfovec---------------" - PRINT_-FULL u.3.1 - sayBrightly '"---------------slot 3.2 is catvec-------------------" - PRINT_-FULL u.3.2 - sayBrightly '"---------------tail of slot 3 is datavector---------" - dcData1 CDDDR u.3 - 'done - -dcAll con == - con := abbreviation? con or con - $infovec : local := getInfovec con - complete? := - #$infovec = 4 => false - $infovec.4 = 'lookupComplete - sayBrightly '"----------------Template-----------------" - dcSlots con - sayBrightly - complete? => '"----------Complete Ops----------------" - '"----------Incomplete Ops---------------" - dcOpTable con - sayBrightly '"----------------Atts-----------------" - dcAtts con - sayBrightly '"----------------Preds-----------------" - dcPreds con - sayBrightly '"----------------Cats-----------------" - dcCats con - sayBrightly '"----------------Data------------------" - dcData con - sayBrightly '"----------------Size------------------" - dcSize(con,'full) - 'done - -dcOps conname == - for [op,:u] in REVERSE getOperationAlistFromLisplib conname repeat - for [sig,slot,pred,key,:.] in u repeat - suffix := - atom pred => nil - concat('" if ",pred2English pred) - key = 'Subsumed => - sayBrightly [:formatOpSignature(op,sig),'" subsumed by ",:formatOpSignature(op,slot),:suffix] - sayBrightly [:formatOpSignature(op,sig),:suffix] - ---======================================================================= --- Compute the lookup function (complete or incomplete) ---======================================================================= -NRTgetLookupFunction(domform,exCategory,addForm) == - domform := SUBLIS($pairlis,domform) - addForm := SUBLIS($pairlis,addForm) - $why: local := nil - atom addForm => 'lookupComplete - extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) - if null extends then - [u,msg,:v] := $why - sayBrightly '"--------------non extending category----------------------" - sayBrightlyNT ['"..",:bright form2String domform,"of cat "] - PRINT u - sayBrightlyNT bright msg - if v then PRINT CAR v else TERPRI() - extends => 'lookupIncomplete - 'lookupComplete - -getExportCategory form == - [op,:argl] := form - op = 'Record => ['RecordCategory,:argl] - op = 'Union => ['UnionCategory,:argl] - functorModemap := GETDATABASE(op,'CONSTRUCTORMODEMAP) - [[.,target,:tl],:.] := functorModemap - EQSUBSTLIST(argl,$FormalMapVariableList,target) - -NRTextendsCategory1(domform,exCategory,addForm) == - addForm is ['Tuple,:r] => - and/[extendsCategory(domform,exCategory,x) for x in r] - extendsCategory(domform,exCategory,addForm) - ---======================================================================= --- Compute if a domain constructor is forgetful functor ---======================================================================= -extendsCategory(dom,u,v) == - --does category u extend category v (yes iff u contains everything in v) - --is dom of category u also of category v? - u=v => true - v is ["Join",:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["CATEGORY",.,:l] => and/[extendsCategory(dom,u,x) for x in l] - v is ["SubsetCategory",cat,d] => extendsCategory(dom,u,cat) and isSubset(dom,d,$e) - v := substSlotNumbers(v,$template,$functorForm) - extendsCategoryBasic0(dom,u,v) => true - $why := - v is ['SIGNATURE,op,sig] => [u,['" has no ",:formatOpSignature(op,sig)]] - [u,'" has no",v] - nil - -extendsCategoryBasic0(dom,u,v) == - v is ['IF,p,['ATTRIBUTE,c],.] => - uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr - null atom c and isCategoryForm(c,nil) => - slot4 := uVec.4 - LASSOC(c,CADR slot4) is [=p,:.] - slot2 := uVec.2 - LASSOC(c,slot2) is [=p,:.] - extendsCategoryBasic(dom,u,v) - -extendsCategoryBasic(dom,u,v) == - u is ["Join",:l] => or/[extendsCategoryBasic(dom,x,v) for x in l] - u = v => true - uVec := (compMakeCategoryObject(u,$EmptyEnvironment)).expr - isCategoryForm(v,nil) => catExtendsCat?(u,v,uVec) - v is ['SIGNATURE,op,sig] => - or/[uVec.i is [[=op,=sig],:.] for i in 6..MAXINDEX uVec] - u is ['CATEGORY,.,:l] => - v is ['IF,:.] => member(v,l) - nil - nil - -catExtendsCat?(u,v,uvec) == - u = v => true - uvec := uvec or (compMakeCategoryObject(u,$EmptyEnvironment)).expr - slot4 := uvec.4 - prinAncestorList := CAR slot4 - member(v,prinAncestorList) => true - vOp := KAR v - if similarForm := assoc(vOp,prinAncestorList) then - PRINT u - sayBrightlyNT '" extends " - PRINT similarForm - sayBrightlyNT '" but not " - PRINT v - or/[catExtendsCat?(x,v,nil) for x in ASSOCLEFT CADR slot4] - -substSlotNumbers(form,template,domain) == - form is [op,:.] and - MEMQ(op,allConstructors()) => expandType(form,template,domain) - form is ['SIGNATURE,op,sig] => - ['SIGNATURE,op,[substSlotNumbers(x,template,domain) for x in sig]] - form is ['CATEGORY,k,:u] => - ['CATEGORY,k,:[substSlotNumbers(x,template,domain) for x in u]] - expandType(form,template,domain) - -expandType(lazyt,template,domform) == - atom lazyt => expandTypeArgs(lazyt,template,domform) - [functorName,:argl] := lazyt - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,expandTypeArgs(dom,template,domform)] - for [.,tag,dom] in argl]] - lazyt is ['local,x] => - n := POSN1(x,$FormalMapVariableList) - ELT(domform,1 + n) - [functorName,:[expandTypeArgs(a,template,domform) for a in argl]] - -expandTypeArgs(u,template,domform) == - u = '$ => u --template.0 -------eliminate this as $ is rep by 0 - INTEGERP u => expandType(templateVal(template, domform, u), template,domform) - u is ['NRTEVAL,y] => y --eval y - u is ['QUOTE,y] => y - atom u => u - expandType(u,template,domform) - -templateVal(template,domform,index) == ---returns a domform or a lazy slot - index = 0 => harhar() --template - template.index - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3