diff options
| author | dos-reis <gdr@axiomatics.org> | 2011-10-02 03:35:59 +0000 |
|---|---|---|
| committer | dos-reis <gdr@axiomatics.org> | 2011-10-02 03:35:59 +0000 |
| commit | 8640c7b9aa33084d77770f435814d1d8558c8e2e (patch) | |
| tree | 968ff56d45b80dcc8ad3002703025cf27995e155 /src | |
| parent | 496ca25659180bb29cc5fea2f3c0337695d742d3 (diff) | |
| download | open-axiom-8640c7b9aa33084d77770f435814d1d8558c8e2e.tar.gz | |
* 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.
Diffstat (limited to 'src')
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 |