aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2011-08-25 15:59:44 +0000
committerdos-reis <gdr@axiomatics.org>2011-08-25 15:59:44 +0000
commitcd5a921db34f465d1dc8fbd2061d9077f64434cf (patch)
treeb6dc636c5fa79035999de79dbb12c2f31c358547 /src
parentc25dfacda02a40b2055328ba5898086c043e5427 (diff)
downloadopen-axiom-cd5a921db34f465d1dc8fbd2061d9077f64434cf.tar.gz
* interp/hashcode.boot: Remove.
*interp/interop.boot: Move OpenAxiom relevant code to define.boot and nrunfast.boot. Remove.
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog6
-rw-r--r--src/interp/Makefile.in9
-rw-r--r--src/interp/define.boot14
-rw-r--r--src/interp/functor.boot28
-rw-r--r--src/interp/g-util.boot4
-rw-r--r--src/interp/hashcode.boot115
-rw-r--r--src/interp/interop.boot669
-rw-r--r--src/interp/nrunfast.boot45
-rw-r--r--src/interp/trace.boot15
-rw-r--r--src/share/algebra/browse.daase2
-rw-r--r--src/share/algebra/category.daase2
-rw-r--r--src/share/algebra/compress.daase2
-rw-r--r--src/share/algebra/interp.daase2
-rw-r--r--src/share/algebra/operation.daase2
14 files changed, 84 insertions, 831 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 1d954c73..de3b2d3b 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,11 @@
2011-08-25 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/hashcode.boot: Remove.
+ *interp/interop.boot: Move OpenAxiom relevant code to define.boot
+ and nrunfast.boot. Remove.
+
+2011-08-25 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* interp/define.boot ($mutableDomain): Remove. Adjust users.
($mutableDomains): Likewise.
* interp/database.boot (dbMutable?): Remove.
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in
index fab50106..1731f897 100644
--- a/src/interp/Makefile.in
+++ b/src/interp/Makefile.in
@@ -65,7 +65,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
astr.$(FASLEXT) bits.$(FASLEXT) \
ht-util.$(FASLEXT) bc-util.$(FASLEXT) \
br-search.$(FASLEXT) alql.$(FASLEXT) \
- buildom.$(FASLEXT) hashcode.$(FASLEXT) \
+ buildom.$(FASLEXT) \
simpbool.$(FASLEXT) g-timer.$(FASLEXT) \
cattable.$(FASLEXT) posit.$(FASLEXT) \
cformat.$(FASLEXT) clam.$(FASLEXT) \
@@ -109,7 +109,7 @@ OBJS= boot-pkg.$(FASLEXT) types.$(FASLEXT) \
# Last minite patches.
# FIXMEL: should be folded into the main object list.
-INOBJS= setvart.$(FASLEXT) interop.$(FASLEXT) patches.$(FASLEXT)
+INOBJS= setvart.$(FASLEXT) patches.$(FASLEXT)
# Main compiler files.
OCOBJS= \
@@ -299,12 +299,11 @@ setvart.$(FASLEXT): macros.$(FASLEXT)
compiler.$(FASLEXT): msgdb.$(FASLEXT) pathname.$(FASLEXT) define.$(FASLEXT)
nrunfast.$(FASLEXT): c-util.$(FASLEXT)
nruncomp.$(FASLEXT): profile.$(FASLEXT) simpbool.$(FASLEXT) functor.$(FASLEXT)
-nrungo.$(FASLEXT): c-util.$(FASLEXT) clam.$(FASLEXT) interop.$(FASLEXT)
define.$(FASLEXT): g-error.$(FASLEXT) nruncomp.$(FASLEXT) database.$(FASLEXT)
database.$(FASLEXT): clam.$(FASLEXT) nlib.$(FASLEXT) daase.$(FASLEXT) \
cattable.$(FASLEXT) compat.$(FASLEXT) g-cndata.$(FASLEXT) \
c-util.$(FASLEXT)
-functor.$(FASLEXT): category.$(FASLEXT) interop.$(FASLEXT) lisplib.$(FASLEXT)
+functor.$(FASLEXT): category.$(FASLEXT) lisplib.$(FASLEXT) nrunfast.$(FASLEXT)
category.$(FASLEXT): c-util.$(FASLEXT) g-cndata.$(FASLEXT)
cattable.$(FASLEXT): simpbool.$(FASLEXT) c-util.$(FASLEXT)
compat.$(FASLEXT): pathname.$(FASLEXT)
@@ -312,7 +311,6 @@ simpbool.$(FASLEXT): macros.$(FASLEXT)
newfort.$(FASLEXT): macros.$(FASLEXT)
lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT) \
daase.$(FASLEXT)
-interop.$(FASLEXT): interop.boot c-util.$(FASLEXT) hashcode.$(FASLEXT)
c-doc.$(FASLEXT): c-util.$(FASLEXT) daase.$(FASLEXT)
server.$(FASLEXT): macros.$(FASLEXT)
@@ -382,7 +380,6 @@ msgdb.$(FASLEXT): g-util.$(FASLEXT)
g-error.$(FASLEXT): diagnostics.$(FASLEXT) g-util.$(FASLEXT)
c-util.$(FASLEXT): g-opt.$(FASLEXT)
pathname.$(FASLEXT): nlib.$(FASLEXT)
-hashcode.$(FASLEXT): g-util.$(FASLEXT)
g-util.$(FASLEXT): ggreater.$(FASLEXT) macros.$(FASLEXT) sys-utility.$(FASLEXT)
g-cndata.$(FASLEXT): sys-macros.$(FASLEXT) c-util.$(FASLEXT)
msg.$(FASLEXT): sys-macros.$(FASLEXT) astr.$(FASLEXT)
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 048efb2f..f4675b08 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -466,6 +466,20 @@ makeCompactSigCode sig == [fn for x in sig] where
--=======================================================================
-- Generate Slot 4 Constructor Vectors
--=======================================================================
+depthAssocList u ==
+ u := removeSymbol(u,'DomainSubstitutionMacro) --hack by RDJ 8/90
+ removeDuplicates ("append"/[depthAssoc(y) for y in u])
+
+depthAssoc x ==
+ y := tableValue($depthAssocCache,x) => y
+ x is ['Join,:u] or (u := getCatAncestors x) =>
+ v := depthAssocList u
+ tableValue($depthAssocCache,x) := [[x,:n],:v]
+ where n() == 1 + "MAX"/[rest y for y in v]
+ tableValue($depthAssocCache,x) := [[x,:0]]
+
+getCatAncestors x == [CAAR y for y in parentsOf opOf x]
+
NRTmakeCategoryAlist() ==
$depthAssocCache: local := hashTable 'EQ
$catAncestorAlist: local := nil
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index f8a2ff11..20ed8c36 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -33,7 +33,7 @@
import lisplib
-import interop
+import nrunfast
import category
namespace BOOT
@@ -60,11 +60,6 @@ CategoryPrint(D,$e) ==
PRETTYPRINT u
--% Domain printing
-keyItem a ==
- isDomain a => CDAR domainRef(a,4)
- a
- --The item that domain checks on
-
--Global strategy here is to maintain a list of substitutions
-- ( in $Sublis), of vectors and the names that they have,
-- which may be either local names ('View1') or global names ('Where1')
@@ -78,7 +73,7 @@ DomainPrint(D,brief) ==
$WhereCounter: local := 1
env:= $e or $EmptyEnvironment --in case we are called from top level
categoryObject? D => CategoryPrint(D,env)
- $Sublis:= [[keyItem D,:'original]]
+ $Sublis:= [[D,:'original]]
SAY '"-----------------------------------------------------------------------"
DomainPrint1(D,nil,env)
while ($WhereList) repeat
@@ -91,7 +86,6 @@ DomainPrint(D,brief) ==
SAY '"-----------------------------------------------------------------------"
DomainPrint1(D,brief,$e) ==
- vector? D and not isDomain D => PacPrint D
if vector? D then
D := D.4 --if we were passed a vector, go to the domain
Sublis:=
@@ -110,12 +104,12 @@ DomainPrint1(D,brief,$e) ==
uu.5 := vv
for j in 0..maxIndex vv repeat
if vector? vv.j then
- l := ASSQ(keyItem vv.j,Sublis)
+ l := ASSQ(vv.j,Sublis)
if l
then name:= rest l
else
name := DPname()
- Sublis := [[keyItem vv.j,:name],:Sublis]
+ Sublis := [[vv.j,:name],:Sublis]
$Sublis := [first Sublis,:$Sublis]
$WhereList := [[name,:vv.j],:$WhereList]
vv.j := name
@@ -125,13 +119,13 @@ DomainPrint1(D,brief,$e) ==
uu.i := DomainPrintSubst(uu.i,Sublis)
if vector? uu.i then
name := DPname()
- Sublis := [[keyItem uu.i,:name],:Sublis]
+ Sublis := [[uu.i,:name],:Sublis]
$Sublis := [first Sublis,:$Sublis]
$WhereList := [[name,:uu.i],:$WhereList]
uu.i := name
if uu.i is [.,:v] and vector? v then
name := DPname()
- Sublis := [[keyItem v,:name],:Sublis]
+ Sublis := [[v,:name],:Sublis]
$Sublis := [first Sublis,:$Sublis]
$WhereList := [[name,:v],:$WhereList]
uu.i := [first uu.i,:name]
@@ -147,22 +141,22 @@ PacPrint v ==
vv := copyVector v
for j in 0..maxIndex vv repeat
if vector? vv.j then
- l := ASSQ(keyItem vv.j,Sublis)
+ l := ASSQ(vv.j,Sublis)
if l
then name := rest l
else
name := DPname()
- Sublis := [[keyItem vv.j,:name],:Sublis]
+ Sublis := [[vv.j,:name],:Sublis]
$Sublis := [first Sublis,:$Sublis]
$WhereList := [[name,:vv.j],:$WhereList]
vv.j := name
if cons? vv.j and vector?(u:=rest vv.j) then
- l := ASSQ(keyItem u,Sublis)
+ l := ASSQ(u,Sublis)
if l
then name := rest l
else
name := DPname()
- Sublis := [[keyItem u,:name],:Sublis]
+ Sublis := [[u,:name],:Sublis]
$Sublis := [first Sublis,:$Sublis]
$WhereList := [[name,:u],:$WhereList]
vv.j.rest := name
@@ -176,7 +170,7 @@ DomainPrintSubst(item,Sublis) ==
[c1,:c2]
l := ASSQ(item,Sublis)
l => rest l
- l := ASSQ(keyItem item,Sublis)
+ l := ASSQ(item,Sublis)
l => rest l
item
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 2efeff70..321f8b9d 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -797,10 +797,6 @@ intern x ==
makeSymbol x
x
-isDomain a ==
- cons? a and vector? first a and
- member(first a.0, $domainTypeTokens)
-
-- variables used by browser
$htHash := MAKE_-HASH_-TABLE()
diff --git a/src/interp/hashcode.boot b/src/interp/hashcode.boot
deleted file mode 100644
index c88c326f..00000000
--- a/src/interp/hashcode.boot
+++ /dev/null
@@ -1,115 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2008, 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 g_-util
-namespace BOOT
-
-$DomainsWithoutLisplibs ==
- '(CAPSULE Union Record SubDomain Mapping Enumeration Mode)
-
-
--- Type hasher for old compiler style type names which produces a hash code
--- compatible with the asharp compiler. Takes a hard error if the type
--- is parameterized, but has no constructor modemap.
-getDomainHash dom == SPADCALL(rest dom, (first dom).4)
-
-hashType(type, percentHash) ==
- symbol? type =>
- type = '$ => percentHash
- type = "%" => percentHash
- hashString symbolName type
- string? type => hashCombine(hashString type,
- hashString('"Enumeration"))
- type is ['QUOTE, val] => hashType(val, percentHash)
- type is [dom] => hashString symbolName dom
- type is ['_:, ., type2] => hashType(type2, percentHash)
- isDomain type => getDomainHash type
- [op, :args] := type
- hash := hashString symbolName op
- op is 'Mapping =>
- hash := hashString '"->"
- [retType, :mapArgs] := args
- for arg in mapArgs repeat
- hash := hashCombine(hashType(arg, percentHash), hash)
- retCode := hashType(retType, percentHash)
- scalarEq?(retCode, $VoidHash) => hash
- hashCombine(retCode, hash)
- op is 'Enumeration =>
- for arg in args repeat
- hash := hashCombine(hashString(symbolName arg), hash)
- hash
- symbolMember?(op,$DomainsWithoutLisplibs) =>
- for arg in args repeat
- hash := hashCombine(hashType(arg, percentHash), hash)
- hash
-
- cmm := getConstructorModemap(op).mmSource
- cosig := rest getDualSignatureFromDB op
- for arg in args for c in cosig for ct in cmm repeat
- if c then
- hash := hashCombine(hashType(arg, percentHash), hash)
- else
- hash := hashCombine(7, hash)
--- !!! If/when asharp hashes values using their type, use instead
--- ctt := applySubst(pairList($FormalMapVariableList,args),ct)
--- hash := hashCombine(hashType(ctt, percentHash), hash)
-
-
- hash
-
-$hashModulus := 1073741789 -- largest 30-bit prime
-
--- Produce a 30-bit hash code. This function must produce the same codes
--- as the asharp string hasher in src/strops.c
-hashString str ==
- h := 0
- for i in 0..#str-1 repeat
- j := codePoint char str.i
- h := LOGXOR(h, ASH(h, 8))
- h := h + j + 200041
- h := LOGAND(h, 1073741823) -- 0x3FFFFFFF
- REM(h, $hashModulus)
-
--- Combine two hash codes to make a new one. Must be the same as in
--- the hashCombine function in aslib/runtime.as in asharp.
-hashCombine(hash1, hash2) ==
- MOD(ASH(LOGAND(hash2, 16777215), 6) + hash1, $hashModulus)
-
-
-$VoidHash := hashString '"Void"
-
-
--- following two lines correct bad coSig properties due to SubsetCategory
---putConstructorProperty('LocalAlgebra,'coSig,'(NIL T T T))
---putConstructorProperty('Localize,'coSig,'(NIL T T T))
diff --git a/src/interp/interop.boot b/src/interp/interop.boot
deleted file mode 100644
index c9c0f67d..00000000
--- a/src/interp/interop.boot
+++ /dev/null
@@ -1,669 +0,0 @@
--- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
--- All rights reserved.
--- Copyright (C) 2007-2011, 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
-import hashcode
-namespace BOOT
-
--- note domainObjects are now (dispatchVector hashCode . domainVector)
--- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr),
--- pre oldAxiomCategory is (dispatchVector . (cat form))
--- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist))
-
-hashCode? x == integer? x
-
-$domainTypeTokens == ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory,
- 'oldAxiomCategory, 0]
-
--- The name game.
--- The compiler produces names that are of the form:
--- a) cons(0, <string>)
--- b) cons(1, type-name, arg-names...)
--- c) cons(2, arg-names...)
--- d) cons(3, value)
--- NB: (c) is for tuple-ish constructors,
--- and (d) is for dependent types.
-
-DNameStringID == 0
-DNameApplyID == 1
-DNameTupleID == 2
-DNameOtherID == 3
-
-DNameToSExpr1 dname ==
- null dname => error "unexpected domain name"
- first dname = DNameStringID =>
- makeSymbol(CompStrToString rest dname)
- name0 := DNameToSExpr1 second dname
- args := rest rest dname
- name0 is '_-_> =>
- froms := first args
- froms := [DNameToSExpr x for x in rest froms]
- ret := second args -- a tuple
- ret := DNameToSExpr second ret -- contents
- ['Mapping,:[ret,:froms]]
- name0 is 'Union or name0 is 'Record =>
- sxs := [DNameToSExpr x for x in rest first args]
- [name0,:sxs]
- name0 is 'Enumeration =>
- [name0,:[DNameFixEnum x for x in rest first args]]
- [name0,:[DNameToSExpr x for x in args]]
-
-DNameToSExpr dname ==
- first dname = DNameOtherID =>
- rest dname
- sx := DNameToSExpr1 dname
- cons? sx => sx
- [sx]
-
-DNameFixEnum arg == CompStrToString rest arg
-
-SExprToDName(sexpr, cosigVal) ==
- -- is it a non-type valued object?
- not cosigVal => [DNameOtherID, :sexpr]
- if first sexpr is '_: then sexpr := third sexpr
- first sexpr is 'Mapping =>
- args := [ SExprToDName(sx,true) for sx in rest sexpr]
- [DNameApplyID,
- [DNameStringID,: StringToCompStr '"->"],
- [DNameTupleID, : rest args],
- [DNameTupleID, first args]]
- name0 := [DNameStringID, : StringToCompStr symbolName first sexpr]
- first sexpr is 'Union or first sexpr is 'Record =>
- [DNameApplyID, name0,
- [DNameTupleID,: [ SExprToDName(sx,true) for sx in rest sexpr]]]
- newCosig := rest getDualSignatureFromDB first sexpr
- [DNameApplyID, name0,
- :[SExprToDName(x,f) for x in rest sexpr for f in newCosig]]
-
--- local garbage because Compiler strings are null terminated
-StringToCompStr(str) ==
- strconc(str, charString abstractChar 0)
-
-CompStrToString(str) ==
- subString(str, 0, #str - 1)
--- local garbage ends
-
-runOldAxiomFunctor(:allArgs) ==
- [:args,env] := allArgs
- getConstructorKindFromDB env is "category" =>
- [$oldAxiomPreCategoryDispatch,: [env, :args]]
- dom:=apply(env, args)
- makeOldAxiomDispatchDomain dom
-
-makeLazyOldAxiomDispatchDomain domform ==
- attribute? domform =>
- [$attributeDispatch, domform, hashString(symbolName domform)]
- getConstructorKindFromDB opOf domform is "category" =>
- [$oldAxiomPreCategoryDispatch,: domform]
- dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform]
- append!(dd,dd) -- installs back pointer to head of domain.
- dd
-
-makeOldAxiomDispatchDomain dom ==
- cons? dom => dom
- [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom]
-
-closeOldAxiomFunctor(name) ==
- [function runOldAxiomFunctor,:symbolFunction name]
-
-lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) ==
- dom := instantiate domenv
- SPADCALL(rest dom, self, op, sig, box, skipdefaults, first dom.3)
-
-lazyOldAxiomDomainHashCode(domenv, env) == first domenv
-
-lazyOldAxiomDomainDevaluate(domenv, env) ==
- dom := instantiate domenv
- SPADCALL(rest dom, first dom.1)
-
-lazyOldAxiomAddChild(domenv, kid, env) ==
- [$lazyOldAxiomDomainDispatch,:domenv]
-
-$lazyOldAxiomDomainDispatch :=
- VECTOR('lazyOldAxiomDomain,
- [function lazyOldAxiomDomainDevaluate],
- [nil],
- [function lazyOldAxiomDomainLookupExport],
- [function lazyOldAxiomDomainHashCode],
- [function lazyOldAxiomAddChild])
-
--- old Axiom pre category objects are just (dispatch . catform)
--- where catform is ('categoryname,: evaluated args)
--- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom])
-oldAxiomPreCategoryBuild(catform, dom, env) ==
- pack := oldAxiomCategoryDefaultPackage(catform, dom)
- [$oldAxiomCategoryDispatch,
- :[catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]]
-oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0)
-oldAxiomCategoryDefaultPackage(catform, dom) ==
- hasDefaultPackage opOf catform
-
-oldAxiomPreCategoryDevaluate([op,:args], env) ==
- SExprToDName([op,:devaluateList args], true)
-
-$oldAxiomPreCategoryDispatch :=
- VECTOR('oldAxiomPreCategory,
- [function oldAxiomPreCategoryDevaluate],
- [nil],
- [nil],
- [function oldAxiomPreCategoryHashCode],
- [function oldAxiomPreCategoryBuild],
- [nil])
-
-oldAxiomCategoryDevaluate([[op,:args],:.], env) ==
- SExprToDName([op,:devaluateList args], true)
-
-oldAxiomPreCategoryParents(catform,dom) ==
- vars := ["$",:rest getConstructorFormFromDB opOf catform]
- vals := [dom,:rest catform]
- -- parents := getConstructorParentsFromDB opOf catform
- parents := parentsOf opOf catform
- PROGV(vars, vals,
- vector
- [eval quoteCatOp cat for [cat,:pred] in parents | eval pred])
-
-quoteCatOp cat ==
- cat isnt [.,:.] => MKQ cat
- ['LIST, MKQ first cat,: rest cat]
-
-
-oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) ==
- [catform,hash, pack,:.] := catenv
- opIsHasCat op => if scalarEq?(sig, hash) then [self] else nil
- null(pack) => nil
- if not vector? pack then
- pack:=apply(pack, [self, :rest catform])
- catenv.rest.rest.first := pack
- fun := basicLookup(op, sig, pack, self) => [fun]
- nil
-
-oldAxiomCategoryParentCount([.,.,.,parents,.], env) == # parents
-oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) ==
- catform := parvec.(n-1)
- VECTORP KAR catform => catform
- newcat := oldAxiomPreCategoryBuild(catform,dom,nil)
- parvec.(n-1) := newcat
- newcat
-
-oldAxiomCategoryBuild([catform,:.], dom, env) ==
- oldAxiomPreCategoryBuild(catform,dom, env)
-oldAxiomCategoryHashCode([.,hash,:.], env) == hash
-
-$oldAxiomCategoryDispatch :=
- VECTOR('oldAxiomCategory,
- [function oldAxiomCategoryDevaluate],
- [nil],
- [function oldAxiomCategoryLookupExport],
- [function oldAxiomCategoryHashCode],
- [function oldAxiomCategoryBuild], -- builder ??
- [function oldAxiomCategoryParentCount],
- [function oldAxiomCategoryNthParent]) -- 1 indexed
-
-attributeDevaluate(attrObj, env) ==
- [name, hash] := attrObj
- StringToCompStr symbolName name
-
-attributeLookupExport(attrObj, self, op, sig, box, env) ==
- [name, hash] := attrObj
- opIsHasCat op => if scalarEq?(hash, sig) then [self] else nil
-
-attributeHashCode(attrObj, env) ==
- [name, hash] := attrObj
- hash
-
-attributeCategoryBuild(attrObj, dom, env) ==
- [name, hash] := attrObj
- [$attributeDispatch, name, hash]
-
-attributeCategoryParentCount(attrObj, env) == 0
-
-attributeNthParent(attrObj, env) == nil
-
-$attributeDispatch :=
- VECTOR('attribute,
- [function attributeDevaluate],
- [nil],
- [function attributeLookupExport],
- [function attributeHashCode],
- [function attributeCategoryBuild], -- builder ??
- [function attributeCategoryParentCount],
- [function attributeNthParent]) -- 1 indexed
-
-
---=======================================================================
--- Generate Category Level Alist
---=======================================================================
-orderCatAnc x ==
- reverse! ASSOCLEFT SORTBY(function rest,rest depthAssoc x)
-
-depthAssocList u ==
- u := removeSymbol(u,'DomainSubstitutionMacro) --hack by RDJ 8/90
- removeDuplicates ("append"/[depthAssoc(y) for y in u])
-
-depthAssoc x ==
- y := tableValue($depthAssocCache,x) => y
- x is ['Join,:u] or (u := getCatAncestors x) =>
- v := depthAssocList u
- tableValue($depthAssocCache,x) := [[x,:n],:v]
- where n() == 1 + "MAX"/[rest y for y in v]
- tableValue($depthAssocCache,x) := [[x,:0]]
-
-getCatAncestors x == [CAAR y for y in parentsOf opOf x]
-
-listOfEntries form ==
- form isnt [.,:.] => form
- form is [op,:l] =>
- op is 'Join => "append"/[listOfEntries x for x in l]
- op is 'CATEGORY => listOfCategoryEntries rest l
- op is 'PROGN => listOfCategoryEntries l
- op is '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 is 'ATTRIBUTE and first u is [f,:.] and constructor? f =>
- [first u]
- op in '(ATTRIBUTE SIGNATURE) => nil
- op is '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]
-
-orderedDefaults(conform,domform) ==
- $depthAssocCache : local := hashTable 'EQ
- conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op]
- acc := nil
- ancestors := ancestorsOf(conform,domform)
- for x in conList repeat
- for y in ancestors | x = CAAR y repeat acc := [y,:acc]
- reverse! acc
-
-instantiate domenv ==
- -- following is a patch for a bug in runtime.as
- -- has a lazy dispatch vector with an instantiated domenv
- VECTORP rest domenv => [$oldAxiomDomainDispatch ,: domenv]
- callForm := second domenv
- oldDom := CDDR domenv
- [functor,:args] := callForm
--- if null(fn := property(functor,'instantiate)) then
--- ofn := symbolFunction functor
--- loadFunctor functor
--- fn := symbolFunction functor
--- symbolFunction(functor) := ofn
--- proprty(functor, 'instantiate) := fn
--- domvec := apply(fn, args)
- domvec := apply(functor, args)
- oldDom.first := $oldAxiomDomainDispatch
- oldDom.rest := [second oldDom,: domvec]
- oldDom
-
-hashTypeForm([fn,: args], percentHash) ==
- hashType([fn,:devaluateList args], percentHash)
-
-$hashOp1 == hashString '"1"
-$hashOp0 == hashString '"0"
-$hashOpApply == hashString '"apply"
-$hashOpSet == hashString '"set!"
-$hashSeg == hashString '".."
-$hashPercent == hashString '"%"
-
-oldAxiomDomainLookupExport _
- (domenv, self, op, sig, box, skipdefaults, env) ==
- domainVec := rest domenv
- if hashCode? op then
- scalarEq?(op, $hashOp1) => op := 'One
- scalarEq?(op, $hashOp0) => op := 'Zero
- scalarEq?(op, $hashOpApply) => op := 'elt
- scalarEq?(op, $hashOpSet) => op := 'setelt
- scalarEq?(op, $hashSeg) => op := 'SEGMENT
- constant := nil
- if hashCode? sig and self and scalarEq?(sig, getDomainHash self) then
- sig := '($)
- constant := true
- val :=
- skipdefaults =>
- oldCompLookupNoDefaults(op, sig, domainVec, self)
- oldCompLookup(op, sig, domainVec, self)
- null val => val
- if constant then val := SPADCALL val
- box.first := val
- box
-
-oldAxiomDomainHashCode(domenv, env) == first domenv
-
-oldAxiomDomainHasCategory(domenv, cat, env) ==
- HasAttribute(domvec := rest domenv, cat) or
- HasCategory(domvec, devaluate cat)
-
-oldAxiomDomainDevaluate(domenv, env) ==
- SExprToDName(rest domenv.0, 'T)
-
-oldAxiomAddChild(domenv, child, env) == [$oldAxiomDomainDispatch,:domenv]
-
-$oldAxiomDomainDispatch :=
- VECTOR('oldAxiomDomain,
- [function oldAxiomDomainDevaluate],
- [nil],
- [function oldAxiomDomainLookupExport],
- [function oldAxiomDomainHashCode],
- [function oldAxiomAddChild])
-
-basicLookupCheckDefaults(op,sig,domain,dollar) ==
- box := [nil]
- not vector?(dispatch := first dollar) => error "bad domain format"
- lookupFun := dispatch.3
- dispatch.0 = 0 => -- new compiler domain object
- hashPercent :=
- vector? dollar => hashType(dollar.0,0)
- hashType(dollar,0)
-
- hashSig :=
- hashCode? sig => sig
- hashType( ['Mapping,:sig], hashPercent)
-
- if symbol? op then op := hashString symbolName op
- first SPADCALL(rest dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun)
- first SPADCALL(rest dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun)
-
-$hasCatOpHash == hashString '"%%"
-opIsHasCat op ==
- hashCode? op => scalarEq?(op, $hasCatOpHash)
- op = "%%"
-
--- has cat questions lookup up twice if false
--- replace with following ?
--- not(opIsHasCat op) and
--- (u := lookupInDomainVector(op,sig,domvec,domvec)) => u
-
-oldCompLookup(op, sig, domvec, dollar) ==
- $lookupDefaults: local := false
- u := lookupInDomainVector(op,sig,domvec,dollar) => u
- $lookupDefaults := true
- lookupInDomainVector(op,sig,domvec,dollar)
-
-oldCompLookupNoDefaults(op, sig, domvec, dollar) ==
- $lookupDefaults: local := false
- lookupInDomainVector(op,sig,domvec,dollar)
-
-hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) ==
- opIsHasCat op =>
- HasCategory(domain, sig)
- if hashCode? op and scalarEq?(op, $hashOp1) then op := 'One
- if hashCode? op and scalarEq?(op, $hashOp0) then op := 'Zero
- hashPercent :=
- vector? dollar => hashType(dollar.0,0)
- hashType(dollar,0)
- if hashCode? sig and scalarEq?(sig, hashPercent) then
- sig := hashType('(Mapping $), hashPercent)
- dollar = nil => systemError()
- $lookupDefaults =>
- hashNewLookupInCategories(op,sig,domain,dollar) --lookup first in my cats
- or newLookupInAddChain(op,sig,domain,dollar)
- --fast path when called from newGoGet
- success := false
- if $monitorNewWorld then
- sayLooking(concat('"---->",form2String devaluate domain,
- '"----> searching op table for:","%l"," "),op,sig,dollar)
- someMatch := false
- numvec := getDomainByteVector domain
- predvec := domainPredicates domain
- max := maxIndex opvec
- k := getOpCode(op,opvec,max) or return
- flag => newLookupInAddChain(op,sig,domain,dollar)
- nil
- idxmax := maxIndex numvec
- start := vectorRef(opvec,k)
- finish :=
- max > k => vectorRef(opvec,k + 2)
- idxmax
- if finish > idxmax then systemError '"limit too large"
- numArgs := if hashCode? sig then -1 else (#sig)-1
- success := nil
- $isDefaultingPackage: local :=
- -- use special defaulting handler when dollar non-trivial
- dollar ~= domain and defaultPackageForm? devaluate domain
- while finish > start repeat
- PROGN
- i := start
- 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 := arrayRef(numvec,i + numTableArgs + 2)
- loc = 1 => (someMatch := true)
- loc = 0 =>
- start := start + numTableArgs + 4
- i := start + 2
- someMatch := true --mark so that if subsumption fails, look for original
- subsumptionSig :=
- [newExpandTypeSlot(arrayRef(numvec,i + j),
- dollar,domain) for j in 0..numTableArgs]
- if $monitorNewWorld then
- sayBrightly [formatOpSignature(op,sig),'"--?-->",
- formatOpSignature(op,subsumptionSig)]
- nil
- slot := vectorRef(domain,loc)
- cons? slot =>
- slot.op = 'newGoGet => someMatch:=true
- --treat as if operation were not there
- --if sameObject?(QCAR slot,'newGoGet) then
- -- UNWIND_-PROTECT --break infinite recursion
- -- ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot rest slot),
- -- if domain.loc = 'skip then domain.loc := slot)
- return (success := slot)
- slot is 'skip => --recursive call from above 'replaceGoGetSlot
- return (success := newLookupInAddChain(op,sig,domain,dollar))
- systemError '"unexpected format"
- start := start + numTableArgs + 4
- (success ~= 'failed) and success =>
- if $monitorNewWorld then
- sayLooking1('"<----",uu) where uu() ==
- cons? success => [first success,:devaluate rest success]
- success
- success
- subsumptionSig and (u:= basicLookup(op,subsumptionSig,domain,dollar)) => u
- flag or someMatch => newLookupInAddChain(op,sig,domain,dollar)
- nil
-
-hashNewLookupInCategories(op,sig,dom,dollar) ==
- slot4 := domainData dom
- catVec := second slot4
- # catVec = 0 => nil --early exit if no categories
- integer? KDR catVec.0 =>
- newLookupInCategories1(op,sig,dom,dollar) --old style
- $lookupDefaults : local := false
- if $monitorNewWorld then sayBrightly concat('"----->",
- form2String devaluate dom,'"-----> searching default packages for ",op)
- predvec := domainPredicates dom
- packageVec := first slot4
---the next three lines can go away with new category world
- varList := ['$,:$FormalMapVariableList]
- 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 |
- (entry := packageVec.i) and entry ~= true repeat
- package :=
- vector? entry =>
- if $monitorNewWorld then
- sayLooking1('"already instantiated cat package",entry)
- entry
- ident? entry =>
- cat := catVec.i
- packageForm := nil
- if not property(entry,'LOADED) then loadLib entry
- infovec := property(entry,'infovec)
- success :=
- --vector? infovec => ----new world
- true => ----new world
- opvec := infovec.1
- max := maxIndex opvec
- code := getOpCode(op,opvec,max)
- null code => nil
- byteVector := CDDDR infovec.3
- endPos :=
- code+2 > max => # byteVector
- vectorRef(opvec,code+2)
- --not nrunNumArgCheck(#sig.source,byteVector,opvec.code,endPos) => nil
- --numOfArgs := byteVector.(opvec.code)
- --numOfArgs ~= #sig.source => nil
- packageForm := [entry,'$,:rest cat]
- package := evalSlotDomain(packageForm,dom)
- packageVec.i := package
- package
- ----old world
- table := tableValue($Slot1DataBase,entry) or systemError nil
- (u := LASSQ(op,table))
- and (v := or/[rest x for x in u]) =>
- packageForm := [entry,'$,:rest cat]
- package := evalSlotDomain(packageForm,dom)
- packageVec.i := package
- package
- nil
- null success =>
- if $monitorNewWorld then
- sayBrightlyNT '" not in: "
- pp (packageForm and devaluate package or entry)
- nil
- if $monitorNewWorld then
- sayLooking1('"candidate default package instantiated: ",success)
- success
- entry
- null package => nil
- if $monitorNewWorld then
- sayLooking1('"Looking at instantiated package ",package)
- res := basicLookup(op,sig,package,dollar) =>
- if $monitorNewWorld then
- sayBrightly '"candidate default package succeeds"
- return res
- if $monitorNewWorld then
- sayBrightly '"candidate fails -- continuing to search categories"
- nil
-
-HasAttribute(domain,attrib) ==
- hashPercent :=
- vector? domain => hashType(domain.0,0)
- hashType(domain,0)
- isDomain domain =>
- integer?((first domain).0) =>
- -- following call to hashType was missing 2nd arg.
- -- getDomainHash domain added on 4/01/94 by RSS
- basicLookup("%%",hashType(attrib, hashPercent),domain,domain)
- HasAttribute(CDDR domain, attrib)
- integer? domainRef(domain,3) => newHasAttribute(domain,attrib)
- (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain)
-
-newHasAttribute(domain,attrib) ==
- hashPercent :=
- vector? domain => hashType(domain.0,0)
- hashType(domain,0)
- predIndex :=
- hashCode? attrib =>
- -- following call to hashType was missing 2nd arg.
- -- hashPercent added by PAB 15/4/94
- or/[x for x in domain.2 | attrib = hashType(first x, hashPercent)]
- LASSOC(attrib,domain.2)
- predIndex =>
- predIndex = 0 => true
- predvec := domainPredicates domain
- testBitVector(predvec,predIndex)
- false
-
-newHasCategory(domain,catform) ==
- catform = $Type or catform = $Category => true
- catform is ["Join",:cats] =>
- and/[newHasCategory(domain,cat) for cat in cats]
- slot4 := domain.4
- auxvec := first slot4
- catvec := second slot4
- $isDefaultingPackage: local := defaultPackageForm? devaluate domain
- #catvec > 0 and integer? KDR catvec.0 => --old style
- predIndex := lazyMatchAssocV1(catform,catvec,domain)
- null predIndex => false
- predIndex = 0 => true
- predvec := domainPredicates domain
- testBitVector(predvec,predIndex)
- lazyMatchAssocV(catform,auxvec,catvec,domain) --new style
-
-getCatForm(catvec, index, domain) ==
- integer?(form := vectorRef(catvec,index)) => domain.form
- form
-
-HasSignature(domain,[op,sig]) ==
- compiledLookup(op,sig,domain)
-
-HasCategory(domain,catform') ==
- catform' is ['SIGNATURE,:f] => HasSignature(domain,f)
- catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f)
- isDomain domain =>
- integer?((first domain).0) =>
- catform' := devaluate catform'
- basicLookup("%%",catform',domain,domain)
- HasCategory(CDDR domain, catform')
- catform:= devaluate catform'
- integer? domainRef(domain,3) => newHasCategory(domain,catform)
- domain0 := canonicalForm domain -- handles old style domains, Record, Union etc.
- slot4 := domainData domain
- catlist := slot4.1
- member(catform,catlist) or
- opOf(catform) in '(Object Type) or --temporary hack
- or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist]
-
-domainEqual(a,b) ==
- vector? a and vector? b and a.0 = b.0
-
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 1a881336..eba02971 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -602,6 +602,51 @@ resolveNiladicConstructors form ==
--=======================================================
-- HasCategory/Attribute
--=======================================================
+domainEqual(a,b) ==
+ vector? a and vector? b and a.0 = b.0
+
+HasAttribute(domain,attrib) ==
+ integer? domainRef(domain,3) => newHasAttribute(domain,attrib)
+ (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain)
+
+newHasAttribute(domain,attrib) ==
+ predIndex := LASSOC(attrib,domain.2) =>
+ predIndex = 0 => true
+ predvec := domainPredicates domain
+ testBitVector(predvec,predIndex)
+ false
+
+newHasCategory(domain,catform) ==
+ catform = $Type or catform = $Category => true
+ catform is ["Join",:cats] =>
+ and/[newHasCategory(domain,cat) for cat in cats]
+ slot4 := domain.4
+ auxvec := first slot4
+ catvec := second slot4
+ $isDefaultingPackage: local := defaultPackageForm? devaluate domain
+ #catvec > 0 and integer? KDR catvec.0 => --old style
+ predIndex := lazyMatchAssocV1(catform,catvec,domain)
+ null predIndex => false
+ predIndex = 0 => true
+ predvec := domainPredicates domain
+ testBitVector(predvec,predIndex)
+ lazyMatchAssocV(catform,auxvec,catvec,domain) --new style
+
+HasSignature(domain,[op,sig]) ==
+ compiledLookup(op,sig,domain)
+
+HasCategory(domain,catform') ==
+ catform' is ['SIGNATURE,:f] => HasSignature(domain,f)
+ catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f)
+ catform:= devaluate catform'
+ integer? domainRef(domain,3) => newHasCategory(domain,catform)
+ domain0 := canonicalForm domain -- handles old style domains, Record, Union etc.
+ slot4 := domainData domain
+ catlist := slot4.1
+ member(catform,catlist) or
+ opOf(catform) in '(Object Type) or --temporary hack
+ or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist]
+
-- PLEASE NOTE: This function has the rather charming side-effect that
-- e.g. it works if domform is an Aldor Category. This is being used
-- by extendscategoryForm in c-util to allow Aldor domains to be used
diff --git a/src/interp/trace.boot b/src/interp/trace.boot
index 1d503bcf..ab1890b5 100644
--- a/src/interp/trace.boot
+++ b/src/interp/trace.boot
@@ -762,24 +762,9 @@ traceReply() ==
sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6)
addTraceItem d ==
- isDomain d => $domains:= [devaluate d,:$domains]
isDomainOrPackage d => $packages:= [devaluate d,:$packages]
constructor? d => $constructors:=[d,:$constructors]
-_?t() ==
- null _/TRACENAMES => sayMSG bright '"nothing is traced"
- for x in _/TRACENAMES | x isnt [.,:.] and not IS__GENVAR x repeat
- if llm:= get(x,'localModemap,$InteractiveFrame) then
- x:= ([CADAR llm])
- sayMSG ['"Function",:bright rassocSub(x,$mapSubNameAlist),'"traced"]
- for x in _/TRACENAMES | x is [d,:l] and isDomainOrPackage d repeat
- suffix:=
- isDomain d => '"domain"
- '"package"
- sayBrightly ['" Functions traced in ",suffix,'"%b",devaluate d,'"%d",":"]
- for x in orderBySlotNumber l repeat reportSpadTrace(" ",take(4,x))
- TERPRI()
-
tracelet(fn,vars) ==
if GENSYMP fn and stupidIsSpadFunction eval fn then
fn := eval fn
diff --git a/src/share/algebra/browse.daase b/src/share/algebra/browse.daase
index 92b9b756..24419aa9 100644
--- a/src/share/algebra/browse.daase
+++ b/src/share/algebra/browse.daase
@@ -1,5 +1,5 @@
-(2276906 . 3523190732)
+(2276906 . 3523272525)
(-18 A S)
((|constructor| (NIL "One-dimensional-array aggregates serves as models for one-dimensional arrays. Categorically,{} these aggregates are finite linear aggregates with the \\spadatt{shallowlyMutable} property,{} that is,{} any component of the array may be changed without affecting the identity of the overall array. Array data structures are typically represented by a fixed area in storage and therefore cannot efficiently grow or shrink on demand as can list structures (see however \\spadtype{FlexibleArray} for a data structure which is a cross between a list and an array). Iteration over,{} and access to,{} elements of arrays is extremely fast (and often can be optimized to open-code). Insertion and deletion however is generally slow since an entirely new data structure must be created for the result.")))
NIL
diff --git a/src/share/algebra/category.daase b/src/share/algebra/category.daase
index 97a4430d..684df420 100644
--- a/src/share/algebra/category.daase
+++ b/src/share/algebra/category.daase
@@ -1,5 +1,5 @@
-(205468 . 3523190736)
+(205468 . 3523272529)
((((-877)) . T))
((((-877)) . T))
((((-877)) . T))
diff --git a/src/share/algebra/compress.daase b/src/share/algebra/compress.daase
index 9209b962..34317536 100644
--- a/src/share/algebra/compress.daase
+++ b/src/share/algebra/compress.daase
@@ -1,5 +1,5 @@
-(30 . 3523190731)
+(30 . 3523272523)
(4428 |Enumeration| |Mapping| |Record| |Union| |ofCategory| |isDomain|
ATTRIBUTE |package| |domain| |category| CATEGORY |nobranch| AND |Join|
|ofType| SIGNATURE "failed" "algebra" |OneDimensionalArrayAggregate&|
diff --git a/src/share/algebra/interp.daase b/src/share/algebra/interp.daase
index 4a3d15c1..e345df14 100644
--- a/src/share/algebra/interp.daase
+++ b/src/share/algebra/interp.daase
@@ -1,5 +1,5 @@
-(2872409 . 3523190745)
+(2872409 . 3523272537)
((-1935 ((#1=(-114) #2=(-1 #1# |#2| |#2|) $) 86 T ELT) ((#1# $) NIL T ELT)) (-1933 (($ #2# $) 18 T ELT) (#3=($ $) NIL T ELT)) (-4218 #4=((|#2| $ #5=(-558) |#2|) NIL T ELT) ((|#2| $ #6=(-1255 #5#) |#2|) 44 T ELT)) (-2510 (#3# 80 T ELT)) (-4272 ((|#2| #7=(-1 |#2| |#2| |#2|) $ |#2| |#2|) 52 T ELT) ((|#2| #7# $ |#2|) 50 T ELT) ((|#2| #7# $) 49 T ELT)) (-3839 ((#5# #8=(-1 #1# |#2|) $) 27 T ELT) ((#5# |#2| $) NIL T ELT) ((#5# |#2| $ #5#) 96 T ELT)) (-3290 ((#9=(-661 |#2|) $) 13 T ELT)) (-3938 (($ #2# $ $) 64 T ELT) (#10=($ $ $) NIL T ELT)) (-2160 (#11=($ (-1 |#2| |#2|) $) 37 T ELT)) (-4388 (#11# NIL T ELT) (($ #7# $ $) 60 T ELT)) (-2517 (($ |#2| $ #5#) NIL T ELT) (#12=($ $ $ #5#) 67 T ELT)) (-1468 (((-3 |#2| "failed") #8# $) 29 T ELT)) (-2158 (#13=(#1# #8# $) 23 T ELT)) (-4230 #4# ((|#2| $ #5#) NIL T ELT) (#14=($ $ #6#) 66 T ELT)) (-2518 (($ $ #5#) 76 T ELT) (#14# 75 T ELT)) (-2157 ((#15=(-791) #8# $) 34 T ELT) ((#15# |#2| $) NIL T ELT)) (-1934 (#12# 69 T ELT)) (-3820 (#3# 68 T ELT)) (-3950 (($ #9#) 73 T ELT)) (-4232 (($ $ |#2|) NIL T ELT) (($ |#2| $) NIL T ELT) (#10# 87 T ELT) (($ (-661 $)) 85 T ELT)) (-4376 (((-877) $) 92 T ELT)) (-2159 (#13# 22 T ELT)) (-3454 (#16=(#1# $ $) 95 T ELT)) (-3086 (#16# 99 T ELT)))
(((-18 |#1| |#2|) (-10 -8 (-15 -3454 #1=(#2=(-114) |#1| |#1|)) (-15 -4376 ((-877) |#1|)) (-15 -3086 #1#) (-15 -1933 #3=(|#1| |#1|)) (-15 -1933 (|#1| #4=(-1 #2# |#2| |#2|) |#1|)) (-15 -2510 #3#) (-15 -1934 #5=(|#1| |#1| |#1| #6=(-558))) (-15 -1935 (#2# |#1|)) (-15 -3938 #7=(|#1| |#1| |#1|)) (-15 -3839 (#6# |#2| |#1| #6#)) (-15 -3839 (#6# |#2| |#1|)) (-15 -3839 (#6# #8=(-1 #2# |#2|) |#1|)) (-15 -1935 (#2# #4# |#1|)) (-15 -3938 (|#1| #4# |#1| |#1|)) (-15 -4218 (|#2| |#1| #9=(-1255 #6#) |#2|)) (-15 -2517 #5#) (-15 -2517 (|#1| |#2| |#1| #6#)) (-15 -2518 #10=(|#1| |#1| #9#)) (-15 -2518 (|#1| |#1| #6#)) (-15 -4388 (|#1| #11=(-1 |#2| |#2| |#2|) |#1| |#1|)) (-15 -4232 (|#1| (-661 |#1|))) (-15 -4232 #7#) (-15 -4232 (|#1| |#2| |#1|)) (-15 -4232 (|#1| |#1| |#2|)) (-15 -4230 #10#) (-15 -3950 (|#1| #12=(-661 |#2|))) (-15 -1468 ((-3 |#2| "failed") #8# |#1|)) (-15 -4272 (|#2| #11# |#1|)) (-15 -4272 (|#2| #11# |#1| |#2|)) (-15 -4272 (|#2| #11# |#1| |#2| |#2|)) (-15 -4230 (|#2| |#1| #6#)) (-15 -4230 #13=(|#2| |#1| #6# |#2|)) (-15 -4218 #13#) (-15 -2157 (#14=(-791) |#2| |#1|)) (-15 -3290 (#12# |#1|)) (-15 -2157 (#14# #8# |#1|)) (-15 -2158 #15=(#2# #8# |#1|)) (-15 -2159 #15#) (-15 -2160 #16=(|#1| (-1 |#2| |#2|) |#1|)) (-15 -4388 #16#) (-15 -3820 #3#)) (-19 |#2|) (-1238)) (T -18))
NIL
diff --git a/src/share/algebra/operation.daase b/src/share/algebra/operation.daase
index a255645d..fa899b48 100644
--- a/src/share/algebra/operation.daase
+++ b/src/share/algebra/operation.daase
@@ -1,5 +1,5 @@
-(719417 . 3523190733)
+(719417 . 3523272526)
(((*1 *2 *3 *4)
(|partial| -12 (-5 *3 (-1288 *4)) (-4 *4 (-13 (-1070) (-658 (-558))))
(-5 *2 (-1288 (-419 (-558)))) (-5 *1 (-1317 *4)))))