From 320d0c5d61b2fc8cb6780b9c7e426a76e126307a Mon Sep 17 00:00:00 2001 From: dos-reis Date: Wed, 27 Apr 2011 07:41:49 +0000 Subject: * interp/br-util.boot (dbInfovec): Move to c-util.boot --- src/ChangeLog | 4 ++++ src/interp/br-con.boot | 6 ++--- src/interp/br-util.boot | 6 ----- src/interp/buildom.boot | 2 +- src/interp/c-doc.boot | 6 ++--- src/interp/c-util.boot | 12 +++++++++- src/interp/clam.boot | 8 +++---- src/interp/compiler.boot | 4 ++-- src/interp/cparse.boot | 6 ++--- src/interp/database.boot | 4 ++-- src/interp/g-timer.boot | 18 +++++++------- src/interp/i-analy.boot | 2 +- src/interp/interop.boot | 30 ++++++++++++------------ src/interp/lisplib.boot | 6 ++--- src/interp/modemap.boot | 4 ++-- src/interp/nruncomp.boot | 2 +- src/interp/nrunfast.boot | 8 +++---- src/interp/postpar.boot | 2 +- src/interp/showimp.boot | 34 +++++++++++++-------------- src/lisp/core.lisp.in | 61 ++++++++++++++++++++++++++++++++++++++++++++++++ 20 files changed, 147 insertions(+), 78 deletions(-) diff --git a/src/ChangeLog b/src/ChangeLog index 89b5b8fc..08a35c9e 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2011-04-27 Gabriel Dos Reis + + * interp/br-util.boot (dbInfovec): Move to c-util.boot + 2011-04-25 Gabriel Dos Reis * boot/translator.boot (inAllContexts): New. diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index bcd0f8e1..e7263dbb 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -1060,7 +1060,7 @@ dbShowConsDoc1(htPage,conform,indexOrNil) == [conname,:conargs] := conform symbolMember?(conname,$DomainNames) => conname := htpProperty(htPage,'conname) - [["constructor",["NIL",doc]],:.] := GETL(conname,'documentation) + [["constructor",["NIL",doc]],:.] := property(conname,'documentation) sig := '((CATEGORY domain) (SetCategory) (SetCategory)) displayDomainOp(htPage,'"constructor",conform,conname,sig,true,doc,indexOrNil,'dbSelectCon,nil,nil) exposeFlag := isExposedConstructor conname @@ -1171,7 +1171,7 @@ dbSpecialDescription(conname) == dbSpecialOperations(conname) == page := htInitPage(nil,nil) conform := getConstructorForm conname - opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) + opAlist := dbSpecialExpandIfNecessary(conform,rest property(conname,'documentation)) fromHeading := ['" from domain {\sf ",form2HtString conform,'"}"] htpSetProperty(page,'fromHeading,fromHeading) htpSetProperty(page,'conform,conform) @@ -1183,7 +1183,7 @@ dbSpecialOperations(conname) == dbSpecialExports(conname) == conform := getConstructorForm conname page := htInitPage(['"Exports of {\sf ",form2HtString conform,'"}"],nil) - opAlist := dbSpecialExpandIfNecessary(conform,rest GETL(conname,'documentation)) + opAlist := dbSpecialExpandIfNecessary(conform,rest property(conname,'documentation)) kePageDisplay(page,'"operation",opAlist) htShowPage() diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot index 599584ba..9d8c3ab9 100644 --- a/src/interp/br-util.boot +++ b/src/interp/br-util.boot @@ -516,12 +516,6 @@ nothingFoundPage(:options) == htCopyProplist htPage == [[x,:y] for [x,:y] in htpPropertyList htPage] -dbInfovec name == - "category" = getConstructorKindFromDB name => nil - asharpConstructorFromDB name => nil - loadLibIfNotLoaded(name) - u := GETL(name,'infovec) => u - emptySearchPage(kind,filter,:options) == skipNamePart := IFCAR options heading := ['"No ",capitalize kind,'" Found"] diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot index 4d4322e7..7720c423 100644 --- a/src/interp/buildom.boot +++ b/src/interp/buildom.boot @@ -525,7 +525,7 @@ EnumerationCategory(:"x") == constructorCategory ["Enumeration",:x] UnionCategory(:"x") == constructorCategory ["Union",:x] constructorCategory (title is [op,:.]) == - constructorFunction:= GETL(op,"makeFunctionList") or + constructorFunction:= property(op,"makeFunctionList") or systemErrorHere ['"constructorCategory",title] [funlist,.]:= FUNCALL(constructorFunction,"$",title,$CategoryFrame) oplist:= [[[a,b],true,c] for [a,b,c] in funlist] diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot index c1421308..6353531e 100644 --- a/src/interp/c-doc.boot +++ b/src/interp/c-doc.boot @@ -400,7 +400,7 @@ checkRecordHash u == checkDocError ['"Wrong number of arguments: ",form2HtString key] else if x in '("\spadop" "\keyword") and (u := checkLookForLeftBrace IFCDR u) and (u := IFCDR u) then x := intern checkGetStringBeforeRightBrace u - not (GETL(x,'Led) or GETL(x,'Nud)) => + not (property(x,'Led) or property(x,'Nud)) => checkDocError ['"Unknown \spadop: ",x] u := rest u 'done @@ -1148,7 +1148,7 @@ checkTransformFirsts(opname,u,margin) == strconc('"\spad{",subString(u,0,k + 1),'"}",subString(u,k + 1)) k := checkSkipToken(u,j,m) or return u infixOp := makeSymbol subString(u,j,k - j) - not GETL(infixOp,'Led) => --case 3 + null property(infixOp,'Led) => --case 3 namestring ~= (firstWord := subString(u,0,i)) => checkDocError ['"Improper first word in comments: ",firstWord] u @@ -1170,7 +1170,7 @@ checkTransformFirsts(opname,u,margin) == checkDocError ['"Improper first word in comments: ",firstWord] u prefixOp := makeSymbol subString(u,0,i) - not GETL(prefixOp,'Nud) => + not property(prefixOp,'Nud) => u ---what could this be? j := checkSkipBlanks(u,i,m) or return u u.j = char "(" => --case 4 diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 9cd39a91..f6a0ede4 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -46,12 +46,22 @@ module c_-util where getSuccessEnvironment: (%Form,%Env) -> %Env getInverseEnvironment: (%Form,%Env) -> %Env giveVariableSomeValue: (%Symbol,%Mode,%Env) -> %Env - + -- functor data manipulation + dbInfovec: %Constructor -> %Maybe %FunctorData --% $SetCategory == '(SetCategory) +--% + +dbInfovec name == + getConstructorKindFromDB name is "category" => nil + asharpConstructorFromDB name => nil + loadLibIfNotLoaded(name) + u := property(name,'infovec) => u + nil + --% ++ Token to indicate that a function body should be ignored. diff --git a/src/interp/clam.boot b/src/interp/clam.boot index 7b1a8c81..f6254c1d 100644 --- a/src/interp/clam.boot +++ b/src/interp/clam.boot @@ -331,7 +331,7 @@ clearClams() == clearClam fn clearClam fn == - infovec:= GETL(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) + infovec := property(fn,'cacheInfo) or keyedSystemError("S2GE0003",[fn]) eval infovec.cacheReset reportAndClearClams() == @@ -377,7 +377,7 @@ cacheStats() == sayBrightly ["Unknown cache type for","%b",fn,"%d"] reportCircularCacheStats(fn,n) == - infovec:= GETL(fn,'cacheInfo) + infovec:= property(fn,'cacheInfo) circList:= eval infovec.cacheName numberUsed := +/[1 for i in 1..n for x in circList while x isnt ['_$failed,:.]] @@ -401,7 +401,7 @@ mkCircularCountAlist(cl,len) == al reportHashCacheStats fn == - infovec:= GETL(fn,'cacheInfo) + infovec:= property(fn,'cacheInfo) hashTable:= eval infovec.cacheName hashValues:= [HGET(hashTable,key) for key in HKEYS hashTable] sayBrightly [:bright fn,'"has",:bright(# hashValues),'"values cached."] @@ -486,7 +486,7 @@ assocCacheShiftCount(x,al,fn) == clamStats() == for [op,kind,:.] in $clamList repeat - cacheVec:= GETL(op,'cacheInfo) or systemErrorHere ["clamStats",op] + cacheVec:= property(op,'cacheInfo) or systemErrorHere ["clamStats",op] prefix:= $reportCounts ~= true => nil hitCounter:= INTERNL(op,'";hit") diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 60d1e521..cd75e326 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1866,7 +1866,7 @@ modeEqualSubst(m1,m,e) == --% Categories compCat(form is [functorName,:argl],m,e) == - fn:= GETL(functorName,"makeFunctionList") or return nil + fn := property(functorName,"makeFunctionList") or return nil diagnoseUnknownType(form,e) [funList,e]:= FUNCALL(fn,form,form,e) catForm:= @@ -2257,7 +2257,7 @@ compReduce1(form is ["REDUCE",op,.,collectForm],m,e,$formalArgList) == ++ returns the identity element of the `reduction' operation `x' ++ over a list -- a monoid homomorphism. getIdentity(x,e) == - GETL(x,"THETA") is [y] => + property(x,"THETA") is [y] => y = 0 => $Zero y = 1 => $One -- The empty list should be indicated by name, not by its diff --git a/src/interp/cparse.boot b/src/interp/cparse.boot index 010c84e4..0c8465fd 100644 --- a/src/interp/cparse.boot +++ b/src/interp/cparse.boot @@ -108,7 +108,7 @@ npPush x == ++ name on the parsing tree stack, otherwise treat the token ++ has a name. npPushId() == - a := GETL($ttok,'INFGENERIC) + a := property($ttok,'INFGENERIC) $ttok := if a then a else $ttok $stack := [tokConstruct("id",$ttok,tokPosn $stok),:$stack] npNext() @@ -296,8 +296,8 @@ npLeftAssoc(operations,parser) == ++ Parse an infix operator name. npInfixOp() == - $stok.first.first = "key" and - GETL($ttok,"INFGENERIC") and npPushId() + $stok.first.first is "key" and + property($ttok,"INFGENERIC") and npPushId() ++ Parse an infix operator, either quoted or backquoted. npInfixOperator() == diff --git a/src/interp/database.boot b/src/interp/database.boot index 05a3e845..1286a98a 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -113,7 +113,7 @@ getDualSignatureFromDB: %Constructor -> %Form getDualSignatureFromDB ctor == GETDATABASE(ctor,"COSIG") -getConstructorPredicatesFromDB: %Constructor -> %Thing +getConstructorPredicatesFromDB: %Constructor -> %List %Thing getConstructorPredicatesFromDB ctor == GETDATABASE(ctor,"PREDICATES") @@ -642,7 +642,7 @@ updateDatabase(fname,cname,systemdir?) == if oldFname := getConstructorAbbreviationFromDB cname then clearClams() clearAllSlams [] - if GETL(cname, 'LOADED) then + if property(cname, 'LOADED) then clearConstructorCaches() if $forceDatabaseUpdate or not systemdir? then clearClams() diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot index 26221309..4abb299a 100644 --- a/src/interp/g-timer.boot +++ b/src/interp/g-timer.boot @@ -45,9 +45,9 @@ printTimeIfTrue := false $printStorageIfTrue := false printNamedStatsByProperty(listofnames, prop) == - total := +/[GETL(name,prop) for [name,:.] in listofnames] + total := +/[property(name,prop) for [name,:.] in listofnames] for [name,:.] in listofnames repeat - n := GETL(name, prop) + n := property(name, prop) strname := STRINGIMAGE name strval := STRINGIMAGE n sayBrightly concat(bright strname, @@ -60,12 +60,12 @@ makeLongStatStringByProperty _ (listofnames, listofclasses, prop, classprop, units, flag) == total := 0 str := '"" - otherStatTotal := GETL('other, prop) + otherStatTotal := property('other, prop) for [name,class,:ab] in listofnames repeat name = 'other => 'iterate cl := first LASSOC(class,listofclasses) - n := GETL( name, prop) - PUT(cl,classprop, n + GETL(cl,classprop)) + n := property(name, prop) + PUT(cl,classprop, n + property(cl,classprop)) total := total + n if n >= 0.01 then timestr := normalizeStatAndStringify n @@ -80,12 +80,12 @@ makeLongStatStringByProperty _ total := total + otherStatTotal cl := first symbolLassoc('other,listofnames) cl := first LASSOC(cl,listofclasses) - PUT(cl,classprop, otherStatTotal + GETL(cl,classprop)) + PUT(cl,classprop, otherStatTotal + property(cl,classprop)) if flag ~= 'long then total := 0 str := '"" for [class,name,:ab] in listofclasses repeat - n := GETL(name, classprop) + n := property(name, classprop) n = 0.0 => 'iterate total := total + n timestr := normalizeStatAndStringify n @@ -199,7 +199,7 @@ initializeTimedNames(listofnames,listofclasses) == NIL updateTimedName name == - count := (GETL(name,'TimeTotal) or 0) + computeElapsedTime() + count := (property(name,'TimeTotal) or 0) + computeElapsedTime() PUT(name,'TimeTotal, count) printNamedStats listofnames == @@ -225,7 +225,7 @@ computeElapsedTime() == gcDelta := currentGCTime - $oldElapsedGCTime elapsedSeconds:= 1.* (currentTime-$oldElapsedTime-gcDelta)/$timerTicksPerSecond - PUT('gc, 'TimeTotal,GETL('gc,'TimeTotal) + + PUT('gc, 'TimeTotal,property('gc,'TimeTotal) + 1.*QUOTIENT(gcDelta,$timerTicksPerSecond)) $oldElapsedTime := elapsedUserTime() $oldElapsedGCTime := elapsedGcTime() diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot index 7a404c41..c1bdf82c 100644 --- a/src/interp/i-analy.boot +++ b/src/interp/i-analy.boot @@ -243,7 +243,7 @@ bottomUp t == -- call a special handler if we are not being package called dol := getAtree(op,'dollar) and (opName ~= 'construct) - (null dol) and (fn:= GETL(opName,"up")) and (u:= FUNCALL(fn, t)) => u + (null dol) and (fn:= property(opName,"up")) and (u:= FUNCALL(fn, t)) => u nargs := #argl if opName then for x in argl for i in 1.. repeat putCallInfo(x,opName,i,nargs) diff --git a/src/interp/interop.boot b/src/interp/interop.boot index 27ce88d8..8ce949d9 100644 --- a/src/interp/interop.boot +++ b/src/interp/interop.boot @@ -337,7 +337,7 @@ instantiate domenv == callForm := second domenv oldDom := CDDR domenv [functor,:args] := callForm --- if null(fn := GETL(functor,'instantiate)) then +-- if null(fn := property(functor,'instantiate)) then -- ofn := symbolFunction functor -- loadFunctor functor -- fn := symbolFunction functor @@ -458,15 +458,15 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == '"----> searching op table for:","%l"," "),op,sig,dollar) someMatch := false numvec := getDomainByteVector domain - predvec := domain.3 + predvec := vectorRef(domain,3) max := maxIndex opvec k := getOpCode(op,opvec,max) or return flag => newLookupInAddChain(op,sig,domain,dollar) nil idxmax := maxIndex numvec - start := opvec.k + start := vectorRef(opvec,k) finish := - QSGREATERP(max,k) => opvec.(QSPLUS(k,2)) + QSGREATERP(max,k) => vectorRef(opvec,QSPLUS(k,2)) idxmax if QSGREATERP(finish,idxmax) then systemError '"limit too large" numArgs := if hashCode? sig then -1 else (#sig)-1 @@ -477,27 +477,27 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == while finish > start repeat PROGN i := start - numTableArgs :=numvec.i - predIndex := numvec.(i := i + 1) + numTableArgs := arrayRef(numvec,i) + predIndex := arrayRef(numvec,i := i + 1) (predIndex ~= 0) and null testBitVector(predvec,predIndex) => nil exportSig := [newExpandTypeSlot(numvec.(i + j + 1), dollar,domain) for j in 0..numTableArgs] sig ~= hashType(['Mapping,: exportSig],hashPercent) => nil --signifies no match - loc := numvec.(i + numTableArgs + 2) + loc := arrayRef(numvec,i + numTableArgs + 2) loc = 1 => (someMatch := true) loc = 0 => start := QSPLUS(start,QSPLUS(numTableArgs,4)) i := start + 2 someMatch := true --mark so that if subsumption fails, look for original subsumptionSig := - [newExpandTypeSlot(numvec.(QSPLUS(i,j)), + [newExpandTypeSlot(arrayRef(numvec,QSPLUS(i,j)), dollar,domain) for j in 0..numTableArgs] if $monitorNewWorld then sayBrightly [formatOpSignature(op,sig),'"--?-->", formatOpSignature(op,subsumptionSig)] nil - slot := domain.loc + slot := vectorRef(domain,loc) cons? slot => slot.op = 'newGoGet => someMatch:=true --treat as if operation were not there @@ -506,7 +506,7 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot rest slot), -- if domain.loc = 'skip then domain.loc := slot) return (success := slot) - slot = 'skip => --recursive call from above 'replaceGoGetSlot + slot is 'skip => --recursive call from above 'replaceGoGetSlot return (success := newLookupInAddChain(op,sig,domain,dollar)) systemError '"unexpected format" start := QSPLUS(start,QSPLUS(numTableArgs,4)) @@ -521,7 +521,7 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == nil hashNewLookupInCategories(op,sig,dom,dollar) == - slot4 := dom.4 + slot4 := vectorRef(dom,4) catVec := second slot4 # catVec = 0 => nil --early exit if no categories integer? KDR catVec.0 => @@ -533,7 +533,7 @@ hashNewLookupInCategories(op,sig,dom,dollar) == packageVec := first slot4 --the next three lines can go away with new category world varList := ['$,:$FormalMapVariableList] - valueList := [dom,:[dom.(5+i) for i in 1..(# rest dom.0)]] + valueList := [dom,:[vectorRef(dom,5+i) for i in 1..(# rest dom.0)]] valueList := [MKQ val for val in valueList] nsig := MSUBST(dom.0,dollar.0,sig) for i in 0..maxIndex packageVec | @@ -546,8 +546,8 @@ hashNewLookupInCategories(op,sig,dom,dollar) == IDENTP entry => cat := catVec.i packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) + if not property(entry,'LOADED) then loadLib entry + infovec := property(entry,'infovec) success := --vector? infovec => ----new world true => ----new world @@ -558,7 +558,7 @@ hashNewLookupInCategories(op,sig,dom,dollar) == byteVector := CDDDR infovec.3 endPos := code+2 > max => # byteVector - opvec.(code+2) + vectorRef(opvec,code+2) --not nrunNumArgCheck(#sig.source,byteVector,opvec.code,endPos) => nil --numOfArgs := byteVector.(opvec.code) --numOfArgs ~= #sig.source => nil diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 2f34523b..a91b5d1d 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -302,7 +302,7 @@ loadLibIfNotLoaded libName == -- replaces old SpadCondLoad -- loads is library is not already loaded $PrintOnly => NIL - GETL(libName,'LOADED) => NIL + property(libName,'LOADED) => NIL loadLib libName loadLib cname == @@ -364,7 +364,7 @@ loadLibIfNecessary(u,mustExist) == cons? u => loadLibIfNecessary(first u,mustExist) value:= functionp(u) or macrop(u) => u - GETL(u,'LOADED) => u + property(u,'LOADED) => u loadLib u => u null $InteractiveMode and ((null (y:= getProplist(u,$CategoryFrame))) or (null symbolLassoc('isFunctor,y)) and (null symbolLAssoc('isCategory,y))) => @@ -428,7 +428,7 @@ autoLoad(abb,cname) == -- builtin constructors are always loaded. By definition, there -- is no way to unload them and load them again. cname in $BuiltinConstructorNames => cname - if not GETL(cname,'LOADED) then loadLib cname + if not property(cname,'LOADED) then loadLib cname symbolFunction cname setAutoLoadProperty(name) == diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index 5197dfae..6d0c700b 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -237,7 +237,7 @@ augModemapsFromDomain(name,functorForm,e) == augModemapsFromDomain1(name,functorForm,e) augModemapsFromDomain1(name,functorForm,e) == - GETL(KAR functorForm,"makeFunctionList") => + property(KAR functorForm,"makeFunctionList") => addConstructorModemaps(name,functorForm,e) atom functorForm and (catform:= getmode(functorForm,e)) => augModemapsFromCategory(name,name,functorForm,catform,e) @@ -345,7 +345,7 @@ substNames(domainName,viewName,functorForm,opalist) == addConstructorModemaps(name,form is [functorName,:.],e) == $InteractiveMode: local:= nil e:= putDomainsInScope(name,e) --frame - fn := GETL(functorName,"makeFunctionList") + fn := property(functorName,"makeFunctionList") [funList,e]:= FUNCALL(fn,name,form,e) for [op,sig,opcode] in funList repeat if opcode is [sel,dc,n] and sel='ELT then diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 75e58532..1f014733 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -419,7 +419,7 @@ stuffSlot(dollar,i,item) == stuffDomainSlots dollar == domname := devaluate dollar - infovec := GETL(opOf domname,'infovec) + infovec := property(opOf domname,'infovec) lookupFunction := getLookupFun infovec lookupFunction := lookupFunction is 'lookupIncomplete => function lookupIncomplete diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index 40df2592..fe17142e 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -325,8 +325,8 @@ newLookupInCategories(op,sig,dom,dollar) == IDENTP entry => cat := vectorRef(catVec,i) packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) + if not property(entry,'LOADED) then loadLib entry + infovec := property(entry,'infovec) success := --vector? infovec => ----new world true => ----new world @@ -404,8 +404,8 @@ newLookupInCategories1(op,sig,dom,dollar) == IDENTP entry => cat := first node packageForm := nil - if not GETL(entry,'LOADED) then loadLib entry - infovec := GETL(entry,'infovec) + if not property(entry,'LOADED) then loadLib entry + infovec := property(entry,'infovec) success := vector? infovec => opvec := infovec.1 diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot index ba65872b..bc519adf 100644 --- a/src/interp/postpar.boot +++ b/src/interp/postpar.boot @@ -83,7 +83,7 @@ postTran x == atom x => postAtom x op := first x - symbol? op and (f:= GETL(op,'postTran)) => FUNCALL(f,x) + symbol? op and (f:= property(op,'postTran)) => FUNCALL(f,x) op is ["elt",a,b] => u:= postTran [b,:rest x] [postTran op,:rest u] diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot index 1adb4179..5fcfc582 100644 --- a/src/interp/showimp.boot +++ b/src/interp/showimp.boot @@ -52,15 +52,15 @@ showImp(dom,:options) == domainForm := devaluate dom [nam,:$domainArgs] := domainForm $predicateList: local := getConstructorPredicatesFromDB nam - predVector := dom.3 + predVector := vectorRef(dom,3) u := getDomainOpTable(dom,true) --sort into 4 groups: domain exports, unexports, default exports, others for (x := [.,.,:key]) in u repeat key = domainForm => domexports := [x,:domexports] integer? key => unexports := [x,:unexports] isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant => constants := [x,:constants] + key is 'nowhere => nowheres := [x,:nowheres] + key is 'constant => constants := [x,:constants] others := [x,:others] --add chain domains go here sayBrightly nowheres => ['"Functions exported but not implemented by", @@ -209,8 +209,8 @@ getDomainSeteltForm ['%store,.,form] == showPredicates dom == sayBrightly '"--------------------Predicate summary-------------------" - conname := first dom.0 - predvector := dom.3 + conname := vectorRef(dom,0).op + predvector := vectorRef(dom,3) predicateList := getConstructorPredicatesFromDB conname for i in 1.. for p in predicateList repeat prefix := @@ -220,22 +220,22 @@ showPredicates dom == showAttributes dom == sayBrightly '"--------------------Attribute summary-------------------" - conname := first dom.0 + conname := vectorRef(dom,0).op abb := getConstructorAbbreviation conname - predvector := dom.3 - for [a,:p] in dom.2 repeat + predvector := vectorRef(dom,3) + for [a,:p] in vectorRef(dom,2) repeat prefix := testBitVector(predvector,p) => '"true : " '"false: " sayBrightly concat(prefix,form2String a) showGoGet dom == - numvec := CDDR dom.4 - for i in 6..maxIndex dom | (slot := dom.i) is ['newGoGet,dol,index,:op] repeat - numOfArgs := numvec.index - whereNumber := numvec.(index := index + 1) + numvec := CDDR vectorRef(dom,4) + for i in 6..maxIndex dom | (slot := vectorRef(dom,i)) is ['newGoGet,dol,index,:op] repeat + numOfArgs := arrayRef(numvec,index) + whereNumber := arrayRef(numvec,index := index + 1) signumList := - [formatLazyDomainForm(dom,numvec.(index + i)) for i in 0..numOfArgs] + [formatLazyDomainForm(dom,arrayRef(numvec,index + i)) for i in 0..numOfArgs] index := index + numOfArgs + 1 namePart := concat(bright "from",form2String formatLazyDomainForm(dom,whereNumber)) @@ -300,12 +300,12 @@ dcOpLatchPrint(op,index) == sayBrightly ['"latch",:formatOpSignature(op,signumList),:namePart] getInfovec name == - u := GETL(name,'infovec) => u - GETL(name,'LOADED) => nil + u := property(name,'infovec) => u + property(name,'LOADED) => nil fullLibName := getConstructorModuleFromDB name or return nil startTimingProcess 'load loadLibNoUpdate(name, name, fullLibName) - GETL(name,'infovec) + property(name,'infovec) getOpSegment index == numOfArgs := (vec := getCodeVector()).index @@ -517,7 +517,7 @@ dcSize(:options) == dcSizeAll() == count := 0 total := 0 - for x in allConstructors() | cons? GETL(x,'infovec) repeat + for x in allConstructors() | cons? property(x,'infovec) repeat count := count + 1 s := dcSize(x,'quiet) sayBrightly [s,'" : ",x] diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in index 4c06f25c..e9765261 100644 --- a/src/lisp/core.lisp.in +++ b/src/lisp/core.lisp.in @@ -89,6 +89,17 @@ "%Form" "%Triple" "%Shell" + ;; functor data structures + "%FunctorData" + "%FunctorCoreData" + "%FunctorBytecode" + "%FunctorTemplate" + "%FunctorPredicateIndexTable" + "%FunctorOperatorDirectory" + "%FunctorCategoryTable" + "%FunctorAttributeTable" + "%FunctorDefaultTable" + "%FunctorLookupFunction" "coreQuit" "fatalError" @@ -228,6 +239,56 @@ (deftype |%Triple| () '(cons |%Code| (cons |%Mode| (cons |%Env| null)))) +;; Functor templates +(deftype |%FunctorTemplate| () + 'simple-vector) + +;; operator directory for functors. +(deftype |%FunctorOperatorDirectory| () + '(simple-array (or symbol fixnum))) + +;; List of (attribute . predicate-index) pairs for functors. +(deftype |%FunctorAttributeTable| () + 'list) + +;; Lookup-function for functors. For most functors, they are +;; either lookupIncomplete or lookupComplete. +;; Historical functors have lookupInTable. +(deftype |%FunctorLookupFunction| () + '|%Symbol|) + +;; Functor predicate index table +(deftype |%FunctorPredicateIndexTable| () + '(simple-array fixnum)) + +;; vector of categories a functor instantiation may belong to. +(deftype |%FunctorCategoryTable| () + '(simple-array |%Form|)) + +;; vector of default category packages that a functor may implicitly use. +(deftype |%FunctorDefaultTable| () + '(simple-array (|%Maybe| |%Constructor|))) + +;; sequence of `byte codes' for a functor +(deftype |%FunctorBytecode| () + '(simple-array fixnum)) + +;; PredicateIndex + DefaultTable + CategoryTable + Bytecode +(deftype |%FunctorCoreData| () + '(cons |%FunctorPredicateIndexTable| + (cons |%FunctorDefaultTable| + (cons |%FunctorCategoryTable| |%FunctorBytecode|)))) + + +;; The essential of what is needed to instantiate a functor. +;; This is the type of `infovec' properties of functors. +(deftype |%FunctorData| () + '(cons |%FunctorTemplate| + (cons |%FunctorOperatorDirectory| + (cons |%FunctorAttributeTable| + (cons |%Thing| + (cons |%FunctorLookupFunction| null)))))) + ;; ;; -*- Configuration Constants -*- ;; -- cgit v1.2.3