aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/ChangeLog44
-rw-r--r--src/boot/ast.boot8
-rw-r--r--src/boot/strap/ast.clisp13
-rw-r--r--src/boot/strap/translator.clisp8
-rw-r--r--src/boot/strap/utility.clisp17
-rw-r--r--src/boot/translator.boot6
-rw-r--r--src/boot/utility.boot9
-rw-r--r--src/interp/astr.boot9
-rw-r--r--src/interp/br-con.boot6
-rw-r--r--src/interp/br-op1.boot10
-rw-r--r--src/interp/br-saturn.boot2
-rw-r--r--src/interp/buildom.boot2
-rw-r--r--src/interp/c-util.boot16
-rw-r--r--src/interp/category.boot10
-rw-r--r--src/interp/clam.boot2
-rw-r--r--src/interp/compiler.boot2
-rw-r--r--src/interp/define.boot4
-rw-r--r--src/interp/functor.boot20
-rw-r--r--src/interp/g-util.boot13
-rw-r--r--src/interp/i-coerce.boot16
-rw-r--r--src/interp/i-coerfn.boot2
-rw-r--r--src/interp/i-funsel.boot40
-rw-r--r--src/interp/i-map.boot3
-rw-r--r--src/interp/i-object.boot2
-rw-r--r--src/interp/i-output.boot2
-rw-r--r--src/interp/i-resolv.boot8
-rw-r--r--src/interp/i-special.boot4
-rw-r--r--src/interp/i-syscmd.boot28
-rw-r--r--src/interp/i-util.boot2
-rw-r--r--src/interp/int-top.boot8
-rw-r--r--src/interp/lisplib.boot2
-rw-r--r--src/interp/macros.lisp4
-rw-r--r--src/interp/msg.boot8
-rw-r--r--src/interp/posit.boot4
-rw-r--r--src/interp/spad.lisp2
-rw-r--r--src/interp/spaderror.lisp2
-rw-r--r--src/interp/sys-utility.boot9
-rw-r--r--src/interp/termrw.boot4
-rw-r--r--src/interp/trace.boot2
-rw-r--r--src/interp/util.lisp4
-rw-r--r--src/interp/vmlisp.lisp65
41 files changed, 217 insertions, 205 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 8bc23caa..b4ae0df6 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,47 @@
+2011-10-01 Gabriel Dos Reis <gdr@cse.tamu.edu>
+
+ * boot/utility.boot (objectAssoc): New. Export.
+ * boot/ast.boot: Use it. instead of ASSOC.
+ * boot/translator.boot (packageBody): Tidy.
+ * interp/astr.boot: Use objectAssoc instead of ASSQ.
+ * interp/br-con.boot: Likewise.
+ * interp/br-op1.boot: Likewise.
+ * interp/br-saturn.boot: Likewise.
+ * interp/buildom.boot: Likewise.
+ * interp/c-util.boot: Likewise.
+ * interp/category.boot: Likewise.
+ * interp/clam.boot: Likewise.
+ * interp/compiler.boot: Likewise.
+ * interp/define.boot: Likewise.
+ * interp/functor.boot: Likewise.
+ * interp/g-util.boot: Likewise.
+ * interp/i-coerce.boot: Likewise.
+ * interp/i-coerfn.boot: Likewise.
+ * interp/i-funsel.boot: Likewise.
+ * interp/i-object.boot: Likewise.
+ * interp/i-output.boot: Likewise.
+ * interp/i-resolv.boot: Likewise.
+ * interp/i-special.boot: Likewise.
+ * interp/i-syscmd.boot: Likewise.
+ * interp/i-util.boot: Likewise.
+ * interp/int-top.boot: Likewise.
+ * interp/lisplib.boot: Likewise.
+ * interp/msg.boot: Likewise.
+ * interp/posit.boot: Likewise.
+ * interp/termrw.boot: Likewise.
+ * interp/trace.boot: Likewise.
+ * interp/sys-utility.boot (upwardCut): New.
+ * interp/spad.lisp: Use it.
+ * interp/util.lisp: Likewise.
+ * interp/spaderror.lisp: Likewise.
+ * interp/vmlisp.lisp (ASSEMBLE): Remove.
+ (ASSQ): Likewise.
+ (MEMQ): Likewise.
+ (NAMEDERRSET): Likewise.
+ (ORADDTEMPDEFS): Likewise.
+ * interp/macros.lisp (QLASSQ): Move to vmlisp.lisp.
+ (LASSQ): Remove.
+
2011-10-01 Gabriel Dos Reis <gdr@cs.tamu.edu>
* boot/parser.boot (bpImport): Accept long names for used namespaces.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 25c1b01e..082ca6e2 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1457,7 +1457,7 @@ unknownNativeTypeError t ==
nativeType t ==
t = nil => t
t isnt [.,:.] =>
- t' := rest ASSOC(coreSymbol t,$NativeTypeTable) =>
+ t' := rest objectAssoc(coreSymbol t,$NativeTypeTable) =>
t' :=
%hasFeature KEYWORD::SBCL => bfColonColon("SB-ALIEN", t')
%hasFeature KEYWORD::CLISP => bfColonColon("FFI",t')
@@ -1710,7 +1710,7 @@ genCLISPnativeTranslation(op,s,t,op') ==
call :=
[n,:[actualArg(p,localPairs) for p in parms]] where
actualArg(p,pairs) ==
- a' := rest ASSOC(p,pairs) => rest rest a'
+ a' := rest objectAssoc(p,pairs) => rest rest a'
p
-- Fix up the call if there is any `write' parameter.
call :=
@@ -1792,8 +1792,8 @@ genCLOZUREnativeTranslation(op,s,t,op') ==
where
args() == [:[x, parm] for x in argtypes for p in parms]
parm() ==
- p' := ASSOC(p, strPairs) => rest p'
- p' := ASSOC(p, aryPairs) => rest p'
+ p' := objectAssoc(p, strPairs) => rest p'
+ p' := objectAssoc(p, aryPairs) => rest p'
p
-- If the foreign call returns a C-string, turn it into a Lisp string.
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 6f4c96da..6a92bd8d 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -2448,7 +2448,9 @@
(COND ((NULL |t|) |t|)
((NOT (CONSP |t|))
(COND
- ((SETQ |t'| (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|)))
+ ((SETQ |t'|
+ (CDR
+ (|objectAssoc| (|coreSymbol| |t|) |$NativeTypeTable|)))
(SETQ |t'|
(COND
((|%hasFeature| :SBCL) (|bfColonColon| 'SB-ALIEN |t'|))
@@ -3109,7 +3111,8 @@
(DEFUN |genCLISPnativeTranslation,actualArg| (|p| |pairs|)
(PROG (|a'|)
(RETURN
- (COND ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|))) (T |p|)))))
+ (COND ((SETQ |a'| (CDR (|objectAssoc| |p| |pairs|))) (CDR (CDR |a'|)))
+ (T |p|)))))
(DEFUN |getCLISPType| (|a|) (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|)))
@@ -3255,10 +3258,12 @@
(LIST |x|
(COND
((SETQ |p'|
- (ASSOC |p| |strPairs|))
+ (|objectAssoc| |p|
+ |strPairs|))
(CDR |p'|))
((SETQ |p'|
- (ASSOC |p| |aryPairs|))
+ (|objectAssoc| |p|
+ |aryPairs|))
(CDR |p'|))
(T |p|)))))
(COND ((NULL |bfVar#13|) NIL)
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 7ce79ebe..c39dcf5b 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -601,11 +601,9 @@
(COND ((|%hasFeature| :SBCL) 'SB-ALIEN)
((|%hasFeature| :CLISP) 'FFI)
((|%hasFeature| :CLOZURE) 'CCL)
- ((|%hasFeature| :ECL) 'EXT) ((|%hasFeature| :GCL) 'SI)
- (T NIL)))
- ((|ident?| |ns|) |ns|) (T NIL)))
- (COND ((NULL |z|) (|bpTrap|))
- (T (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |z|) |user|)))))))
+ ((|%hasFeature| :ECL) 'FFI) (T (RETURN NIL))))
+ ((|ident?| |ns|) |ns|) (T (|bpTrap|))))
+ (CONS 'USE-PACKAGE (CONS (SYMBOL-NAME |z|) |user|)))))
((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN))
(CONS (CAR |x|)
(LET ((|bfVar#2| NIL)
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index 8a06ff0c..7125bd09 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -48,6 +48,12 @@
(FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) (|%List| |%Thing|)) |remove|))
(DECLAIM
+ (FTYPE
+ (FUNCTION (|%Thing| (|%List| (|%Pair| |%Thing| |%Thing|)))
+ (|%Maybe| (|%Pair| |%Thing| |%Thing|)))
+ |objectAssoc|))
+
+(DECLAIM
(FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
|setDifference|))
@@ -329,6 +335,17 @@
((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|))
(T (|removeValue| |l| |x|))))
+(DEFUN |objectAssoc| (|x| |l|)
+ (PROG (|a| |p|)
+ (RETURN
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
+ (RETURN NIL))
+ ((AND (CONSP |p|) (PROGN (SETQ |a| (CAR |p|)) T) (EQ |a| |x|))
+ (RETURN |p|)))))))
+
(DEFUN |charPosition| (|c| |s| |k|)
(PROG (|n|)
(RETURN
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index f7a6fc36..36f61662 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -434,11 +434,9 @@ packageBody(x,p) ==
%hasFeature KEYWORD::CLISP => 'FFI
%hasFeature KEYWORD::CLOZURE => 'CCL
%hasFeature KEYWORD::ECL => 'FFI
- %hasFeature KEYWORD::GCL => 'SI
- nil
+ return nil
ident? ns => ns
- nil
- z = nil => bpTrap()
+ bpTrap()
['USE_-PACKAGE,symbolName z,:user]
x is ['PROGN,:.] => [x.op,:[packageBody(y,p) for y in x.args]]
x
diff --git a/src/boot/utility.boot b/src/boot/utility.boot
index 4d4d5961..44c20d2c 100644
--- a/src/boot/utility.boot
+++ b/src/boot/utility.boot
@@ -47,7 +47,7 @@ module utility (objectMember?, symbolMember?, stringMember?,
charMember?, scalarMember?, listMember?, reverse, reverse!,
lastNode, append, append!, copyList, substitute, substitute!,
setDifference, setUnion, setIntersection,
- applySubst, applySubst!, applySubstNQ,
+ applySubst, applySubst!, applySubstNQ, objectAssoc,
remove,removeSymbol,atomic?,finishLine) where
substitute: (%Thing,%Thing,%Thing) -> %Thing
substitute!: (%Thing,%Thing,%Thing) -> %Thing
@@ -57,6 +57,8 @@ module utility (objectMember?, symbolMember?, stringMember?,
lastNode: %List %Thing -> %Maybe %Node %Thing
removeSymbol: (%List %Thing, %Symbol) -> %List %Thing
remove: (%List %Thing, %Thing) -> %List %Thing
+ objectAssoc: (%Thing, %List %Pair(%Thing,%Thing)) ->
+ %Maybe %Pair(%Thing,%Thing)
setDifference: (%List %Thing,%List %Thing) -> %List %Thing
setUnion: (%List %Thing,%List %Thing) -> %List %Thing
setIntersection: (%List %Thing,%List %Thing) -> %List %Thing
@@ -291,6 +293,11 @@ remove(l,x) ==
--% search
+objectAssoc(x,l) ==
+ repeat
+ l isnt [p,:l] => return nil
+ p is [a,:.] and sameObject?(a,x) => return p
+
++ Return the index of the character `c' in the string `s', if present.
++ Otherwise, return nil.
charPosition(c,s,k) ==
diff --git a/src/interp/astr.boot b/src/interp/astr.boot
index abbac83c..b68250a5 100644
--- a/src/interp/astr.boot
+++ b/src/interp/astr.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
@@ -61,9 +61,8 @@ ncAlist x ==
--- Get the entry for key k on x's association list
ncEltQ(x,k) ==
- r := QASSQ(k,ncAlist x)
- null r => ncBug ('S2CB0007,[k])
- rest r
+ r := objectAssoc(k,ncAlist x) => rest r
+ ncBug ('S2CB0007,[k])
-- Put (k . v) on the association list of x and return v
-- case1: ncPutQ(x,k,v) where k is a key (an identifier), v a value
@@ -74,7 +73,7 @@ ncPutQ(x,k,v) ==
LISTP k =>
for key in k for val in v repeat ncPutQ(x,key,val)
v
- r := QASSQ(k,ncAlist x)
+ r := objectAssoc(k,ncAlist x)
if null r then
r := [[k,:v], :ncAlist x]
x.first := [ncTag x,:r]
diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot
index 63c27d71..1719a767 100644
--- a/src/interp/br-con.boot
+++ b/src/interp/br-con.boot
@@ -49,7 +49,7 @@ namespace BOOT
-- [mathform2HtString x for x in rest a]
-- if cons? a then a := first a
-- da := DOWNCASE a
--- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) =>
+-- pageName := QLASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) =>
-- downlink pageName --special jump out for primitive domains
-- line := conPageFastPath a => kPage line --lower case name of cons?
-- line := conPageFastPath UPCASE a => kPage line --upper case an abbr?
@@ -65,7 +65,7 @@ conPage(a,:b) ==
$conArgstrings: local := [form2HtString x for x in KDR a]
if cons? a then a := first a
da := DOWNCASE a
- pageName := LASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) =>
+ pageName := QLASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) =>
downlink pageName --special jump out for primitive domains
line := conPageFastPath da => kPage(line,form) --lower case name of cons?
line := conPageFastPath UPCASE a => kPage(line,form) --upper case an abbr?
@@ -77,7 +77,7 @@ conPageFastPath x == --called by conPage and constructorSearch
charPosition(char "*",s,0) < #s => nil --quit if name has * in it
name := (string? x => makeSymbol x; x)
entry := tableValue($lowerCaseConTb,name) or return nil
- lineNumber := LASSQ('dbLineNumber,CDDR entry) =>
+ lineNumber := QLASSQ('dbLineNumber,CDDR entry) =>
--'dbLineNumbers property is set by function dbAugmentConstructorDataTable
dbRead lineNumber --read record for constructor from libdb.text
conPageConEntry first entry
diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot
index 9ccfde7d..49752fd0 100644
--- a/src/interp/br-op1.boot
+++ b/src/interp/br-op1.boot
@@ -525,20 +525,20 @@ dbShowOpAllDomains(htPage,opAlist,which) ==
for [.,predicate,origin,:.] in items repeat
conname := first origin
getConstructorKindFromDB conname = "category" =>
- pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true)
+ pred := simpOrDumb(predicate,QLASSQ(conname,catOriginAlist) or true)
catOriginAlist := insertAlist(conname,pred,catOriginAlist)
- pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true)
+ pred := simpOrDumb(predicate,QLASSQ(conname,domOriginAlist) or true)
domOriginAlist := insertAlist(conname,pred,domOriginAlist)
--the following is similar to "domainsOf" but do not sort immediately
u := [COPY key for [key,:.] in entries _*HASCATEGORY_-HASH_*
- | LASSQ(rest key,catOriginAlist)]
+ | QLASSQ(rest key,catOriginAlist)]
for pair in u repeat
[dom,:cat] := pair
- LASSQ(cat,catOriginAlist) is 'etc => pair.rest := 'etc
+ QLASSQ(cat,catOriginAlist) is 'etc => pair.rest := 'etc
pair.rest := simpOrDumb(constructorHasCategoryFromDB pair,true)
--now add all of the domains
for [dom,:pred] in domOriginAlist repeat
- u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u)
+ u := insertAlist(dom,simpOrDumb(pred,QLASSQ(dom,u) or true),u)
cAlist := listSort(function GLESSEQP,u)
for pair in cAlist repeat
pair.first := getConstructorForm first pair
diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot
index 9fad03b0..d7bba66f 100644
--- a/src/interp/br-saturn.boot
+++ b/src/interp/br-saturn.boot
@@ -735,7 +735,7 @@ $exampleConstructors := nil
saturnHasExamplePage conname ==
if not $exampleConstructors then
$exampleConstructors := getSaturnExampleList()
- ASSQ(conname, $exampleConstructors)
+ objectAssoc(conname, $exampleConstructors)
getSaturnExampleList() ==
file := strconc(systemRootDirectory(), "/doc/axug/examples.lsp")
diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot
index 386e11d8..33feca63 100644
--- a/src/interp/buildom.boot
+++ b/src/interp/buildom.boot
@@ -277,7 +277,7 @@ lookupInTable(op,sig,dollar,[domain,table]) ==
table is "derived" => lookupInAddChain(op,sig,domain,dollar)
success := nil -- lookup result
someMatch := false
- while not success for [sig1,:code] in LASSQ(op,table) repeat
+ while not success for [sig1,:code] in QLASSQ(op,table) repeat
success :=
not compareSig(sig,sig1,canonicalForm dollar,domain) => false
code is ['Subsumed,a] =>
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index c5131859..4e209b84 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -636,10 +636,12 @@ TrimCF() ==
new:= nil
old:= CAAR $CategoryFrame
for u in old repeat
- if not ASSQ(first u,new) then
+ if objectAssoc(first u,new) = nil then
uold:= rest u
unew:= nil
- for v in uold repeat if not ASSQ(first v,unew) then unew:= [v,:unew]
+ for v in uold repeat
+ if objectAssoc(first v,unew) = nil then
+ unew:= [v,:unew]
new:= [[first u,:reverse! unew],:new]
$CategoryFrame:= [[reverse! new]]
nil
@@ -766,7 +768,7 @@ isDomainInScope(domain,e) ==
not ident? domain or isSomeDomainVariable domain => true
false
(name:= first domain)="Category" => true
- ASSQ(name,domainList) => true
+ objectAssoc(name,domainList) => true
-- null rest domain or domainMember(domain,domainList) => true
-- false
isFunctor name => false
@@ -1008,8 +1010,8 @@ extendsCategoryForm(domain,form,form') ==
getmode(x,e) ==
prop:=getProplist(x,e)
- u:= LASSQ("value",prop) => u.mode
- LASSQ("mode",prop)
+ u := QLASSQ("value",prop) => u.mode
+ QLASSQ("mode",prop)
getmodeOrMapping(x,e) ==
u:= getmode(x,e) => u
@@ -1041,7 +1043,7 @@ sublisV(p,e) ==
string? e => e
-- no need to descend vectors unless they are categories
categoryObject? e => vector [suba(p,e.i) for i in 0..maxIndex e]
- e isnt [.,:.] => (y:= ASSQ(e,p) => rest y; e)
+ e isnt [.,:.] => (y := objectAssoc(e,p) => rest y; e)
u:= suba(p,first e)
v:= suba(p,rest e)
sameObject?(first e,u) and sameObject?(rest e,v) => e
@@ -1495,7 +1497,7 @@ backendCompile2 code ==
code isnt [name,[type,args,:body],:junk] or junk ~= nil =>
systemError ['"parenthesis error in: ", code]
type = "SLAM" => backendCompileSLAM(name,args,body)
- LASSQ(name,$clamList) => compClam(name,args,body,$clamList)
+ QLASSQ(name,$clamList) => compClam(name,args,body,$clamList)
type = "SPADSLAM" => backendCompileSPADSLAM(name,args,body)
type = "ILAM" => backendCompileILAM(name,args,body)
body := [name,[type,args,:body]]
diff --git a/src/interp/category.boot b/src/interp/category.boot
index 5e9ff863..3e14a9b3 100644
--- a/src/interp/category.boot
+++ b/src/interp/category.boot
@@ -313,17 +313,17 @@ FindFundAncs(l,e) ==
ans := FindFundAncs(rest l,e)
for u in FindFundAncs([[CatEval(first x,e),mkAnd(CADAR l,second x,e)]
for x in categoryAncestors f1],e) repeat
- x:= ASSQ(first u,ans) =>
+ x:= objectAssoc(first u,ans) =>
ans:= [[first u,mkOr(second x,second u,e)],:remove(ans,x)]
ans:= [u,:ans]
--testing to see if first l is already there
- x:= ASSQ(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,second x,e)],:remove(ans,x)]
+ x := objectAssoc(CAAR l,ans) => [[CAAR l,mkOr(CADAR l,second x,e)],:remove(ans,x)]
CADAR l=true =>
for x in categoryPrincipals f1 repeat
- if y:= ASSQ(CatEval(x,e),ans) then ans := remove(ans,y)
+ if y := objectAssoc(CatEval(x,e),ans) then ans := remove(ans,y)
[first l,:ans]
for x in categoryPrincipals f1 repeat
- if y:= ASSQ(CatEval(x,e),ans) then ans:=
+ if y := objectAssoc(CatEval(x,e),ans) then ans:=
[[first y,mkOr(CADAR l,second y,e)],:remove(ans,y)]
[first l,:ans]
-- Our new thing may have, as an alternate view, a principal
@@ -468,7 +468,7 @@ JoinInner(l,$e) ==
-- bname,
-- " replacing",
-- first anc)
- bCond:= ASSQ(b,CondList)
+ bCond := objectAssoc(b,CondList)
CondList := remove(CondList,bCond)
-- value of bCond not used and could be nil
-- bCond:= second bCond
diff --git a/src/interp/clam.boot b/src/interp/clam.boot
index 3bde0e83..eabd822e 100644
--- a/src/interp/clam.boot
+++ b/src/interp/clam.boot
@@ -78,7 +78,7 @@ $failed := '"failed"
compClam(op,argl,body,$clamList) ==
--similar to reportFunctionCompilation in SLAM BOOT
if $InteractiveMode then startTimingProcess 'compilation
- if (u:= LASSQ(op,$clamList)) isnt [kind,eqEtc,:options]
+ if (u := QLASSQ(op,$clamList)) isnt [kind,eqEtc,:options]
then keyedSystemError("S2GE0004",[op])
$clamList:= nil --clear to avoid looping
if u:= S_-(options,'(shift count)) then
diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot
index 519f31dd..39a3f765 100644
--- a/src/interp/compiler.boot
+++ b/src/interp/compiler.boot
@@ -256,7 +256,7 @@ freeVarUsage([.,vars,body],env) ==
u isnt [.,:.] =>
not ident? u => free
symbolMember?(u,bound) => free
- v := ASSQ(u,free) =>
+ v := objectAssoc(u,free) =>
v.rest := 1 + rest v
free
getmode(u,e) = nil => free
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 2b3c9ab1..a3911f27 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -1553,7 +1553,7 @@ makeFunctorArgumentParameters(argl,sigl,target) ==
for u in ss repeat
$ConditionalOperators:=[rest u,:$ConditionalOperators]
s is ['Join,:sl] =>
- u:=ASSQ('CATEGORY,ss) =>
+ u := objectAssoc('CATEGORY,ss) =>
MSUBST([:u,:ss],u,s)
['Join,:sl,['CATEGORY,'package,:ss]]
['Join,s,['CATEGORY,'package,:ss]]
@@ -1602,7 +1602,7 @@ mkOpVec(dom,siglist) ==
--new form is (<op> <signature> <slotNumber> <condition> <kind>)
ops := newVector #siglist
for (opSig:= [op,sig]) in siglist for i in 0.. repeat
- u:= ASSQ(op,oplist)
+ u := objectAssoc(op,oplist)
assoc(sig,u) is [.,n,.,'ELT] =>
vectorRef(ops,i) := vectorRef(dom,n)
noplist := applySubst(substargs,u)
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 670fbe22..3860c8e8 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -104,7 +104,7 @@ DomainPrint1(D,brief,$e) ==
uu.5 := vv
for j in 0..maxIndex vv repeat
if vector? vv.j then
- l := ASSQ(vv.j,Sublis)
+ l := objectAssoc(vv.j,Sublis)
if l
then name:= rest l
else
@@ -141,7 +141,7 @@ PacPrint v ==
vv := copyVector v
for j in 0..maxIndex vv repeat
if vector? vv.j then
- l := ASSQ(vv.j,Sublis)
+ l := objectAssoc(vv.j,Sublis)
if l
then name := rest l
else
@@ -151,7 +151,7 @@ PacPrint v ==
$WhereList := [[name,:vv.j],:$WhereList]
vv.j := name
if cons? vv.j and vector?(u:=rest vv.j) then
- l := ASSQ(u,Sublis)
+ l := objectAssoc(u,Sublis)
if l
then name := rest l
else
@@ -168,9 +168,9 @@ DomainPrintSubst(item,Sublis) ==
c2 := DomainPrintSubst(b,Sublis)
sameObject?(c1,a) and sameObject?(c2,b) => item
[c1,:c2]
- l := ASSQ(item,Sublis)
+ l := objectAssoc(item,Sublis)
l => rest l
- l := ASSQ(item,Sublis)
+ l := objectAssoc(item,Sublis)
l => rest l
item
@@ -309,7 +309,7 @@ worthlessCode x ==
cons5(p,l) ==
l and (CAAR l = first p) => [p,: rest l]
# l < 5 => [p,:l]
- QCDDDDR(l).rest := nil
+ l.rest.rest.rest.rest.rest := nil
[p,:l]
SetDomainSlots124(dom,names,vals) ==
@@ -329,7 +329,7 @@ sublisProp(subst,props) ==
--keep original CONS
cond is ['or,:x] =>
(or/[inspect(u,subst) for u in x] => [a,true,:l]; nil)
- cond is ["has",nam,b] and (val:= ASSQ(nam,subst)) =>
+ cond is ["has",nam,b] and (val := objectAssoc(nam,subst)) =>
ev :=
b is ['ATTRIBUTE,c] => HasAttribute(rest val,c)
b is ['SIGNATURE,c] => HasSignature(rest val,c)
@@ -852,9 +852,9 @@ getCaps x ==
getAbbreviation(name,c) ==
--returns abbreviation of name with c arguments
x := getConstructorAbbreviationFromDB name
- X := ASSQ(x,$abbreviationTable) =>
- N:= ASSQ(name,rest X) =>
- C:= ASSQ(c,rest N) => rest C --already there
+ X := objectAssoc(x,$abbreviationTable) =>
+ N := objectAssoc(name,rest X) =>
+ C := objectAssoc(c,rest N) => rest C --already there
newAbbreviation:= mkAbbrev(X,x)
N.rest := [[c,:newAbbreviation],:rest N]
newAbbreviation
diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot
index 43cc0bef..41a07a51 100644
--- a/src/interp/g-util.boot
+++ b/src/interp/g-util.boot
@@ -313,7 +313,7 @@ putIntSymTab(x,prop,val,e) ==
pl0 := pl := search(x,e)
pl :=
null pl => [[prop,:val]]
- u := ASSQ(prop,pl) =>
+ u := objectAssoc(prop,pl) =>
u.rest := val
pl
lp := lastNode pl
@@ -325,7 +325,7 @@ putIntSymTab(x,prop,val,e) ==
addIntSymTabBinding(var,proplist,e is [[curContour,:.],:.]) ==
-- change proplist of var in e destructively
- u := ASSQ(var,curContour) =>
+ u := objectAssoc(var,curContour) =>
u.rest := proplist
e
first(e).first := [[var,:proplist],:curContour]
@@ -734,14 +734,15 @@ search(x,e is [curEnv,:tailEnv]) ==
searchCurrentEnv(x,currentEnv) ==
for contour in currentEnv repeat
- if u:= ASSQ(x,contour) then return (signal:= u)
+ if u:= objectAssoc(x,contour) then return (signal:= u)
KDR signal
searchTailEnv(x,e) ==
for env in e repeat
signal:=
for contour in env repeat
- if (u:= ASSQ(x,contour)) and ASSQ("FLUID",u) then return (signal:= u)
+ if (u := objectAssoc(x,contour)) and objectAssoc("FLUID",u) then
+ return (signal:= u)
if signal then return signal
KDR signal
@@ -775,14 +776,14 @@ addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) ==
addBindingInteractive(var,proplist,e is [[curContour,:.],:.]) ==
-- change proplist of var in e destructively
- u := ASSQ(var,curContour) =>
+ u := objectAssoc(var,curContour) =>
u.rest := proplist
e
first(e).first := [[var,:proplist],:curContour]
e
augProplistInteractive(proplist,prop,val) ==
- u := ASSQ(prop,proplist) =>
+ u := objectAssoc(prop,proplist) =>
u.rest := val
proplist
[[prop,:val],:proplist]
diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot
index 1a0e5ec0..c668f46a 100644
--- a/src/interp/i-coerce.boot
+++ b/src/interp/i-coerce.boot
@@ -604,8 +604,8 @@ canCoerceTower(t1,t2) ==
canCoerceLocal(t1,t2) ==
-- test for coercion on top level
- p:= ASSQ(first t1,$CoerceTable)
- p and ASSQ(first t2,rest p) is [.,:[tag,fun]] =>
+ p := objectAssoc(first t1,$CoerceTable)
+ p and objectAssoc(first t2,rest p) is [.,:[tag,fun]] =>
tag='partial => nil
tag='total => true
(functionp(fun) and
@@ -619,8 +619,8 @@ canCoerceCommute(t1,t2) ==
-- looks for the existence of a commuting function
symbolMember?(first(t1),(l := [$QuotientField, 'Gaussian])) and
symbolMember?(first(t2),l) => true
- p:= ASSQ(first t1,$CommuteTable)
- p and ASSQ(first t2,rest p) is [.,:['commute,.]]
+ p := objectAssoc(first t1,$CommuteTable)
+ p and objectAssoc(first t2,rest p) is [.,:['commute,.]]
newCanCoerceCommute(t1,t2) ==
coerceIntCommute(objNewWrap("$fromCoerceable$",t1),t2)
@@ -1133,8 +1133,8 @@ coerceIntTableOrFunction(triple,t2) ==
null isValidType t2 => nil -- added 9-18-85 by RSS
null isLegitimateMode(t2,nil,nil) => nil -- added 6-28-87 by RSS
t1 := objMode triple
- p:= ASSQ(first t1,$CoerceTable)
- p and ASSQ(first t2,rest p) is [.,:[tag,fun]] =>
+ p := objectAssoc(first t1,$CoerceTable)
+ p and objectAssoc(first t2,rest p) is [.,:[tag,fun]] =>
val := objVal triple
fun='Identity => objNew(val,t2)
tag='total =>
@@ -1275,8 +1275,8 @@ coerceIntTest(t1,t2) ==
-- thus the type can be bubbled before coerceIntTableOrFunction is called
t1=t2 or
b:=
- p:= ASSQ(first t1,$CoerceTable)
- p and ASSQ(first t2,rest p)
+ p := objectAssoc(first t1,$CoerceTable)
+ p and objectAssoc(first t2,rest p)
b or coerceConvertMmSelection('coerce,t1,t2) or
($useConvertForCoercions and
coerceConvertMmSelection('convert,t1,t2))
diff --git a/src/interp/i-coerfn.boot b/src/interp/i-coerfn.boot
index eba7c9c4..7735ae5d 100644
--- a/src/interp/i-coerfn.boot
+++ b/src/interp/i-coerfn.boot
@@ -302,7 +302,7 @@ Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) ==
e1:= removeVectorElt(e,pos)
y:= coerceInt(objNewWrap([[e1,:c]],S1),T) =>
-- need to be careful about zeros
- p:= ASSQ(exp,x) =>
+ p := objectAssoc(exp,x) =>
c' := SPADCALL(rest p,objValUnwrap(y),plusfunc)
c' = zero => x := REMALIST(x,exp)
p.rest := c'
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index 9b1bd614..513d3a9a 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -690,7 +690,7 @@ getFunctionFromDomain(op,dc,args) ==
isOpInDomain(opName,dom,nargs) ==
-- returns true only if there is an op in the given domain with
-- the given number of arguments
- mmList := ASSQ(opName,getConstructorOperationsFromDB dom.op)
+ mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
null mmList => nil
gotOne := nil
@@ -705,7 +705,7 @@ findCommonSigInDomain(opName,dom,nargs) ==
-- a "signature" where a type position is non-nil only if all
-- signatures shares that type .
dom.op in '(Union Record Mapping) => nil
- mmList := ASSQ(opName,getConstructorOperationsFromDB dom.op)
+ mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
null mmList => nil
gotOne := nil
@@ -720,7 +720,7 @@ findCommonSigInDomain(opName,dom,nargs) ==
findUniqueOpInDomain(op,opName,dom) ==
-- return function named op in domain dom if unique, choose one if not
- mmList := ASSQ(opName,getConstructorOperationsFromDB dom.op)
+ mmList := objectAssoc(opName,getConstructorOperationsFromDB dom.op)
mmList := subCopy(mmList,constructSubst dom)
null mmList =>
throwKeyedMsg("S2IS0021",[opName,dom])
@@ -792,7 +792,7 @@ findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) ==
findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom)
nil
fun:= nil
- ( p := ASSQ(op,getConstructorOperationsFromDB dcName) ) and
+ ( p := objectAssoc(op,getConstructorOperationsFromDB dcName) ) and
SL := constructSubst dc
-- if the arglist is homogeneous, first look for homogeneous
-- functions. If we don't find any, look at remaining ones
@@ -838,7 +838,7 @@ isHomogeneousList y ==
nil
findFunctionInDomain1(omm,op,tar,args1,args2,SL) ==
- dc:= rest (dollarPair := ASSQ('$,SL))
+ dc := rest (dollarPair := objectAssoc('$,SL))
-- need to drop '$ from SL
mm:= subCopy(omm, SL)
-- tests whether modemap mm is appropriate for the function
@@ -1118,14 +1118,14 @@ matchTypes(pm,args1,args2) ==
-- args2 a list of polynomial types for symbols
-- the result is a match from pm to args, if one exists
for v in pm for t1 in args1 for t2 in args2 until $Subst is 'failed repeat
- p:= ASSQ(v,$Subst) =>
+ p := objectAssoc(v,$Subst) =>
t:= rest p
t=t1 => $Coerce and t1 = $Symbol and
- (q := ASSQ(v,$SymbolType)) and t2 and
+ (q := objectAssoc(v,$SymbolType)) and t2 and
(t3 := resolveTT(rest q, t2)) and
(q.rest := t3)
$Coerce =>
- if t = $Symbol and (q := ASSQ(v,$SymbolType)) then
+ if t = $Symbol and (q := objectAssoc(v,$SymbolType)) then
t := rest q
if t1 = $Symbol and t2 then t1:= t2
t0 := resolveTT(t,t1) => p.rest := t0
@@ -1203,7 +1203,7 @@ evalMmCond0(op,sig,st) ==
SL:= evalMmDom st
SL is 'failed => 'failed
for p in SL until p1 and not b repeat b:=
- p1:= ASSQ(first p,$Subst)
+ p1 := objectAssoc(first p,$Subst)
p1 and
t1:= rest p1
t:= rest p
@@ -1286,7 +1286,7 @@ evalMmDom(st) ==
for mmC in st until SL is 'failed repeat
mmC is ['isDomain,v,d] =>
string? d => SL:= 'failed
- p:= ASSQ(v,SL) and not (d=rest p) => SL:= 'failed
+ p := objectAssoc(v,SL) and not (d=rest p) => SL:= 'failed
d1:= subCopy(d,SL)
cons?(d1) and symbolMember?(v,d1) => SL:= 'failed
SL:= augmentSub(v,d1,SL)
@@ -1315,8 +1315,8 @@ orderMmCatStack st ==
SORT(st, function mmCatComp)
mmCatComp(c1, c2) ==
- b1 := ASSQ(second c1, $Subst)
- b2 := ASSQ(second c2, $Subst)
+ b1 := objectAssoc(second c1, $Subst)
+ b2 := objectAssoc(second c2, $Subst)
b1 and null(b2) => true
false
@@ -1346,7 +1346,7 @@ evalMmCat1(mmC is ['ofCategory,d,c],op, SL) ==
$domPvar: local := nil
$hope:= nil
NSL:= hasCate(d,c,SL)
- NSL is 'failed and isPatternVar d and $Coerce and ( p:= ASSQ(d,$Subst) )
+ NSL is 'failed and isPatternVar d and $Coerce and ( p:= objectAssoc(d,$Subst) )
and (rest(p) is ["Variable",:.] or rest(p) = $Symbol) =>
p.rest := getSymbolType d
hasCate(d,c,SL)
@@ -1361,7 +1361,7 @@ evalMmCat1(mmC is ['ofCategory,d,c],op, SL) ==
dom := defaultTypeForCategory(c, SL)
null dom =>
op isnt 'coerce => 'failed -- evalMmCatLastChance(d,c,SL)
- null (p := ASSQ(d,$Subst)) =>
+ null (p := objectAssoc(d,$Subst)) =>
dom =>
NSL := [[d,:dom]]
op isnt 'coerce => 'failed -- evalMmCatLastChance(d,c,SL)
@@ -1376,9 +1376,9 @@ hasCate(dom,cat,SL) ==
-- augments substitution SL or returns 'failed
dom = $EmptyMode => nil
isPatternVar dom =>
- (p:= ASSQ(dom,SL)) and ((NSL := hasCate(rest p,cat,SL)) isnt 'failed) =>
+ (p:= objectAssoc(dom,SL)) and ((NSL := hasCate(rest p,cat,SL)) isnt 'failed) =>
NSL
- (p:= ASSQ(dom,$Subst)) or (p := ASSQ(dom, SL)) =>
+ (p:= objectAssoc(dom,$Subst)) or (p := objectAssoc(dom, SL)) =>
-- S:= hasCate(rest p,cat,augmentSub(first p,rest p,copy SL))
S:= hasCate1(rest p,cat,SL, dom)
S isnt 'failed => S
@@ -1503,12 +1503,12 @@ hasCaty(d,cat,SL) ==
'failed
mkDomPvar(p, d, subs, y) ==
- l := MEMQ(p, $FormalMapVariableList) =>
+ l := upwardCut(p,$FormalMapVariableList) =>
domArg(d, #$FormalMapVariableList - #l, subs, y)
d
domArg(type, i, subs, y) ==
- p := MEMQ($FormalMapVariableList.i, subs) =>
+ p := upwardCut($FormalMapVariableList.i, subs) =>
y.(#subs - #p)
type
@@ -1585,7 +1585,7 @@ hasSig(dom,foo,sig,SL) ==
$domPvar: local := nil
fun:= getConstructorAbbreviationFromDB dom.op =>
S0:= constructSubst dom
- p := ASSQ(foo,getConstructorOperationsFromDB dom.op) =>
+ p := objectAssoc(foo,getConstructorOperationsFromDB dom.op) =>
for [x,.,cond,.] in rest p until S isnt 'failed repeat
S:=
cond isnt [.,:.] => copy SL
@@ -1734,7 +1734,7 @@ isPartialMode m ==
getSymbolType var ==
-- var is a pattern variable
- p:= ASSQ(var,$SymbolType) => rest p
+ p:= objectAssoc(var,$SymbolType) => rest p
t:= '(Polynomial (Integer))
$SymbolType:= [[var,:t],:$SymbolType]
t
diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot
index 45049109..5a25e8e3 100644
--- a/src/interp/i-map.boot
+++ b/src/interp/i-map.boot
@@ -383,8 +383,7 @@ clearDep1(x,toDoList,doneList,depList) ==
clearCache x
newDone:= [x,:doneList]
until null a repeat
- a:= ASSQ(x,depList)
- a =>
+ a := objectAssoc(x,depList) =>
depList := remove(depList,a)
toDoList := setUnion(toDoList,
setDifference(rest a,doneList))
diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot
index 73496c23..dc486e75 100644
--- a/src/interp/i-object.boot
+++ b/src/interp/i-object.boot
@@ -363,7 +363,7 @@ computedMode t ==
--% Other VAT properties
insertShortAlist(prop,val,al) ==
- pair := QASSQ(prop,al) =>
+ pair := objectAssoc(prop,al) =>
pair.rest := val
al
[[prop,:val],:al]
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot
index 0f7eb681..ccb6fcf7 100644
--- a/src/interp/i-output.boot
+++ b/src/interp/i-output.boot
@@ -394,7 +394,7 @@ newlineIfDisplaying() ==
specialChar(symbol) ==
-- looks up symbol in $specialCharacterAlist, gets the index
-- into the EBCDIC table, and returns the appropriate character
- null (code := IFCDR ASSQ(symbol,$specialCharacterAlist)) => '"?"
+ null (code := IFCDR objectAssoc(symbol,$specialCharacterAlist)) => '"?"
$specialCharacters.code
rbrkSch() == symbolName specialChar 'rbrk
diff --git a/src/interp/i-resolv.boot b/src/interp/i-resolv.boot
index 217d81ad..b2e37a7d 100644
--- a/src/interp/i-resolv.boot
+++ b/src/interp/i-resolv.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
@@ -484,7 +484,7 @@ resolveTM1(t,m) ==
m = $Exit => t
containsVars m =>
isPatternVar m =>
- p := ASSQ(m,$Subst) =>
+ p := objectAssoc(m,$Subst) =>
$Coerce =>
tt := resolveTT1(t,rest p) => (p.rest := tt) and tt
nil
@@ -633,8 +633,8 @@ resolveTMEq1(ct,cm) ==
b :=
xt=xm => 'T
isPatternVar(xm) and
- p := ASSQ(xm,$Subst) => xt=rest p
- p := ASSQ(xm,SL) => xt=rest p
+ p := objectAssoc(xm,$Subst) => xt=rest p
+ p := objectAssoc(xm,SL) => xt=rest p
SL := augmentSub(xm,xt,SL)
b => SL
'failed
diff --git a/src/interp/i-special.boot b/src/interp/i-special.boot
index ba2dbd61..b3fd5f40 100644
--- a/src/interp/i-special.boot
+++ b/src/interp/i-special.boot
@@ -1647,7 +1647,7 @@ compileIs(val,pattern) ==
predCode:=["%LET",g:=gensym(),["isPatternMatch",
getArgValue(val,computedMode val),MKQ removeConstruct pattern]]
for var in removeDuplicates vars repeat
- assignCode:=[["%LET",var,["CDR",["ASSQ",MKQ var,g]]],:assignCode]
+ assignCode:=[["%LET",var,["CDR",["objectAssoc",MKQ var,g]]],:assignCode]
null $opIsIs =>
['%when,[["EQ",predCode,MKQ "failed"],["SEQ",:assignCode,'%true]]]
['%when,[['%not,["EQ",predCode,MKQ "failed"]],["SEQ",:assignCode,'%true]]]
@@ -1697,7 +1697,7 @@ isPatMatch(l,pats) ==
$subs:=[[pat,:first l],:$subs]
isPatMatch(rest l,restPats)
pat is ["=",var] =>
- p:=ASSQ(var,$subs) =>
+ p := objectAssoc(var,$subs) =>
first l = rest p => isPatMatch(rest l, restPats)
$subs:="failed"
$subs:="failed"
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index 09b1b3e1..1c48b7c6 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -1487,8 +1487,8 @@ recordNewValue(x,prop,val) ==
recordNewValue0(x,prop,val) ==
-- writes (prop . val) into $HistRecord
-- updateHist writes this stuff out into the history file
- p1:= ASSQ(x,$HistRecord) =>
- p2:= ASSQ(prop,rest p1) =>
+ p1 := objectAssoc(x,$HistRecord) =>
+ p2 := objectAssoc(prop,rest p1) =>
p2.rest := val
p1.rest := [[prop,:val],:rest p1]
p:= [x,:list [prop,:val]]
@@ -1501,8 +1501,8 @@ recordOldValue(x,prop,val) ==
recordOldValue0(x,prop,val) ==
-- writes (prop . val) into $HistList
- p1:= ASSQ(x,first $HistList) =>
- not ASSQ(prop,rest p1) =>
+ p1 := objectAssoc(x,first $HistList) =>
+ objectAssoc(prop,rest p1) = nil =>
p1.rest := [[prop,:val],:rest p1]
p:= [x,:list [prop,:val]]
$HistList.first := [p,:first $HistList]
@@ -1517,7 +1517,7 @@ undoInCore(n) ==
n>0 and
$HiFiAccess =>
vec:= rest (try readHiFi(n); finally disableHist())
- val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,rest p) ) and
+ val:= ( p := objectAssoc('%,vec) ) and (p1 := objectAssoc('value,rest p) ) and
rest p1
sayKeyedMsg("S2IH0019",[n])
$InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame)
@@ -1546,7 +1546,7 @@ undoFromFile(n) ==
x:= first p1
for p2 in rest p1 repeat
$InteractiveFrame:= putHist(x,first p2,rest p2,$InteractiveFrame)
- val:= ( p:= ASSQ('%,vec) ) and ( p1:= ASSQ('value,rest p) ) and rest p1
+ val := (p := objectAssoc('%,vec) ) and (p1 := objectAssoc('value,rest p) ) and rest p1
$InteractiveFrame:= putHist('%,'value,val,$InteractiveFrame)
updateHist()
@@ -1679,8 +1679,8 @@ showInOut(mini,maxi) ==
for ind in mini..maxi repeat
vec:= (try readHiFi(ind); finally disableHist())
sayMSG [first vec]
- Alist:= ASSQ('%,rest vec) =>
- triple:= rest ASSQ('value,rest Alist)
+ Alist := objectAssoc('%,rest vec) =>
+ triple := rest objectAssoc('value,rest Alist)
$IOindex:= ind
spadPrint(objValUnwrap triple,objMode triple)
@@ -1694,8 +1694,8 @@ fetchOutput(n) ==
n >= $IOindex => throwKeyedMsg("S2IH0001",[n])
n < 1 => throwKeyedMsg("S2IH0002",[n])
vec:= (try readHiFi(n); finally disableHist())
- Alist:= ASSQ('%,rest vec) =>
- val:= rest ASSQ('value,rest Alist) => val
+ Alist := objectAssoc('%,rest vec) =>
+ val := rest objectAssoc('value,rest Alist) => val
throwKeyedMsg("S2IH0003",[n])
throwKeyedMsg("S2IH0003",[n])
throwKeyedMsg("S2IH0004",nil)
@@ -2395,7 +2395,7 @@ diffAlist(new,old) ==
-- (2) if the old world does have a proplist for that variable, then
-- a) for each property with a value: give the old value
-- b) for each property missing: give nil as the old value
- oldPair := ASSQ(name,old) =>
+ oldPair := objectAssoc(name,old) =>
null (oldProplist := rest oldPair) =>
--record old values of new properties as nil
acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc]
@@ -2409,7 +2409,7 @@ diffAlist(new,old) ==
acc := [[name,:[[prop] for [prop,:.] in proplist]],:acc]
--record properties absent on new list (say, from a )cl all)
for (oldPair := [name,:r]) in old repeat
- r and null LASSQ(name,new) =>
+ r and null QLASSQ(name,new) =>
acc := [oldPair,:acc]
-- name has an entry both in new and old world
-- (1) if the new world has no proplist for that variable
@@ -2492,10 +2492,10 @@ undoSingleStep(changes,env) ==
for (change := [name,:changeList]) in changes repeat
if symbolLassoc('localModemap,changeList) then
changeList := undoLocalModemapHack changeList
- pairlist := ASSQ(name,env) =>
+ pairlist := objectAssoc(name,env) =>
proplist := rest pairlist =>
for (pair := [prop,:value]) in changeList repeat
- node := ASSQ(prop,proplist) => node.rest := value
+ node := objectAssoc(prop,proplist) => node.rest := value
proplist.rest := [first proplist,:rest proplist]
proplist.first := pair
pairlist.rest := changeList
diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot
index 136c61b9..7bd3d8fe 100644
--- a/src/interp/i-util.boot
+++ b/src/interp/i-util.boot
@@ -114,7 +114,7 @@ LZeros n ==
$variableNumberAlist := nil
variableNumber(x) ==
- p := ASSQ(x, $variableNumberAlist)
+ p := objectAssoc(x, $variableNumberAlist)
null p =>
$variableNumberAlist := [[x,:0], :$variableNumberAlist]
0
diff --git a/src/interp/int-top.boot b/src/interp/int-top.boot
index f0b6eb22..a4927b31 100644
--- a/src/interp/int-top.boot
+++ b/src/interp/int-top.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
@@ -445,8 +445,6 @@ getParserMacros() ==
$pfMacros
displayParserMacro m ==
- m := ASSQ(m, $pfMacros)
- null m => nil
- pfPrintSrcLines third m
-
+ m := objectAssoc(m, $pfMacros) => pfPrintSrcLines third m
+ nil
diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot
index 0bf11904..a6cf576b 100644
--- a/src/interp/lisplib.boot
+++ b/src/interp/lisplib.boot
@@ -637,7 +637,7 @@ transformOperationAlist operationAlist ==
signatureItem:=
if u:= assoc([op,sig],$functionLocations) then n := [n,:rest u]
[sig,n,condition,kind]
- itemList:= [signatureItem,:LASSQ(op,newAlist)]
+ itemList:= [signatureItem,:QLASSQ(op,newAlist)]
newAlist:= insertAlist(op,itemList,newAlist)
newAlist
diff --git a/src/interp/macros.lisp b/src/interp/macros.lisp
index 783de371..7e0690fa 100644
--- a/src/interp/macros.lisp
+++ b/src/interp/macros.lisp
@@ -222,10 +222,6 @@
; 15.6 Association Lists
-(defun QLASSQ (p a-list) (cdr (assq p a-list)))
-
-(define-function 'LASSQ #'QLASSQ)
-
;;; Operations on Association Sets (AS)
(defun AS-INSERT (A B L)
diff --git a/src/interp/msg.boot b/src/interp/msg.boot
index 23826171..7fa2418f 100644
--- a/src/interp/msg.boot
+++ b/src/interp/msg.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
@@ -468,7 +468,7 @@ getMsgToWhere msg ==
getMsgCatAttr (msg,'$toWhereGuys)
getMsgCatAttr (msg,cat) ==
- IFCDR QASSQ(cat, ncAlist msg)
+ IFCDR objectAssoc(cat, ncAlist msg)
setMsgForcedAttrList (msg,aL) ==
for attr in aL repeat
@@ -484,10 +484,10 @@ setMsgForcedAttr(msg,cat,attr) ==
setMsgUnforcedAttr(msg,cat,attr) ==
cat = 'catless => setMsgCatlessAttr(msg,attr)
- not QASSQ(cat, ncAlist msg) => ncPutQ(msg,cat,attr)
+ objectAssoc(cat, ncAlist msg) = nil => ncPutQ(msg,cat,attr)
setMsgCatlessAttr(msg,attr) ==
- ncPutQ(msg,'catless,CONS (attr, IFCDR QASSQ("catless", ncAlist msg)))
+ ncPutQ(msg,'catless,CONS (attr, IFCDR objectAssoc("catless", ncAlist msg)))
whichCat attr ==
found := 'catless
diff --git a/src/interp/posit.boot b/src/interp/posit.boot
index 9e3af606..05679001 100644
--- a/src/interp/posit.boot
+++ b/src/interp/posit.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
@@ -129,7 +129,7 @@ tokType x== ncTag x
tokPart x== rest x
tokPosn x==
- a:= QASSQ("posn",ncAlist x)
+ a := objectAssoc("posn",ncAlist x)
if a then rest a else pfNoPosition()
pfAbSynOp form ==
diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp
index 154f3920..d08d692b 100644
--- a/src/interp/spad.lisp
+++ b/src/interp/spad.lisp
@@ -397,7 +397,7 @@
nil)))
(defun |hashable| (dom)
- (memq (|knownEqualPred| dom)
+ (|symbolMember?| (|knownEqualPred| dom)
'(EQ EQL EQUAL)))
;; simpler interpface to RDEFIOSTREAM
diff --git a/src/interp/spaderror.lisp b/src/interp/spaderror.lisp
index 3a07ad21..8d4eab9e 100644
--- a/src/interp/spaderror.lisp
+++ b/src/interp/spaderror.lisp
@@ -86,7 +86,7 @@
(setq |$BreakMode| |$oldBreakMode|)
nil)) ;; resets error handler
((and (null |$inLispVM|)
- (memq |$BreakMode| '(|nobreak| |query| |resume|)))
+ (|symbolMember?| |$BreakMode| '(|nobreak| |query| |resume|)))
(let ((|$inLispVM| T)) ;; turn off handler
(return
(|systemError| (error-format error-string args)))))
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index e6a36af3..3f78da41 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -42,6 +42,7 @@ module sys_-utility where
probeReadableFile : %String -> %Maybe %String
remove!: (%List %Thing,%Thing) -> %List %Thing
displayTextFile: %Thing -> %Void
+ upwardCut: (%Thing, %List %Thing) -> %List %Thing
--%
$COMBLOCKLIST := nil
@@ -377,6 +378,14 @@ remove!(l,x) ==
return l
p := rest p
+++ Return the list of objects that follow x in l, including x itself.
+++ Otherwise return nil.
+upwardCut(x,l) ==
+ repeat
+ l isnt [.,:.] => return nil
+ sameObject?(x,first l) => return l
+ l := rest l
+
--%
displayTextFile f ==
try
diff --git a/src/interp/termrw.boot b/src/interp/termrw.boot
index aa3283f2..3df5ce55 100644
--- a/src/interp/termrw.boot
+++ b/src/interp/termrw.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
@@ -108,7 +108,7 @@ mergeSubs(S1,S2) ==
-- S1 doesn't contain any of the variables of S2
null S1 => S2
null S2 => S1
- S3 := [p for p in S2 | not ASSQ(first p, S1)]
+ S3 := [p for p in S2 | objectAssoc(first p, S1) = nil]
-- for p in S1 repeat S3:= augmentSub(first p,rest p,S3)
append(S1,S3)
diff --git a/src/interp/trace.boot b/src/interp/trace.boot
index 5e2e92d4..976e788e 100644
--- a/src/interp/trace.boot
+++ b/src/interp/trace.boot
@@ -378,7 +378,7 @@ getPreviousMapSubNames(traceNames) ==
subs
lassocSub(x,subs) ==
- y:= LASSQ(x,subs) => y
+ y := QLASSQ(x,subs) => y
x
rassocSub(x,subs) ==
diff --git a/src/interp/util.lisp b/src/interp/util.lisp
index 61603c46..73ebd5f6 100644
--- a/src/interp/util.lisp
+++ b/src/interp/util.lisp
@@ -60,8 +60,8 @@
(defun make-directory (direc)
(setq direc (namestring direc))
(if (string= direc "") (|systemRootDirectory|)
- (if (or (memq :unix *features*)
- (memq 'unix *features*))
+ (if (or (|symbolMember?| :unix *features*)
+ (|symbolMember?| 'unix *features*))
(progn
(if (char/= (char direc 0) #\/)
(setq direc (concat (|systemRootDirectory|) "/" direc)))
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index ab04002a..bbf199f6 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -70,16 +70,9 @@
(defmacro add1 (x)
`(1+ ,x))
-(defmacro assemble (&rest ignore)
- (declare (ignore ignore))
- nil)
-
(defmacro applx (&rest args)
`(apply ,@args))
-(defmacro assq (a b)
- `(assoc ,a ,b :test #'eq))
-
(defmacro bintp (n)
`(typep ,n 'bignum))
@@ -201,34 +194,17 @@
(defmacro maxindex (x)
`(the fixnum (1- (the fixnum (length ,x)))))
-(defmacro memq (a b)
- `(member ,a ,b :test #'eq))
-
(defmacro minus (x)
`(- ,x))
-(defmacro namederrset (id iexp &rest item)
- (declare (ignore item))
- `(catch ,id ,iexp))
-
(defmacro ne (a b) `(not (equal ,a ,b)))
(defmacro nump (n)
`(numberp ,n))
-(defmacro oraddtempdefs (filearg)
- `(eval-when
- #+:common-lisp (:compile-toplevel)
- #-:common-lisp (compile)
- (load ,filearg)))
-
(defmacro plus (&rest args)
`(+ ,@ args))
-; (defmacro qassq (a b)
-; `(assoc ,a ,b :test #'eq))
-(defmacro qassq (a b) `(assq ,a ,b))
-
(defmacro qcar (x)
`(car (the cons ,x)))
@@ -264,48 +240,9 @@
(defmacro qcdddr (x)
`(cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))
-(defmacro qcaaaar (x)
- `(car (the cons (car (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcaaadr (x)
- `(car (the cons (car (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcaadar (x)
- `(car (the cons (car (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcaaddr (x)
- `(car (the cons (car (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcadaar (x)
- `(car (the cons (cdr (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcadadr (x)
- `(car (the cons (cdr (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcaddar (x)
- `(car (the cons (cdr (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcadddr (x)
- `(car (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdaaar (x)
- `(cdr (the cons (car (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcdaadr (x)
- `(cdr (the cons (car (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdadar (x)
- `(cdr (the cons (car (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcdaddr (x)
- `(cdr (the cons (car (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-(defmacro qcddaar (x)
- `(cdr (the cons (cdr (the cons (car (the cons (car (the cons ,x)))))))))
-(defmacro qcddadr (x)
- `(cdr (the cons (cdr (the cons (car (the cons (cdr (the cons ,x)))))))))
-(defmacro qcdddar (x)
- `(cdr (the cons (cdr (the cons (cdr (the cons (car (the cons ,x)))))))))
-(defmacro qcddddr (x)
- `(cdr (the cons (cdr (the cons (cdr (the cons (cdr (the cons ,x)))))))))
-
-(defmacro qcsize (x)
- `(the fixnum (length (the simple-string ,x))))
-
(defmacro qeqq (pattern exp)
`(,(ecqexp pattern 1) ,exp))
-(defmacro qlength (a)
- `(length ,a))
-
(defmacro qrplaca (a b)
`(rplaca (the cons ,a) ,b))
@@ -734,6 +671,8 @@
; 14.3 Searching
+(defun QLASSQ (p a-list) (cdr (|objectAssoc| p a-list)))
+
(DEFUN |assoc| (X Y)
"Return the pair associated with key X in association list Y."
; ignores non-nil list terminators