aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog4
-rw-r--r--src/interp/br-con.boot6
-rw-r--r--src/interp/br-util.boot6
-rw-r--r--src/interp/buildom.boot2
-rw-r--r--src/interp/c-doc.boot6
-rw-r--r--src/interp/c-util.boot12
-rw-r--r--src/interp/clam.boot8
-rw-r--r--src/interp/compiler.boot4
-rw-r--r--src/interp/cparse.boot6
-rw-r--r--src/interp/database.boot4
-rw-r--r--src/interp/g-timer.boot18
-rw-r--r--src/interp/i-analy.boot2
-rw-r--r--src/interp/interop.boot30
-rw-r--r--src/interp/lisplib.boot6
-rw-r--r--src/interp/modemap.boot4
-rw-r--r--src/interp/nruncomp.boot2
-rw-r--r--src/interp/nrunfast.boot8
-rw-r--r--src/interp/postpar.boot2
-rw-r--r--src/interp/showimp.boot34
-rw-r--r--src/lisp/core.lisp.in61
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 <gdr@cs.tamu.edu>
+
+ * interp/br-util.boot (dbInfovec): Move to c-util.boot
+
2011-04-25 Gabriel Dos Reis <gdr@cs.tamu.edu>
* 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 -*-
;;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-30 23:00:09 +0000