aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/boot/strap/tokens.clisp1
-rw-r--r--src/boot/tokens.boot3
-rw-r--r--src/interp/buildom.boot85
-rw-r--r--src/interp/c-util.boot11
-rw-r--r--src/interp/category.boot2
-rw-r--r--src/interp/g-opt.boot2
-rw-r--r--src/interp/i-analy.boot2
-rw-r--r--src/interp/i-syscmd.boot4
-rw-r--r--src/interp/interop.boot4
-rw-r--r--src/interp/nrunfast.boot12
-rw-r--r--src/interp/nrungo.boot2
-rw-r--r--src/interp/nrunopt.boot2
12 files changed, 67 insertions, 63 deletions
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 6888f321..3b5694f7 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -244,6 +244,7 @@
(LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T)
(LIST '|upperCase?| 'UPPER-CASE-P)
(LIST '|vector?| 'SIMPLE-VECTOR-P)
+ (LIST '|vectorRef| 'SVREF)
(LIST '|writeByte| 'WRITE-BYTE)
(LIST '|writeLine| 'WRITE-LINE) (LIST 'PLUS '+)
(LIST 'MINUS '-) (LIST 'TIMES '*) (LIST 'POWER 'EXPT)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 9647e0e5..dd46d89b 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -1,6 +1,6 @@
-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
--- Copyright (C) 2007-2010, Gabriel Dos Reis.
+-- Copyright (C) 2007-2011, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
@@ -307,6 +307,7 @@ for i in [ _
["true", "T"] , _
["upperCase?", "UPPER-CASE-P"], _
["vector?", "SIMPLE-VECTOR-P"], _
+ ["vectorRef", "SVREF"] , _
["writeByte", "WRITE-BYTE"], _
["writeLine", "WRITE-LINE"], _
["PLUS", "+"] , _
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index d885b1c1..2f08bc29 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -85,23 +85,24 @@ Record(:args) ==
nargs := #args
dom := newShell(nargs + 10)
-- JHD added an extra slot to cache EQUAL methods
- dom.0 := ["Record", :srcArgs]
- dom.1 :=
+ vectorRef(dom,0) := ["Record", :srcArgs]
+ vectorRef(dom,1) :=
["lookupInTable",dom,
[["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
["~=",[[$Boolean,"$","$"],:0]],
["hash",[[$SingleInteger,"$"],:0]],
["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]]
- dom.2 := nil
- dom.3 := ["RecordCategory",:rest dom.0]
- dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := nil
- for i in $FirstParamSlot.. for a in args repeat dom.i := third a
- dom.($FirstParamSlot + nargs) := [function RecordEqual, :dom]
- dom.($FirstParamSlot + nargs + 1) := [function RecordPrint, :dom]
- dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+ vectorRef(dom,2) := nil
+ vectorRef(dom,3) := ["RecordCategory",:rest dom.0]
+ vectorRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors]
+ vectorRef(dom,5) := nil
+ for i in $FirstParamSlot.. for a in args repeat
+ vectorRef(dom,i) := third a
+ vectorRef(dom,$FirstParamSlot + nargs) := [function RecordEqual, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 1) := [function RecordPrint, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom]
-- following is cache for equality functions
- dom.($FirstParamSlot + nargs + 3) := if nargs <= 2
+ vectorRef(dom,$FirstParamSlot + nargs + 3) := if nargs <= 2
then [nil,:nil]
else newShell nargs
-- remember this instantiation for future re-use.
@@ -160,26 +161,27 @@ Union(:args) ==
"domainEqualList") => CDRwithIncrement t
nargs := #args
dom := newShell (nargs + 9)
- dom.0 := ["Union", :srcArgs]
- dom.1 :=
+ vectorRef(dom,0) := ["Union", :srcArgs]
+ vectorRef(dom,1) :=
["lookupInTable",dom,
[["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
["~=",[[$Boolean,"$","$"],:0]],
["hash", [[$SingleInteger,"$"],:0]],
["coerce",[[$OutputForm,"$"],:oldSlotCode (nargs+1)]]]]
- dom.2 := nil
- dom.3 := ["UnionCategory",:rest dom.0]
- dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := nil
- for i in $FirstParamSlot.. for a in args repeat dom.i := a
- dom.($FirstParamSlot + nargs) := [function UnionEqual, :dom]
- dom.($FirstParamSlot + nargs + 1) := [function UnionPrint, :dom]
- dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+ vectorRef(dom,2) := nil
+ vectorRef(dom,3) := ["UnionCategory",:rest dom.0]
+ vectorRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors]
+ vectorRef(dom,5) := nil
+ for i in $FirstParamSlot.. for a in args repeat
+ vectorRef(dom,i) := a
+ vectorRef(dom,$FirstParamSlot + nargs) := [function UnionEqual, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 1) := [function UnionPrint, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom]
haddProp($ConstructorCache,"Union",srcArgs,[1,:dom])
dom
UnionEqual(x, y, dom) ==
- ["Union",:branches] := dom.0
+ ["Union",:branches] := vectorRef(dom,0)
predlist := mkPredList branches
same := false
for b in stripUnionTags branches for p in predlist while not same repeat
@@ -216,21 +218,22 @@ Mapping(:args) ==
"domainEqualList") => CDRwithIncrement t
nargs := #args
dom := newShell(nargs + 9)
- dom.0 := ["Mapping", :srcArgs]
- dom.1 :=
+ vectorRef(dom,0) := ["Mapping", :srcArgs]
+ vectorRef(dom,1) :=
["lookupInTable",dom,
[["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
["~=",[[$Boolean,"$","$"],:0]],
["hash", [[$SingleInteger,"$"],:0]],
["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs + 1)]]]]
- dom.2 := nil
- dom.3 := $SetCategory
- dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := nil
- for i in $FirstParamSlot.. for a in args repeat dom.i := a
- dom.($FirstParamSlot + nargs) := [function MappingEqual, :dom]
- dom.($FirstParamSlot + nargs + 1) := [function MappingPrint, :dom]
- dom.($FirstParamSlot + nargs + 2) := [function Undef, :dom]
+ vectorRef(dom,2) := nil
+ vectorRef(dom,3) := $SetCategory
+ vectorRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors]
+ vectorRef(dom,5) := nil
+ for i in $FirstParamSlot.. for a in args repeat
+ vectorRef(dom,i) := a
+ vectorRef(dom,$FirstParamSlot + nargs) := [function MappingEqual, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 1) := [function MappingPrint, :dom]
+ vectorRef(dom,$FirstParamSlot + nargs + 2) := [function Undef, :dom]
haddProp($ConstructorCache,"Mapping",srcArgs,[1,:dom])
dom
@@ -252,8 +255,8 @@ Enumeration(:"args") ==
nargs := #args
dom := newShell(nargs + 9)
-- JHD added an extra slot to cache EQUAL methods
- dom.0 := ["Enumeration", :args]
- dom.1 :=
+ vectorRef(dom,0) := ["Enumeration", :args]
+ vectorRef(dom,1) :=
["lookupInTable",dom,
[["=",[[$Boolean,"$","$"],:oldSlotCode nargs]],
["~=",[[$Boolean,"$","$"],:0]],
@@ -261,10 +264,10 @@ Enumeration(:"args") ==
["coerce",[[$OutputForm,"$"],:oldSlotCode(nargs+1)],
[["$", $Symbol], :oldSlotCode(nargs+2)]]
]]
- dom.2 := nil
- dom.3 := ["EnumerationCategory",:rest dom.0]
- dom.4 := [$commonCategoryDefaults, $commonCategoryAncestors]
- dom.5 := nil
+ vectorRef(dom,2) := nil
+ vectorRef(dom,3) := ["EnumerationCategory",:rest dom.0]
+ vectorRef(dom,4) := [$commonCategoryDefaults, $commonCategoryAncestors]
+ vectorRef(dom,5) := nil
for i in $FirstParamSlot.. for a in args repeat dom.i := a
dom.($FirstParamSlot + nargs) := [function EnumEqual, :dom]
dom.($FirstParamSlot + nargs + 1) := [function EnumPrint, :dom]
@@ -276,10 +279,10 @@ EnumEqual(e1,e2,dom) ==
e1=e2
EnumPrint(enum, dom) ==
- (rest(dom.0)).enum
+ rest(vectorRef(dom,0)).enum
createEnum(sym, dom) ==
- args := rest(dom.0)
+ args := vectorRef(dom,0).args
val := -1
for v in args for i in 0.. repeat
sym=v => return(val:=i)
@@ -302,7 +305,7 @@ constructorCategory (title is [op,:.]) ==
cat:=
JoinInner([eval $SetCategory,mkCategory("domain",oplist,nil,nil,nil)],
$EmptyEnvironment)
- cat.0 := title
+ vectorRef(cat,0) := title
cat
--mkMappingFunList(nam,mapForm,e) == [[],e]
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index cfb68f21..08bfb572 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -179,10 +179,9 @@ declareUnusedParameters x == (augment x; x) where
devaluate d ==
not vector? d => d
- QSGREATERP(QVSIZE d,5) and getShellEntry(d,3) is ['Category] =>
- getShellEntry(d,0)
- QSGREATERP(QVSIZE d,0) =>
- d':=getShellEntry(d,0)
+ QVSIZE d > 5 and vectorRef(d,3) is ['Category] => vectorRef(d,0)
+ QVSIZE d > 0 =>
+ d' := vectorRef(d,0)
isFunctor d' => d'
d
d
@@ -1629,7 +1628,7 @@ expandFormTemplate(shell,args,slot) ==
integer? slot =>
slot = 0 => "$"
slot = 2 => "$$"
- expandFormTemplate(shell,args,getShellEntry(shell,slot))
+ expandFormTemplate(shell,args,vectorRef(shell,slot))
atom slot => slot
slot is ["local",parm] and (n := isFormal parm) =>
args.n -- FIXME: we should probably expand with dual signature
@@ -1645,7 +1644,7 @@ equalFormTemplate(shell,args,slot,form) ==
integer? slot =>
slot = 0 => form = "$"
slot = 2 => form = "$$"
- equalFormTemplate(shell,args,getShellEntry(shell,slot),form)
+ equalFormTemplate(shell,args,vectorRef(shell,slot),form)
slot is ["local",parm] and (n := isFormal parm) =>
equalFormTemplate(shell,args,args.n,form)
slot is ["NTREVAL",val] => form = val
diff --git a/src/interp/category.boot b/src/interp/category.boot
index 4d873c5b..e788700f 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -48,7 +48,7 @@ $NewCatVec := nil
++ Returns true if `a' is a category (runtime) object.
isCategory: %Thing -> %Boolean
isCategory a ==
- vector? a and #a > 5 and getShellEntry(a,3) = $Category
+ vector? a and #a > 5 and vectorRef(a,3) = $Category
++ Return true if the form `x' designates an instantiaion of a
++ category constructor known to the global database or the
diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot
index 369a43bb..993f928c 100644
--- a/src/interp/g-opt.boot
+++ b/src/interp/g-opt.boot
@@ -435,7 +435,7 @@ optQSMINUS u ==
++ List of VM side effect free operators.
$VMsideEffectFreeOperators ==
'(CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND
- SPADfirst QVELT _+ _- _* _< _= _<_= _> _>_= ASH INTEGER_-LENGTH
+ SPADfirst _+ _- _* _< _= _<_= _> _>_= ASH INTEGER_-LENGTH
QEQCAR QCDR QCAR IDENTP SYMBOLP
GREATERP ZEROP ODDP FLOAT_-RADIX FLOAT FLOAT_-SIGN
CGREATERP GGREATERP CHAR GET BVEC_-GREATER %when %false %true
diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot
index 6a75ba52..4949f043 100644
--- a/src/interp/i-analy.boot
+++ b/src/interp/i-analy.boot
@@ -195,7 +195,7 @@ pushDownOp?(op,n) ==
numMms := # ops
for [.,targ,:argl] in ops repeat
for arg in argl for i in 0.. repeat
- targ = arg => setShellEntry(sameAsTarg,i,1 + sameAsTarg.i)
+ targ = arg => vectorRef(sameAsTarg,i) := 1 + sameAsTarg.i
-- now see which args have their count = numMms
ok := NIL
for i in 0..(n-1) repeat
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index 66f72f73..e26c256d 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -2080,7 +2080,7 @@ writify ob ==
HPUT($seen, ob, nob)
HPUT($seen, nob, nob)
for i in 0..n repeat
- QSETVELT(nob, i, writifyInner QVELT(ob,i))
+ vectorRef(nob, i) := writifyInner vectorRef(ob,i)
nob
ob = 'WRITIFIED_!_! =>
['WRITIFIED_!_!, 'SELF]
@@ -2223,7 +2223,7 @@ dewritify ob ==
HPUT($seen, ob, nob)
HPUT($seen, nob, nob)
for i in 0..n repeat
- QSETVELT(nob, i, dewritifyInner QVELT(ob,i))
+ vectorRef(nob,i) := dewritifyInner vectorRef(ob,i)
nob
-- Default case: return the object itself.
ob
diff --git a/src/interp/interop.boot b/src/interp/interop.boot
index 2722de20..bd9cf23f 100644
--- a/src/interp/interop.boot
+++ b/src/interp/interop.boot
@@ -578,12 +578,12 @@ newHasCategory(domain,catform) ==
predIndex := lazyMatchAssocV1(catform,catvec,domain)
null predIndex => false
predIndex = 0 => true
- predvec := QVELT(domain,3)
+ predvec := vectorRef(domain,3)
testBitVector(predvec,predIndex)
lazyMatchAssocV(catform,auxvec,catvec,domain) --new style
getCatForm(catvec, index, domain) ==
- integer?(form := QVELT(catvec,index)) => domain.form
+ integer?(form := vectorRef(catvec,index)) => domain.form
form
HasSignature(domain,[op,sig]) ==
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 8a2fa6b8..a9097d17 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -84,7 +84,7 @@ getOpCode(op,vec,max) ==
--search Op vector for "op" returning code if found, nil otherwise
res := nil
for i in 0..max by 2 repeat
- EQ(QVELT(vec,i),op) => return (res := QSADD1 i)
+ EQ(vectorRef(vec,i),op) => return (res := QSADD1 i)
res
evalSlotDomain(u,dollar) ==
@@ -157,7 +157,7 @@ replaceGoGetSlot env ==
keyedSystemError("S2NR0001",[op,sig,goGetDomain.0])
if $monitorNewWorld then
sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain)
- setShellEntry(thisDomain,thisSlot,slot)
+ vectorRef(thisDomain,thisSlot) := slot
if $monitorNewWorld then
sayLooking1('"<------",[first slot,:devaluate rest slot])
slot
@@ -601,7 +601,7 @@ lazyDomainSet(lazyForm,thisDomain,slot) ==
sayLooking1(concat(form2String devaluate thisDomain,
'" activating lazy slot ",slot,'": "),slotDomain)
name := first form
- setShellEntry(thisDomain,slot,slotDomain)
+ vectorRef(thisDomain,slot) := slotDomain
++ Return a type form where all niladic constructors are
@@ -676,13 +676,13 @@ lazyMatchAssocV(x,auxvec,catvec,domain) == --new style slot4
n := MAXINDEX catvec
xop := first x
or/[auxvec.i for i in 0..n |
- xop = first (lazyt := QVELT(catvec,i)) and lazyMatch(x,lazyt,domain,domain)]
+ xop = first (lazyt := vectorRef(catvec,i)) and lazyMatch(x,lazyt,domain,domain)]
lazyMatchAssocV1(x,vec,domain) == --old style slot4
n := MAXINDEX vec
xop := first x
- or/[rest QVELT(vec,i) for i in 0..n |
- xop = first (lazyt := first QVELT(vec,i)) and lazyMatch(x,lazyt,domain,domain)]
+ or/[rest vectorRef(vec,i) for i in 0..n |
+ xop = first (lazyt := first vectorRef(vec,i)) and lazyMatch(x,lazyt,domain,domain)]
--=======================================================
-- Utility Functions
diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot
index 4dea8353..b446b4cd 100644
--- a/src/interp/nrungo.boot
+++ b/src/interp/nrungo.boot
@@ -124,7 +124,7 @@ goGet(:l) ==
fn:= basicLookup(op,sig,lookupDomain,dollar)
fn = nil => keyedSystemError("S2NR0001",[op,sig,lookupDomain.0])
val:= apply(first fn,[:arglist,rest fn])
- setShellEntry(thisDomain,index,fn)
+ vectorRef(thisDomain,index) := fn
val
NRTreplaceLocalTypes(t,dom) ==
diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot
index 635937a6..f15ed5f4 100644
--- a/src/interp/nrunopt.boot
+++ b/src/interp/nrunopt.boot
@@ -272,7 +272,7 @@ augmentPredCode(n,lastPl) ==
delta:=2 * delta; u) for x in pl]
augmentPredVector(dollar,value) ==
- setShellEntry(dollar,3,value + QVELT(dollar,3))
+ vectorRef(dollar,3) := value + vectorRef(dollar,3)
isHasDollarPred pred ==
pred is [op,:r] =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-27 16:36:20 +0000