remove more pamphlets

1 files changed, 607 insertions, 0 deletions

diff --git a/src/interp/interop.boot b/src/interp/interop.boot
new file mode 100644
index 00000000..99543049
--- /dev/null
+++ b/src/interp/interop.boot
@@ -0,0 +1,607 @@
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+-- Copyright (C) 2007, Gabriel Dos Reis.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+--     - Redistributions of source code must retain the above copyright
+--       notice, this list of conditions and the following disclaimer.
+--
+--     - Redistributions in binary form must reproduce the above copyright
+--       notice, this list of conditions and the following disclaimer in
+--       the documentation and/or other materials provided with the
+--       distribution.
+--
+--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+--       names of its contributors may be used to endorse or promote products
+--       derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+)package "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 == INTEGERP 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"
+  CAR dname = DNameStringID => 
+    INTERN(CompStrToString CDR dname)
+  name0 := DNameToSExpr1 CAR CDR dname
+  args  := CDR CDR dname
+  name0 = '_-_> => 
+    froms := CAR args
+    froms := MAPCAR(function DNameToSExpr, CDR froms)
+    ret   := CAR CDR args -- a tuple
+    ret   := DNameToSExpr CAR CDR ret -- contents
+    CONS('Mapping, CONS(ret, froms))
+  name0 = 'Union or name0 = 'Record =>
+    sxs := MAPCAR(function DNameToSExpr, CDR CAR args)
+    CONS(name0, sxs)
+  name0 = 'Enumeration =>
+    CONS(name0, MAPCAR(function DNameFixEnum, CDR CAR args))
+  CONS(name0, MAPCAR(function DNameToSExpr, args))
+
+DNameToSExpr dname ==
+  CAR dname = DNameOtherID  =>
+        CDR dname
+  sx := DNameToSExpr1 dname
+  CONSP sx => sx
+  LIST sx
+
+DNameFixEnum arg == CompStrToString CDR arg
+  
+SExprToDName(sexpr, cosigVal) == 
+  -- is it a non-type valued object?
+  NOT cosigVal => [DNameOtherID, :sexpr]
+  if CAR sexpr = '_: then sexpr := CAR CDR CDR sexpr
+  CAR sexpr = 'Mapping =>
+    args := [ SExprToDName(sx, 'T) for sx in CDR sexpr]
+    [DNameApplyID,
+         [DNameStringID,: StringToCompStr '"->"],
+              [DNameTupleID, : CDR args],
+                 [DNameTupleID, CAR args]]
+  name0 :=   [DNameStringID, : StringToCompStr SYMBOL_-NAME CAR sexpr]
+  CAR sexpr = 'Union or CAR sexpr = 'Record =>
+    [DNameApplyID, name0, 
+        [DNameTupleID,: [ SExprToDName(sx, 'T) for sx in CDR sexpr]]]
+  newCosig := CDR GETDATABASE(CAR sexpr, QUOTE COSIG)
+  [DNameApplyID, name0,
+   : MAPCAR(function SExprToDName, CDR sexpr, newCosig)]
+
+-- local garbage because Compiler strings are null terminated
+StringToCompStr(str) == 
+   CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0))
+
+CompStrToString(str) == 
+   SUBSTRING(str, 0, (LENGTH str - 1))
+-- local garbage ends
+
+runOldAxiomFunctor(:allArgs) ==
+  [:args,env] := allArgs
+  GETDATABASE(env, 'CONSTRUCTORKIND) = 'category =>
+      [$oldAxiomPreCategoryDispatch,: [env, :args]]
+  dom:=APPLY(env, args)
+  makeOldAxiomDispatchDomain dom
+
+makeLazyOldAxiomDispatchDomain domform ==
+  attribute? domform =>
+      [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)]
+  GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category =>
+      [$oldAxiomPreCategoryDispatch,: domform]
+  dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform]
+  NCONC(dd,dd) -- installs back pointer to head of domain.
+  dd
+
+makeOldAxiomDispatchDomain dom ==
+  PAIRP dom => dom
+  [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom]
+
+closeOldAxiomFunctor(name) ==
+   [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name]
+
+lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) ==
+  dom := instantiate domenv
+  SPADCALL(CDR dom, self, op, sig, box, skipdefaults, CAR(dom).3)
+
+lazyOldAxiomDomainHashCode(domenv, env) == CAR domenv
+
+lazyOldAxiomDomainDevaluate(domenv, env) ==
+  dom := instantiate domenv
+  SPADCALL(CDR dom, CAR(dom).1)
+
+lazyOldAxiomAddChild(domenv, kid, env) ==
+  CONS($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)
+   CONS($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], T)
+
+$oldAxiomPreCategoryDispatch :=
+   VECTOR('oldAxiomPreCategory,
+          [function oldAxiomPreCategoryDevaluate],
+          [nil],
+          [nil],
+          [function oldAxiomPreCategoryHashCode],
+          [function oldAxiomPreCategoryBuild],
+          [nil])
+
+oldAxiomCategoryDevaluate([[op,:args],:.], env) ==
+   SExprToDName([op,:devaluateList args], T)
+
+oldAxiomPreCategoryParents(catform,dom) ==
+  vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)]
+  vals := [dom,:rest catform]
+  -- parents :=  GETDATABASE(opOf catform, 'PARENTS)
+  parents := parentsOf opOf catform
+  PROGV(vars, vals,
+    LIST2VEC
+      [EVAL quoteCatOp cat for [cat,:pred] in parents | EVAL pred])
+
+quoteCatOp cat == 
+   atom cat => MKQ cat
+   ['LIST, MKQ CAR cat,: CDR cat]
+
+
+oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) ==
+   [catform,hash, pack,:.] := catenv
+   opIsHasCat op => if EQL(sig, hash) then [self] else nil
+   NULL(pack) => nil
+   if not VECP pack then
+       pack:=apply(pack, CONS(self, rest catform))
+       RPLACA(CDDR catenv, pack)
+   fun := basicLookup(op, sig, pack, self) => [fun]
+   nil
+
+oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents
+oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) ==
+  catform := ELT(parvec, n-1)
+  VECTORP KAR catform => catform
+  newcat := oldAxiomPreCategoryBuild(catform,dom,nil)
+  SETELT(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 SYMBOL_-NAME name
+
+attributeLookupExport(attrObj, self, op, sig, box, env) ==
+   [name, hash] := attrObj
+   opIsHasCat op => if EQL(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
+
+
+orderedDefaults(conform,domform) ==
+  $depthAssocCache : local := MAKE_-HASHTABLE 'ID
+  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]
+  NREVERSE acc
+
+instantiate domenv ==
+   -- following is a patch for a bug in runtime.as
+   -- has a lazy dispatch vector with an instantiated domenv
+  VECTORP CDR domenv => [$oldAxiomDomainDispatch ,: domenv]
+  callForm := CADR domenv
+  oldDom := CDDR domenv
+  [functor,:args] := callForm
+--  if null(fn := GETL(functor,'instantiate)) then
+--     ofn := SYMBOL_-FUNCTION functor
+--     loadFunctor functor
+--     fn := SYMBOL_-FUNCTION functor
+--     SETF(SYMBOL_-FUNCTION functor, ofn)
+--     PUT(functor, 'instantiate, fn)
+--  domvec := APPLY(fn, args)
+  domvec := APPLY(functor, args)
+  RPLACA(oldDom, $oldAxiomDomainDispatch)
+  RPLACD(oldDom, [CADR 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 := CDR domenv
+     if hashCode? op then
+         EQL(op, $hashOp1) => op := 'One
+         EQL(op, $hashOp0) => op := 'Zero
+         EQL(op, $hashOpApply) => op := 'elt
+         EQL(op, $hashOpSet) => op := 'setelt
+         EQL(op, $hashSeg) => op := 'SEGMENT
+     constant := nil
+     if hashCode? sig and self and EQL(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
+     RPLACA(box, val)
+     box
+     
+oldAxiomDomainHashCode(domenv, env) == CAR domenv
+
+oldAxiomDomainHasCategory(domenv, cat, env) ==
+  HasAttribute(domvec := CDR domenv, cat) or
+    HasCategory(domvec, devaluate cat)
+
+oldAxiomDomainDevaluate(domenv, env) == 
+   SExprToDName(CDR(domenv).0, 'T)
+
+oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv)
+
+$oldAxiomDomainDispatch :=
+   VECTOR('oldAxiomDomain,
+          [function oldAxiomDomainDevaluate],
+          [nil],
+          [function oldAxiomDomainLookupExport],
+          [function oldAxiomDomainHashCode],
+          [function oldAxiomAddChild])
+
+basicLookupCheckDefaults(op,sig,domain,dollar) ==
+  box := [nil]
+  not VECP(dispatch := CAR dollar) => error "bad domain format"
+  lookupFun := dispatch.3
+  dispatch.0 = 0  =>  -- new compiler domain object
+       hashPercent :=
+          VECP dollar => hashType(dollar.0,0)
+          hashType(dollar,0)
+
+       hashSig :=
+         hashCode? sig => sig
+         hashType( ['Mapping,:sig], hashPercent)
+
+       if SYMBOLP op then op := hashString SYMBOL_-NAME op
+       CAR SPADCALL(CDR dollar, dollar, op, hashSig, box, not $lookupDefaults, lookupFun)
+  CAR SPADCALL(CDR dollar, dollar, op, sig, box, not $lookupDefaults, lookupFun)
+
+$hasCatOpHash := hashString '"%%"
+opIsHasCat op ==
+  hashCode? op => EQL(op, $hasCatOpHash)
+  EQ(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 := nil
+  u := lookupInDomainVector(op,sig,domvec,dollar) => u
+  $lookupDefaults := true
+  lookupInDomainVector(op,sig,domvec,dollar)
+
+oldCompLookupNoDefaults(op, sig, domvec, dollar) ==
+  $lookupDefaults:local := nil
+  lookupInDomainVector(op,sig,domvec,dollar)
+
+hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) ==
+  opIsHasCat op =>
+      HasCategory(domain, sig)
+  if hashCode? op and EQL(op, $hashOp1) then op := 'One
+  if hashCode? op and EQL(op, $hashOp0) then op := 'Zero
+  hashPercent :=
+    VECP dollar => hashType(dollar.0,0)
+    hashType(dollar,0)
+  if hashCode? sig and EQL(sig, hashPercent) then 
+         sig := hashType('(Mapping $), hashPercent)
+  dollar = nil => systemError()
+  $lookupDefaults = true =>
+    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 := domain.3
+  max := MAXINDEX opvec
+  k := getOpCode(op,opvec,max) or return
+    flag => newLookupInAddChain(op,sig,domain,dollar)
+    nil
+  maxIndex := MAXINDEX numvec
+  start := ELT(opvec,k)
+  finish :=
+    QSGREATERP(max,k) => opvec.(QSPLUS(k,2))
+    maxIndex
+  if QSGREATERP(finish,maxIndex) 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 isDefaultPackageForm? devaluate domain
+  while finish > start repeat
+    PROGN
+      i := start
+      numTableArgs :=numvec.i
+      predIndex := numvec.(i := QSADD1 i)
+      (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 = 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)),
+            dollar,domain) for j in 0..numTableArgs]
+        if $monitorNewWorld then
+          sayBrightly [formatOpSignature(op,sig),'"--?-->",
+            formatOpSignature(op,subsumptionSig)]
+        nil
+      slot := domain.loc
+      null atom slot =>
+        EQ(QCAR slot,'newGoGet) => someMatch:=true
+                   --treat as if operation were not there
+        --if EQ(QCAR slot,'newGoGet) then
+        --  UNWIND_-PROTECT --break infinite recursion
+        --    ((SETELT(domain,loc,'skip); slot := replaceGoGetSlot QCDR slot),
+        --      if domain.loc = 'skip then domain.loc := slot)
+        return (success := slot)
+      slot = 'skip =>       --recursive call from above 'replaceGoGetSlot
+        return (success := newLookupInAddChain(op,sig,domain,dollar))
+      systemError '"unexpected format"
+    start := QSPLUS(start,QSPLUS(numTableArgs,4))
+  (success ^= 'failed) and success =>
+    if $monitorNewWorld then
+      sayLooking1('"<----",uu) where uu() ==
+        PAIRP 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 := dom.4
+  catVec := CADR slot4
+  SIZE catVec = 0 => nil                      --early exit if no categories
+  INTEGERP KDR catVec.0 =>
+    newLookupInCategories1(op,sig,dom,dollar) --old style
+  $lookupDefaults : local := nil
+  if $monitorNewWorld = true then sayBrightly concat('"----->",
+    form2String devaluate dom,'"-----> searching default packages for ",op)
+  predvec := dom.3
+  packageVec := QCAR 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 := [MKQ val for val in valueList]
+  nsig := MSUBST(dom.0,dollar.0,sig)
+  for i in 0..MAXINDEX packageVec |
+       (entry := packageVec.i) and entry ^= 'T repeat
+    package :=
+      VECP entry =>
+         if $monitorNewWorld then
+           sayLooking1('"already instantiated cat package",entry)
+         entry
+      IDENTP entry =>
+        cat := catVec.i
+        packageForm := nil
+        if not GETL(entry,'LOADED) then loadLib entry
+        infovec := GETL(entry,'infovec)
+        success :=
+          --VECP 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 => SIZE byteVector
+              opvec.(code+2)
+            --not nrunNumArgCheck(#(QCDR sig),byteVector,opvec.code,endPos) => nil
+            --numOfArgs := byteVector.(opvec.code)
+            --numOfArgs ^= #(QCDR sig) => nil
+            packageForm := [entry,'$,:CDR cat]
+            package := evalSlotDomain(packageForm,dom)
+            packageVec.i := package
+            package
+                           ----old world
+          table := HGET($Slot1DataBase,entry) or systemError nil
+          (u := LASSQ(op,table))
+            and (v := or/[rest x for x in u]) =>
+              packageForm := [entry,'$,:CDR cat]
+              package := evalSlotDomain(packageForm,dom)
+              packageVec.i := package
+              package
+          nil
+        null success =>
+          if $monitorNewWorld = true 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 = true then
+        sayBrightly '"candidate default package succeeds"
+      return res
+    if $monitorNewWorld = true then
+      sayBrightly '"candidate fails -- continuing to search categories"
+    nil
+
+HasAttribute(domain,attrib) ==
+  hashPercent :=
+       VECP domain => hashType(domain.0,0)
+       hashType(domain,0)
+  isDomain domain =>
+     FIXP((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)
+-->
+  isNewWorldDomain domain => newHasAttribute(domain,attrib)
+--+
+  (u := LASSOC(attrib,domain.2)) and lookupPred(first u,domain,domain)
+ 
+newHasAttribute(domain,attrib) ==
+  hashPercent :=
+       VECP 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 =>
+    EQ(predIndex,0) => true
+    predvec := domain.3
+    testBitVector(predvec,predIndex)
+  false
+
+newHasCategory(domain,catform) ==
+  catform = '(Type) => true  
+  slot4 := domain.4
+  auxvec := CAR slot4
+  catvec := CADR slot4
+  $isDefaultingPackage: local := isDefaultPackageForm? devaluate domain
+  #catvec > 0 and INTEGERP KDR catvec.0 =>              --old style
+    predIndex := lazyMatchAssocV1(catform,catvec,domain)
+    null predIndex => false
+    EQ(predIndex,0) => true
+    predvec := QVELT(domain,3)
+    testBitVector(predvec,predIndex)
+  lazyMatchAssocV(catform,auxvec,catvec,domain)         --new style
+
+getCatForm(catvec, index, domain) ==
+   NUMBERP(form := QVELT(catvec,index)) => domain.form
+   form
+
+has(domain,catform') == HasCategory(domain,catform')
+
+HasCategory(domain,catform') ==
+  catform' is ['SIGNATURE,:f] => HasSignature(domain,f)
+  catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f)
+  isDomain domain =>
+     FIXP((first domain).0) =>
+        catform' := devaluate catform'
+        basicLookup("%%",catform',domain,domain)
+     HasCategory(CDDR domain, catform')
+  catform:= devaluate catform'
+  isNewWorldDomain domain => newHasCategory(domain,catform)
+  domain0:=domain.0 -- handles old style domains, Record, Union etc.
+  slot4 := domain.4
+  catlist := slot4.1
+  member(catform,catlist) or
+   MEMQ(opOf(catform),'(Object Type)) or  --temporary hack
+    or/[compareSigEqual(catform,cat,domain0,domain) for cat in catlist]
+
+--systemDependentMkAutoload(fn,cnam) ==
+--    FBOUNDP(cnam) => "next"
+--    SETF(SYMBOL_-FUNCTION cnam,mkAutoLoad(fn, cnam))
+