From 0204a2e9c993ee408d769cc6e2f91506b5699c81 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 4 Oct 2011 00:01:48 +0000 Subject: * boot/utility.boot (symbolAssoc): Rename from assocSymbol. Export. * interp/functor.boot: Remove getAbbreviation, mkAbbrev, addsuffix. * interp/sys-utility.boot (symbolAssoc): Remove as redundant. (scalarTarget): New. * interp/bc-matrix.boot: Use symbolTarget instead of symbolLassoc. * interp/br-con.boot: Use QLASSQ instead of symbolTarget. * interp/br-data.boot: Likewise. * interp/br-op1.boot: Likewise. * interp/br-prof.boot: Likewise. * interp/br-saturn.boot: Likewise. * interp/br-search.boot: Likewise. * interp/buildom.boot: Likewise. * interp/c-doc.boot: Likewise. * interp/c-util.boot: Likewise. * interp/cattable.boot: Likewise. * interp/clam.boot: Likewise. * interp/define.boot: Likewise. * interp/format.boot: Likewise. * interp/g-timer.boot: Likewise. * interp/g-util.boot: Likewise. * interp/ht-util.boot: Likewise. * interp/htsetvar.boot: Likewise. * interp/i-intern.boot: Likewise. * interp/i-map.boot: Likewise. * interp/i-object.boot: Likewise. * interp/i-syscmd.boot: Likewise. * interp/lisplib.boot: Likewise. * interp/profile.boot: Likewise. * interp/trace.boot: Likewise. * interp/vmlisp.lisp (assoc): Tidy. --- src/ChangeLog | 33 +++++++++++++++++++++++++++++ src/boot/strap/utility.clisp | 50 +++++++++++++++++++++++++------------------- src/boot/utility.boot | 30 +++++++++++++------------- src/interp/bc-matrix.boot | 6 +++--- src/interp/br-con.boot | 10 ++++----- src/interp/br-data.boot | 2 +- src/interp/br-op1.boot | 14 ++++++------- src/interp/br-prof.boot | 2 +- src/interp/br-saturn.boot | 4 ++-- src/interp/br-search.boot | 6 +++--- src/interp/buildom.boot | 2 +- src/interp/c-doc.boot | 11 ++++++---- src/interp/c-util.boot | 16 +++++++------- src/interp/cattable.boot | 4 ++-- src/interp/clam.boot | 2 +- src/interp/define.boot | 4 ++-- src/interp/format.boot | 2 +- src/interp/functor.boot | 33 ----------------------------- src/interp/g-timer.boot | 2 +- src/interp/g-util.boot | 11 +++++----- src/interp/ht-util.boot | 2 +- src/interp/htsetvar.boot | 2 +- src/interp/i-intern.boot | 4 ++-- src/interp/i-map.boot | 19 ++++++++--------- src/interp/i-object.boot | 8 +++---- src/interp/i-syscmd.boot | 6 +++--- src/interp/lisplib.boot | 6 +++--- src/interp/profile.boot | 12 +++++------ src/interp/sys-utility.boot | 13 +++++++----- src/interp/trace.boot | 14 ++++++------- src/interp/vmlisp.lisp | 17 ++------------- 31 files changed, 171 insertions(+), 176 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index 8c52fa09..e834c58e 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,36 @@ +2011-10-03 Gabriel Dos Reis + + * boot/utility.boot (symbolAssoc): Rename from assocSymbol. Export. + * interp/functor.boot: Remove getAbbreviation, mkAbbrev, addsuffix. + * interp/sys-utility.boot (symbolAssoc): Remove as redundant. + (scalarTarget): New. + * interp/bc-matrix.boot: Use symbolTarget instead of symbolLassoc. + * interp/br-con.boot: Use QLASSQ instead of symbolTarget. + * interp/br-data.boot: Likewise. + * interp/br-op1.boot: Likewise. + * interp/br-prof.boot: Likewise. + * interp/br-saturn.boot: Likewise. + * interp/br-search.boot: Likewise. + * interp/buildom.boot: Likewise. + * interp/c-doc.boot: Likewise. + * interp/c-util.boot: Likewise. + * interp/cattable.boot: Likewise. + * interp/clam.boot: Likewise. + * interp/define.boot: Likewise. + * interp/format.boot: Likewise. + * interp/g-timer.boot: Likewise. + * interp/g-util.boot: Likewise. + * interp/ht-util.boot: Likewise. + * interp/htsetvar.boot: Likewise. + * interp/i-intern.boot: Likewise. + * interp/i-map.boot: Likewise. + * interp/i-object.boot: Likewise. + * interp/i-syscmd.boot: Likewise. + * interp/lisplib.boot: Likewise. + * interp/profile.boot: Likewise. + * interp/trace.boot: Likewise. + * interp/vmlisp.lisp (assoc): Tidy. + 2011-10-03 Gabriel Dos Reis * interp/comp.lisp: Remove. diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index c42cc8f2..d522b8c8 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -19,8 +19,9 @@ |scalarMember?| |listMember?| |reverse| |reverse!| |lastNode| |append| |append!| |copyList| |substitute| |substitute!| |setDifference| |setUnion| |setIntersection| - |applySubst| |applySubst!| |applySubstNQ| |objectAssoc| - |remove| |removeSymbol| |atomic?| |finishLine|))) + |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ| + |objectAssoc| |remove| |removeSymbol| |atomic?| + |finishLine|))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|)) @@ -49,10 +50,16 @@ (DECLAIM (FTYPE - (FUNCTION (|%Thing| (|%List| (|%Pair| |%Thing| |%Thing|))) + (FUNCTION (|%Thing| (|%List| |%Thing|)) (|%Maybe| (|%Pair| |%Thing| |%Thing|))) |objectAssoc|)) +(DECLAIM + (FTYPE + (FUNCTION (|%Symbol| (|%List| |%Thing|)) + (|%Maybe| (|%Pair| |%Symbol| |%Thing|))) + |symbolAssoc|)) + (DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|)) |setDifference|)) @@ -172,15 +179,25 @@ (DEFUN |append| (|x| |y|) (|append!| (|copyList| |x|) |y|)) -(DEFUN |assocSymbol| (|s| |al|) +(DEFUN |symbolAssoc| (|s| |l|) (PROG (|x|) (RETURN (LOOP (COND - ((AND (CONSP |al|) - (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T)) - (COND ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (IDENTITY (RETURN |x|))))) - (T (RETURN NIL))))))) + ((NOT + (AND (CONSP |l|) (PROGN (SETQ |x| (CAR |l|)) (SETQ |l| (CDR |l|)) T))) + (RETURN NIL)) + ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (RETURN |x|))))))) + +(DEFUN |objectAssoc| (|x| |l|) + (PROG (|p|) + (RETURN + (LOOP + (COND + ((NOT + (AND (CONSP |l|) (PROGN (SETQ |p| (CAR |l|)) (SETQ |l| (CDR |l|)) T))) + (RETURN NIL)) + ((AND (CONSP |p|) (EQ (CAR |p|) |x|)) (RETURN |p|))))))) (DEFUN |substitute!| (|y| |x| |s|) (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|) @@ -208,7 +225,7 @@ (SETQ |tl| (|applySubst| |sl| (CDR |t|))) (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) (T (CONS |hd| |tl|)))) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) (T |t|))))) (DEFUN |applySubst!| (|sl| |t|) @@ -218,7 +235,7 @@ ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|))) (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|) (RPLACD |t| |tl|)) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) (T |t|))))) (DEFUN |applySubstNQ| (|sl| |t|) @@ -231,7 +248,7 @@ (SETQ |tl| (|applySubstNQ| |sl| |tl|)) (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|) (T (CONS |hd| |tl|)))))) - ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|)) + ((AND (SYMBOLP |t|) (SETQ |p| (|symbolAssoc| |t| |sl|))) (CDR |p|)) (T |t|))))) (DEFUN |setDifference| (|x| |y|) @@ -335,17 +352,6 @@ ((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/utility.boot b/src/boot/utility.boot index d60c7d5c..79d84700 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, objectAssoc, + symbolAssoc, applySubst, applySubst!, applySubstNQ, objectAssoc, remove,removeSymbol,atomic?,finishLine) where substitute: (%Thing,%Thing,%Thing) -> %Thing substitute!: (%Thing,%Thing,%Thing) -> %Thing @@ -57,8 +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) + objectAssoc: (%Thing, %List %Thing) -> %Maybe %Pair(%Thing,%Thing) + symbolAssoc: (%Symbol,%List %Thing) -> %Maybe %Pair(%Symbol,%Thing) setDifference: (%List %Thing,%List %Thing) -> %List %Thing setUnion: (%List %Thing,%List %Thing) -> %List %Thing setIntersection: (%List %Thing,%List %Thing) -> %List %Thing @@ -177,12 +177,15 @@ append(x,y) == --% a-list -assocSymbol(s,al) == +symbolAssoc(s,l) == repeat - al is [x,:al] => - cons? x and symbolEq?(s,first x) => - return x - return nil + l isnt [x,:l] => return nil + x is [.,:.] and symbolEq?(s,first x) => return x + +objectAssoc(x,l) == + repeat + l isnt [p,:l] => return nil + p is [.,:.] and sameObject?(first p,x) => return p --% substitution @@ -210,7 +213,7 @@ applySubst(sl,t) == tl := applySubst(sl,rest t) sameObject?(hd,first t) and sameObject?(tl,rest t) => t [hd,:tl] - symbol? t and (p := assocSymbol(t,sl)) => rest p + symbol? t and (p := symbolAssoc(t,sl)) => rest p t applySubst!(sl,t) == @@ -219,7 +222,7 @@ applySubst!(sl,t) == tl := applySubst!(sl,rest t) t.first := hd t.rest := tl - symbol? t and (p := assocSymbol(t,sl)) => rest p + symbol? t and (p := symbolAssoc(t,sl)) => rest p t ++ Like applySubst, but skip quoted materials. @@ -230,7 +233,7 @@ applySubstNQ(sl,t) == tl := applySubstNQ(sl,tl) sameObject?(hd,first t) and sameObject?(tl,rest t) => t [hd,:tl] - symbol? t and (p := assocSymbol(t,sl)) => rest p + symbol? t and (p := symbolAssoc(t,sl)) => rest p t --% set operations @@ -293,11 +296,6 @@ 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/bc-matrix.boot b/src/interp/bc-matrix.boot index 18b93120..1aacb08d 100644 --- a/src/interp/bc-matrix.boot +++ b/src/interp/bc-matrix.boot @@ -141,10 +141,10 @@ bcMatrixGen htPage == nrows := htpProperty(htPage,'nrows) ncols := htpProperty(htPage,'ncols) mat := htpProperty(htPage,'matrix) - formula := symbolLassoc('formula,mat) => + formula := symbolTarget('formula,mat) => formula := formula.0 - rowVar := (symbolLassoc('rowVar,mat)).0 - colVar := (symbolLAssoc('colVar,mat)).0 + rowVar := (symbolTarget('rowVar,mat)).0 + colVar := (symbolTarget('colVar,mat)).0 strconc('"matrix([[",formula,'" for ",colVar,'" in 1..", STRINGIMAGE ncols,'"] for ",rowVar,'" in 1..",STRINGIMAGE nrows,'"])") mat := htpProperty(htPage,'matrix) => diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index 1719a767..46ab6120 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 := QLASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping))) => +-- pageName := symbolTarget(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 := QLASSQ(da,'((type . CategoryType)(union . DomainUnion)(record . DomainRecord)(mapping . DomainMapping)(enumeration . DomainEnumeration))) => + pageName := symbolTarget(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 := QLASSQ('dbLineNumber,CDDR entry) => + lineNumber := symbolTarget('dbLineNumber,CDDR entry) => --'dbLineNumbers property is set by function dbAugmentConstructorDataTable dbRead lineNumber --read record for constructor from libdb.text conPageConEntry first entry @@ -704,7 +704,7 @@ conOpPage1(conform,:options) == htpSetProperty(page,'domname,domname) --> !!note!! <-- htpSetProperty(page,'conform,conform) htpSetProperty(page,'signature,signature) - if selectedOperation := symbolLAssoc('selectedOperation,IFCDR options) then + if selectedOperation := symbolTarget('selectedOperation,IFCDR options) then htpSetProperty(page,'selectedOperation,selectedOperation) for [a,:b] in bindingsAlist repeat htpSetProperty(page,a,b) koPage(page,'"operation") @@ -984,7 +984,7 @@ dbShowConsDoc1(htPage,conform,indexOrNil) == --NOTE that we pass conform is as "origin" getConstructorDocumentation conname == - symbolLassoc('constructor,getConstructorDocumentationFromDB conname) + symbolTarget('constructor,getConstructorDocumentationFromDB conname) is [[nil,line,:.],:.] and line or '"" dbSelectCon(htPage,which,index) == diff --git a/src/interp/br-data.boot b/src/interp/br-data.boot index 3b372629..204db22a 100644 --- a/src/interp/br-data.boot +++ b/src/interp/br-data.boot @@ -111,7 +111,7 @@ buildLibdbConEntry conname == DOWNCASE stringChar(symbolName kind,0) argl := rest $conform conComments := - symbolLassoc('constructor,$doc) is [[=nil,:r]] => + symbolTarget('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r '"" argpart:= subString(form2HtString ['f,:argl],1) diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot index 216e863d..ebd5b510 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,QLASSQ(conname,catOriginAlist) or true) + pred := simpOrDumb(predicate,symbolTarget(conname,catOriginAlist) or true) catOriginAlist := insertAlist(conname,pred,catOriginAlist) - pred := simpOrDumb(predicate,QLASSQ(conname,domOriginAlist) or true) + pred := simpOrDumb(predicate,symbolTarget(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_* - | QLASSQ(rest key,catOriginAlist)] + | symbolTarget(rest key,catOriginAlist)] for pair in u repeat [dom,:cat] := pair - QLASSQ(cat,catOriginAlist) is 'etc => pair.rest := 'etc + symbolTarget(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,QLASSQ(dom,u) or true),u) + u := insertAlist(dom,simpOrDumb(pred,symbolTarget(dom,u) or true),u) cAlist := listSort(function GLESSEQP,u) for pair in cAlist repeat pair.first := getConstructorForm first pair @@ -610,10 +610,10 @@ dbShowOpParameters(htPage,opAlist,which,data) == htSayExpose(ops,exposeFlag) n := #opform do - n = 2 and symbolLassoc('Nud,PROPLIST op) => + n = 2 and symbolTarget('Nud,PROPLIST op) => dbShowOpParameterJump(ops,which,count,single?) htSay('" {\em ",KAR args,'"}") - n = 3 and symbolLassoc('Led,PROPLIST op) => + n = 3 and symbolTarget('Led,PROPLIST op) => htSay('"{\em ",KAR args,'"} ") dbShowOpParameterJump(ops,which,count,single?) htSay('" {\em ",KAR KDR args,'"}") diff --git a/src/interp/br-prof.boot b/src/interp/br-prof.boot index c626ba23..56636ad2 100644 --- a/src/interp/br-prof.boot +++ b/src/interp/br-prof.boot @@ -84,7 +84,7 @@ dbShowInfoOp(htPage,op,sig,alist) == applySubst(pairList($FormalMapVariableList,IFCDR conform),faTypes) conform := htpProperty(htPage,'conform) conname := opOf conform ---argTypes := reverse ASSOCRIGHT symbolLassoc('arguments,alist) +--argTypes := reverse ASSOCRIGHT symbolTarget('arguments,alist) --sig := or/[sig for [sig,:.] in LASSOC(op,opAlist) | rest sig = argTypes] ops := escapeSpecialChars STRINGIMAGE zeroOneConvert op oppart := ['"{\em ", ops, '"}"] diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index 238855a0..6bea4b28 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -1206,9 +1206,9 @@ displayDomainOp(htPage,which,origin,op,sig,predicate, ops := escapeSpecialChars STRINGIMAGE op n := #sig do - n = 2 and symbolLassoc('Nud,PROPLIST op) => + n = 2 and symbolTarget('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}") - n = 3 and symbolLassoc('Led,PROPLIST op) => + n = 3 and symbolTarget('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}") if unexposed? and $includeUnexposed? then htSayUnexposed() diff --git a/src/interp/br-search.boot b/src/interp/br-search.boot index 026ff895..fa44b8e1 100644 --- a/src/interp/br-search.boot +++ b/src/interp/br-search.boot @@ -362,7 +362,7 @@ spadType(x) == --called by \spadtype{x} from HyperDoc looksLikeDomainForm x == entry := getCDTEntry(opOf x,true) or return false - coSig := symbolLassoc('coSig,CDDR entry) + coSig := symbolTarget('coSig,CDDR entry) k := #coSig x isnt [.,:.] => k = 1 k ~= #x => false @@ -754,7 +754,7 @@ dbSearchAbbrev([.,:conlist],kind,filter) == null conlist => emptySearchPage('"abbreviation",filter) kind := intern kind if kind ~= 'constructor then - conlist := [x for x in conlist | symbolLassoc('kind,IFCDR IFCDR x) = kind] + conlist := [x for x in conlist | symbolTarget('kind,IFCDR IFCDR x) = kind] conlist is [[nam,:.]] => conPage DOWNCASE nam cAlist := [[con,:true] for con in conlist] htPage := htInitPage('"",nil) @@ -764,7 +764,7 @@ dbSearchAbbrev([.,:conlist],kind,filter) == page := htInitPage([#conlist, '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) for [nam,abbr,:r] in conlist repeat - kind := symbolLAssoc('kind,r) + kind := symbolTarget('kind,r) htSay('"\newline{\em ",s := STRINGIMAGE abbr) htSayStandard '"\tab{10}" htSay '"}" diff --git a/src/interp/buildom.boot b/src/interp/buildom.boot index 6af76e6a..59e0e68b 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 QLASSQ(op,table) repeat + while not success for [sig1,:code] in symbolTarget(op,table) repeat success := not compareSig(sig,sig1,canonicalForm dollar,domain) => false code is ['Subsumed,a] => diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot index 100ee96d..fbf666f0 100644 --- a/src/interp/c-doc.boot +++ b/src/interp/c-doc.boot @@ -36,6 +36,9 @@ import c_-util import daase namespace BOOT +$checkPrenAlist == + [[char "(",:char ")"],[char "{",:char "}"],[char "[",:char "]"]] + batchExecute() == _/RF_-1 '(GENCON INPUT) @@ -77,7 +80,7 @@ getDocForDomain(name,op,sig) == ++ `op' and given signature `sigPart'. The operator `op' is assumed ++ to have been defined in the domain or catagory `abb'. getOpDoc(abb,op,:sigPart) == - u := symbolLassoc(op,getConstructorDocumentationFromDB abb) + u := symbolTarget(op,getConstructorDocumentationFromDB abb) $argList : local := $FormalMapVariableList _$: local := '_$ sigPart is [sig] => or/[d for [s,:d] in u | sig = s] @@ -1009,8 +1012,8 @@ checkBalance u == while u repeat do x := first u - openClose := assoc(x,$checkPrenAlist) --is it an open bracket? - => stack := [first openClose,:stack] --yes, push the open bracket + closer := scalarTarget(x,$checkPrenAlist) --is it an open bracket? + => stack := [closer,:stack] --yes, push the open bracket open := rassoc(x,$checkPrenAlist) => --it is a close bracket! stack is [top,:restStack] => --does corresponding open bracket match? if open ~= top then --yes: just pop the stack @@ -1153,7 +1156,7 @@ checkTransformFirsts(opname,u,margin) == checkDocError ['"Improper first word in comments: ",firstWord] u #(p := symbolName infixOp) = 1 and (open := p.0) and - (close := LASSOC(open,$checkPrenAlist)) => --have an open bracket + (close := scalarTarget(open,$checkPrenAlist)) => --have an open bracket l := getMatchingRightPren(u,k + 1,open,close) if l > maxIndex u then l := k - 1 strconc('"\spad{",subString(u,0,l + 1),'"}",subString(u,l + 1)) diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 795556da..8145cd36 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -478,7 +478,7 @@ addContour(c,E is [cur,:tail]) == if p="conditionalmode" then pv.first := "mode" --check for conflicts with earlier mode - if vv := symbolLassoc("mode",e) then + if vv := symbolTarget("mode",e) then if v ~=vv then stackWarning('"The conditional modes %1p and %2p conflict", [v,vv]) @@ -603,7 +603,7 @@ prEnv E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat SAY('"******CONTOUR ",j,'", LEVEL ",i,'":******") - for z in y | null symbolLassoc("modemap",rest z) repeat + for z in y | null symbolTarget("modemap",rest z) repeat TERPRI() SAY("Properties Of: ",first z) for u in rest z repeat @@ -619,7 +619,7 @@ prModemaps E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat for z in y | not member(first z,listOfOperatorsSeenSoFar) and - (modemap := symbolLassoc("modemap",rest z)) repeat + (modemap := symbolTarget("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] TERPRI() PRIN1 first z @@ -710,7 +710,7 @@ diagnoseUnknownType(t,e) == isConstantId(name,e) == ident? name => pl:= getProplist(name,e) => - (symbolLassoc("value",pl) or symbolLassoc("mode",pl) => false; true) + (symbolTarget("value",pl) or symbolTarget("mode",pl) => false; true) true false @@ -1010,8 +1010,8 @@ extendsCategoryForm(domain,form,form') == getmode(x,e) == prop:=getProplist(x,e) - u := QLASSQ("value",prop) => u.mode - QLASSQ("mode",prop) + u := symbolTarget("value",prop) => u.mode + symbolTarget("mode",prop) getmodeOrMapping(x,e) == u:= getmode(x,e) => u @@ -1095,7 +1095,7 @@ displayModemaps E == for x in E for i in 1.. repeat for y in x for j in 1.. repeat for z in y | not member(first z,listOfOperatorsSeenSoFar) and - (modemaps := symbolLassoc("modemap",rest z)) repeat + (modemaps := symbolTarget("modemap",rest z)) repeat listOfOperatorsSeenSoFar:= [first z,:listOfOperatorsSeenSoFar] displayOpModemaps(first z,modemaps) @@ -1497,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) - QLASSQ(name,$clamList) => compClam(name,args,body,$clamList) + symbolTarget(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/cattable.boot b/src/interp/cattable.boot index 7e225cc6..a5abcce8 100644 --- a/src/interp/cattable.boot +++ b/src/interp/cattable.boot @@ -109,7 +109,7 @@ simpHasPred(pred,:options) == main where op is 'hasArgs => ($hasArgs => $hasArgs = r; pred) null r and opOf op = "has" => simp first pred pred is '%true or pred is '(QUOTE T) => true - op1 := symbolLassoc(op,'((and . AND)(or . OR)(not . NOT))) => + op1 := symbolTarget(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r] simp first pred --REMOVE THIS HACK !!!! pred in '(T etc) => pred @@ -134,7 +134,7 @@ simpHasSignature(pred,conform,op,sig) == --eval w/o loading ident? conform => pred [conname,:args] := conform n := #sig - u := symbolLassoc(op,getConstructorOperationsFromDB conname) + u := symbolTarget(op,getConstructorOperationsFromDB conname) candidates := [x for (x := [sig1,:.]) in u | #sig1 = #sig] or return false match := or/[x for (x := [sig1,:.]) in candidates | sig = sublisFormal(args,sig1)] or return false diff --git a/src/interp/clam.boot b/src/interp/clam.boot index eabd822e..ef384409 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 := QLASSQ(op,$clamList)) isnt [kind,eqEtc,:options] + if (u := symbolTarget(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/define.boot b/src/interp/define.boot index f933a59e..3c73dfb0 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -827,7 +827,7 @@ compDefine1(form,m,e) == compDefineAddSignature([op,:argl],signature,e) == (sig:= hasFullSignature(argl,signature,e)) and - null assoc(['$,:sig],symbolLassoc('modemap,getProplist(op,e))) => + null assoc(['$,:sig],symbolTarget('modemap,getProplist(op,e))) => declForm:= [":",[op,:[[":",x,m] for x in argl for m in sig.source]],signature.target] [.,.,e]:= comp(declForm,$EmptyMode,e) @@ -1198,7 +1198,7 @@ addModemap1(op,mc,sig,pred,fn,e) == if mc="Rep" then sig := substituteDollarIfRepHack sig currentProplist:= getProplist(op,e) or nil newModemapList:= - mkNewModemapList(mc,sig,pred,fn,symbolLassoc('modemap,currentProplist),e,nil) + mkNewModemapList(mc,sig,pred,fn,symbolTarget('modemap,currentProplist),e,nil) newProplist:= augProplist(currentProplist,'modemap,newModemapList) newProplist':= augProplist(newProplist,"FLUID",true) unErrorRef op diff --git a/src/interp/format.boot b/src/interp/format.boot index 4498f339..a619d7d5 100644 --- a/src/interp/format.boot +++ b/src/interp/format.boot @@ -725,7 +725,7 @@ pred2English x == concat(pred2English a,'": ",form2String abbreviate b) x is [op,a,b] and op in '(isDomain domainEqual) => concat(pred2English a,'" = ",form2String abbreviate b) - x is [op,:.] and (translation := symbolLassoc(op,'( + x is [op,:.] and (translation := symbolTarget(op,'( (_< . " < ") (_<_= . " <= ") (_> . " > ") (_>_= . " >= ") (_= . " = ") (_~_= . " _~_= ")))) => concat(pred2English a,translation,pred2English b) diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 0a93ed7d..c291c554 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -846,36 +846,3 @@ getCaps x == clist:= [c for i in 0..maxIndex s | upperCase? (c:= s.i)] null clist => '"__" strconc/[first clist,:[L_-CASE u for u in rest clist]] - ---% abbreviation code - -getAbbreviation(name,c) == - --returns abbreviation of name with c arguments - x := getConstructorAbbreviationFromDB name - 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 - newAbbreviation:= mkAbbrev(X,x) - X.rest := [[name,[c,:newAbbreviation]],:rest X] - newAbbreviation - $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable] - x - -mkAbbrev(X,x) == addSuffix(alistSize rest X,x) - -alistSize c == - count(c,1) where - count(x,level) == - level=2 => #x - null x => 0 - count(CDAR x,level+1)+count(rest x,level) - -addSuffix(n,u) == - s := STRINGIMAGE u - alphabetic? stringChar(s,maxIndex s) => - makeSymbol strconc(s,STRINGIMAGE n) - INTERNL strconc(s,STRINGIMAGE ";",STRINGIMAGE n) - diff --git a/src/interp/g-timer.boot b/src/interp/g-timer.boot index 69f538db..4e3ab09d 100644 --- a/src/interp/g-timer.boot +++ b/src/interp/g-timer.boot @@ -78,7 +78,7 @@ makeLongStatStringByProperty _ if otherStatTotal > 0 then str := makeStatString(str,normalizeStatAndStringify otherStatTotal,'O,flag) total := total + otherStatTotal - cl := first symbolLassoc('other,listofnames) + cl := first symbolTarget('other,listofnames) cl := first LASSOC(cl,listofclasses) property(cl,classprop) := otherStatTotal + property(cl,classprop) if flag ~= 'long then diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index f9bb8ef0..f49a61ec 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -266,15 +266,15 @@ get(x,prop,e) == get0(x,prop,e) == cons? x => get0(x.op,prop,e) - u := QLASSQ(x,first first e) => QLASSQ(prop,u) + u := symbolTarget(x,first first e) => symbolTarget(prop,u) (tail := rest first e) and (u := fastSearchCurrentEnv(x,tail)) => - QLASSQ(prop,u) + symbolTarget(prop,u) nil get1(x,prop,e) == cons? x => get1(x.op,prop,e) prop = "modemap" and $insideCapsuleFunctionIfTrue => - symbolLassoc("modemap",getProplist(x,$CapsuleModemapFrame)) + symbolTarget("modemap",getProplist(x,$CapsuleModemapFrame)) or get2(x,prop) LASSOC(prop,getProplist(x,e)) or get2(x,prop) @@ -762,10 +762,10 @@ augProplistOf(var,prop,val,e) == semchkProplist(x,proplist,prop,val) == prop="isLiteral" => - symbolLassoc("value",proplist) or symbolLassoc("mode",proplist) => + symbolTarget("value",proplist) or symbolTarget("mode",proplist) => warnLiteral x prop in '(mode value) => - symbolLassoc("isLiteral",proplist) => warnLiteral x + symbolTarget("isLiteral",proplist) => warnLiteral x addBinding(var,proplist,e is [[curContour,:tailContour],:tailEnv]) == sameObject?(proplist,getProplist(var,e)) => e @@ -875,7 +875,6 @@ $charQuote == char "'" $charSemiColon == char ";" $charComma == char "," $charPeriod == char "." -$checkPrenAlist := [[char "(",:char ")"],[char "{",:char "}"],[char "[",:char "]"]] $charEscapeList:= [char "%",char "#",$charBack] $charIdentifierEndings := [char "__", char "!", char "?"] $charSplitList := [$charComma,$charPeriod,char "[", char "]",$charLbrace, $charRbrace, char "(", char ")", char "$", char "%"] diff --git a/src/interp/ht-util.boot b/src/interp/ht-util.boot index 46e1fcf1..1117be20 100644 --- a/src/interp/ht-util.boot +++ b/src/interp/ht-util.boot @@ -269,7 +269,7 @@ bcSadFaces() == htLispLinks(links,:option) == [links,options] := beforeAfter('options,links) - indent := symbolLAssoc('indent,options) or 5 + indent := symbolTarget('indent,options) or 5 iht '"\newline\indent{" iht stringize indent iht '"}\beginitems" diff --git a/src/interp/htsetvar.boot b/src/interp/htsetvar.boot index 058fcc8c..e91a7dcd 100644 --- a/src/interp/htsetvar.boot +++ b/src/interp/htsetvar.boot @@ -430,7 +430,7 @@ htCacheSet htPage == num := chkAllNonNegativeInteger htpLabelInputString(htPage,htMakeLabel('"c",i)) $cacheAlist := ADDASSOC(makeSymbol name,num,$cacheAlist) - if (n := symbolLAssoc('all,$cacheAlist)) then + if (n := symbolTarget('all,$cacheAlist)) then $cacheCount := n $cacheAlist := deleteAssoc('all,$cacheAlist) htInitPage('"Cache Summary",nil) diff --git a/src/interp/i-intern.boot b/src/interp/i-intern.boot index e91f1d43..b8be53f7 100644 --- a/src/interp/i-intern.boot +++ b/src/interp/i-intern.boot @@ -449,9 +449,9 @@ remprop(x,prop,e) == e fastSearchCurrentEnv(x,currentEnv) == - u:= QLASSQ(x,first currentEnv) => u + u:= symbolTarget(x,first currentEnv) => u while (currentEnv:= rest currentEnv) repeat - u:= QLASSQ(x,first currentEnv) => u + u:= symbolTarget(x,first currentEnv) => u transformCollect [:itrl,body] == -- syntactic transformation for COLLECT form, called from mkAtree1 diff --git a/src/interp/i-map.boot b/src/interp/i-map.boot index 8261ac76..dcdf4cf8 100644 --- a/src/interp/i-map.boot +++ b/src/interp/i-map.boot @@ -786,13 +786,12 @@ mapRecurDepth(opName,opList,body) == -- expanding the bodies of maps called in body body isnt [.,:.] => 0 body is [op,:argl] => - argc:= + argc := argl isnt [.,:.] => 0 - argl => "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] - 0 - symbolMember?(op,opList) => argc - op=opName => 1 + argc - (obj := get(op,'value,$e)) and objVal obj is ["%Map",:mapDef] => + "MAX"/[mapRecurDepth(opName,opList,x) for x in argl] + ident? op and symbolMember?(op,opList) => argc + ident? op and op = opName => 1 + argc + ident? op and (obj := get(op,'value,$e)) and objVal obj is ["%Map",:mapDef] => mapRecurDepth(opName,[op,:opList],getMapBody(op,mapDef)) + argc argc @@ -895,15 +894,15 @@ nonRecursivePart(opName, funBody) == expandRecursiveBody(alreadyExpanded, body) == -- replaces calls to other maps with their bodies body isnt [.,:.] => - (obj := get(body,'value,$e)) and objVal obj is ["%Map",:mapDef] and + ident? body and (obj := get(body,'value,$e)) and objVal obj is ["%Map",:mapDef] and ((numMapArgs mapDef) = 0) => getMapBody(body,mapDef) body body is [op,:argl] => - not symbolMember?(op,alreadyExpanded) => + ident? op and not symbolMember?(op,alreadyExpanded) => (obj := get(op,'value,$e)) and objVal obj is ["%Map",:mapDef] => - newBody:= getMapBody(op,mapDef) + newBody := getMapBody(op,mapDef) for arg in argl for var in $FormalMapVariableList repeat - newBody:=MSUBST(arg,var,newBody) + newBody := substitute(arg,var,newBody) expandRecursiveBody([op,:alreadyExpanded],newBody) [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] [op,:[expandRecursiveBody(alreadyExpanded,arg) for arg in argl]] diff --git a/src/interp/i-object.boot b/src/interp/i-object.boot index 972d6ed4..2e739d1c 100644 --- a/src/interp/i-object.boot +++ b/src/interp/i-object.boot @@ -375,7 +375,7 @@ putAtree(x,prop,val) == if vector? op then putAtree(op,prop,val) x not vector? x => x -- just ignore it - n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + n := symbolTarget(prop,'((mode . 1) (value . 2) (modeSet . 3))) => vectorRef(x,n) := val vectorRef(x,4) := insertShortAlist(prop,val,x.4) x @@ -387,9 +387,9 @@ getAtree(x,prop) == vector? op => getAtree(op,prop) nil not vector? x => nil -- just ignore it - n := QLASSQ(prop,'((mode . 1) (value . 2) (modeSet . 3))) + n := symbolTarget(prop,'((mode . 1) (value . 2) (modeSet . 3))) => vectorRef(x,n) - QLASSQ(prop,vectorRef(x,4)) + symbolTarget(prop,vectorRef(x,4)) putTarget(x, targ) == -- want to put nil modes perhaps to clear old target @@ -462,7 +462,7 @@ getFlagArgsPos t == transferPropsToNode(x,t) == propList := getProplist(x,$env) - QLASSQ('Led,propList) or QLASSQ('Nud,propList) => nil + symbolTarget('Led,propList) or symbolTarget('Nud,propList) => nil node := vector? t => t first t diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot index 1c48b7c6..311db253 100644 --- a/src/interp/i-syscmd.boot +++ b/src/interp/i-syscmd.boot @@ -353,7 +353,7 @@ clearCmdParts(l is [opt,:vl]) == vl := ASSOCLEFT CAAR $InteractiveFrame vl := removeDuplicates(append(vl, pmacs)) $e : local := $InteractiveFrame - for x in vl repeat + for x in vl | ident? x repeat clearDependencies(x,true) if option is 'properties and symbolMember?(x,pmacs) then clearParserMacro(x) @@ -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 QLASSQ(name,new) => + r and null symbolTarget(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 @@ -2490,7 +2490,7 @@ undoSingleStep(changes,env) == -- pp '"----Undoing 1 step--------" -- pp changes for (change := [name,:changeList]) in changes repeat - if symbolLassoc('localModemap,changeList) then + if symbolTarget('localModemap,changeList) then changeList := undoLocalModemapHack changeList pairlist := objectAssoc(name,env) => proplist := rest pairlist => diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 27b67a68..e1a16471 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -294,7 +294,7 @@ loadIfNecessary u == dbLoaded? constructorDB u => u loadLib u => u not $InteractiveMode and (null (y:= getProplist(u,$CategoryFrame)) - or (null symbolLassoc('isFunctor,y)) and (null symbolLAssoc('isCategory,y))) => + or (null symbolTarget('isFunctor,y)) and (null symbolTarget('isCategory,y))) => y:= getConstructorKindFromDB u => y = "category" => updateCategoryFrameForCategory u @@ -637,7 +637,7 @@ transformOperationAlist operationAlist == signatureItem:= if u:= assoc([op,sig],$functionLocations) then n := [n,:rest u] [sig,n,condition,kind] - itemList:= [signatureItem,:QLASSQ(op,newAlist)] + itemList:= [signatureItem,:symbolTarget(op,newAlist)] newAlist:= insertAlist(op,itemList,newAlist) newAlist @@ -673,7 +673,7 @@ getSlotNumberFromOperationAlist(domainForm,op,sig) == operationAlist:= getConstructorOperationsFromDB constructorName or keyedSystemError("S2IL0026",[constructorName]) - entryList:= QLASSQ(op,operationAlist) or return nil + entryList:= symbolTarget(op,operationAlist) or return nil tail:= or/[r for [sig1,:r] in entryList | sigsMatch(sig,sig1,domainForm)] => first tail nil diff --git a/src/interp/profile.boot b/src/interp/profile.boot index 78afa963..41796931 100644 --- a/src/interp/profile.boot +++ b/src/interp/profile.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 @@ -73,19 +73,19 @@ profileRecord(label,name,info) == --name: info is var: type or op: sig $profileAlist profileDisplay() == - profileDisplayOp('constructor,symbolLassoc('constructor,$profileAlist) ) + profileDisplayOp('constructor,symbolTarget('constructor,$profileAlist) ) for [op,:alist1] in $profileAlist | op ~= 'constructor repeat profileDisplayOp(op,alist1) profileDisplayOp(op,alist1) == sayBrightly op - if symbolLassoc('arguments,alist1) then + if symbolTarget('arguments,alist1) then sayBrightly '" arguments" - for [x,:t] in MSORT symbolLAssoc('arguments,alist1) repeat + for [x,:t] in MSORT symbolTarget('arguments,alist1) repeat sayBrightly concat('" ",x,": ",prefix2String t) - if symbolLassoc('locals,alist1) then + if symbolTarget('locals,alist1) then sayBrightly '" locals" - for [x,:t] in MSORT symbolLassoc('locals,alist1) repeat + for [x,:t] in MSORT symbolTarget('locals,alist1) repeat sayBrightly concat('" ",x,": ",prefix2String t) for [con,:alist2] in alist1 | not (con in '(locals arguments)) repeat sayBrightly concat('" ",prefix2String con) diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot index b8ae514d..f9f7cbf8 100644 --- a/src/interp/sys-utility.boot +++ b/src/interp/sys-utility.boot @@ -45,6 +45,9 @@ module sys_-utility where upwardCut: (%Thing, %List %Thing) -> %List %Thing symbolPosition: (%Symbol,%List %Symbol) -> %Maybe %Short valuePosition: (%Thing,%List %Thing) -> %Maybe %Short + symbolTarget: (%Symbol,%List %Thing) -> %Maybe %Thing + scalarAssoc: (%Thing,%List %Thing) -> %Maybe %Pair(%Thing,%Thing) + scalarTarget: (%Thing,%List %Thing) -> %Maybe %Thing --% $COMBLOCKLIST := nil @@ -148,7 +151,6 @@ ADDASSOC(x,y,l) == x = first first l => [[x,:y],:rest l] [first l,:ADDASSOC(x,y,rest l)] - ++ Remove any assocation pair `(u . x)' from list `v'. DELLASOS: (%Thing,%Alist(%Thing,%Thing)) -> %Alist(%Thing,%Thing) DELLASOS(u,v) == @@ -358,9 +360,6 @@ valuePosition(s,l) == --% assoc -symbolAssoc(s,l) == - or/[symbolEq?(s,first x) and leave x for x in l | cons? x] or nil - scalarAssoc(c,l) == or/[scalarEq?(c,first x) and leave x for x in l | cons? x] or nil @@ -369,10 +368,14 @@ stringAssoc(s,l) == --% lassoc -symbolLassoc(s,l) == +symbolTarget(s,l) == p := symbolAssoc(s,l) => rest p nil +scalarTarget(s,l) == + p := scalarAssoc(s,l) => rest p + nil + --% remove!(l,x) == l = nil => nil diff --git a/src/interp/trace.boot b/src/interp/trace.boot index 976e788e..c1e71e8b 100644 --- a/src/interp/trace.boot +++ b/src/interp/trace.boot @@ -138,8 +138,8 @@ trace1 l == ADDASSOC(x,$options,$optionAlist) optionList:= getTraceOptions $options argument:= - domainList := symbolLassoc("of",optionList) => - symbolLAssoc("ops",optionList) => + domainList := symbolTarget("of",optionList) => + symbolTarget("ops",optionList) => throwKeyedMsg("S2IT0004",nil) opList:= traceList => [["ops",:traceList]] @@ -378,7 +378,7 @@ getPreviousMapSubNames(traceNames) == subs lassocSub(x,subs) == - y := QLASSQ(x,subs) => y + y := symbolTarget(x,subs) => y x rassocSub(x,subs) == @@ -586,7 +586,7 @@ mapLetPrint(x,val,currentFunction) == letPrint(x,val,currentFunction) == if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= symbolLassoc("all",$letAssoc))) then + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= symbolTarget("all",$letAssoc))) then if (y="all" or symbolMember?(x,y)) and not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then sayBrightlyNT [:bright x,": "] @@ -604,7 +604,7 @@ letPrint(x,val,currentFunction) == letPrint2(x,printform,currentFunction) == $BreakMode:local := nil if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= symbolLAssoc("all",$letAssoc))) then + ((y:= symbolTarget(currentFunction,$letAssoc)) or (y:= symbolTarget("all",$letAssoc))) then if (y="all" or symbolMember?(x,y)) and not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then $BreakMode:='letPrint2 @@ -624,7 +624,7 @@ letPrint2(x,printform,currentFunction) == letPrint3(x,xval,printfn,currentFunction) == $BreakMode:local := nil if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= symbolLassoc("all",$letAssoc))) then + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= symbolTarget("all",$letAssoc))) then if (y="all" or symbolMember?(x,y)) and not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then $BreakMode:='letPrint2 @@ -792,7 +792,7 @@ breaklet(fn,vars) == fn = "Undef" => nil fnEntry:= LASSOC(fn,$letAssoc) vars:= - pair := symbolLassoc("BREAK",fnEntry) => setUnion(vars,rest pair) + pair := symbolTarget("BREAK",fnEntry) => setUnion(vars,rest pair) vars $letAssoc:= null fnEntry => [[fn,:[["BREAK",:vars]]],:$letAssoc] diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp index bbf199f6..e922e1de 100644 --- a/src/interp/vmlisp.lisp +++ b/src/interp/vmlisp.lisp @@ -671,26 +671,13 @@ ; 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 ; ignores non-pair a-list entries - (cond ((symbolp X) - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((NOT (consp (CAR Y))) ) - ((EQ (CAAR Y) X) (RETURN (CAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) + (cond ((symbolp X) (|symbolAssoc| X Y)) ((or (numberp x) (characterp x)) - (PROG NIL - A (COND ((ATOM Y) (RETURN NIL)) - ((NOT (consp (CAR Y))) ) - ((EQL (CAAR Y) X) (RETURN (CAR Y))) ) - (SETQ Y (CDR Y)) - (GO A))) + (|scalarAssoc| X Y)) (t (PROG NIL A (COND ((ATOM Y) (RETURN NIL)) -- cgit v1.2.3