diff options
Diffstat (limited to 'src/interp')
36 files changed, 252 insertions, 230 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 4804f25b..55cea06a 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -216,7 +216,7 @@ ${AXIOMSYS}: database.date \ $(BOOTSYS) -- \ --system="$(AXIOM)/" \ --sysalg="$(axiom_targetdir)/algebra/" \ - --prologue="(pushnew :open-axiom-basic-system *features*)" \ + --prologue="(pushnew :open-axiom-algebra-system *features*)" \ --make --output=$@ --main="BOOT::|systemMain|" \ --load-directory=. $(OBJS) makeint.$(LNKEXT) @ echo 6a $@ created diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 7ba5f03b..3455bfe9 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -379,7 +379,7 @@ ${AXIOMSYS}: database.date \ $(BOOTSYS) -- \ --system="$(AXIOM)/" \ --sysalg="$(axiom_targetdir)/algebra/" \ - --prologue="(pushnew :open-axiom-basic-system *features*)" \ + --prologue="(pushnew :open-axiom-algebra-system *features*)" \ --make --output=$@ --main="BOOT::|systemMain|" \ --load-directory=. $(OBJS) makeint.$(LNKEXT) @ echo 6a $@ created diff --git a/src/interp/c-doc.boot b/src/interp/c-doc.boot index c99b359b..ce5958d2 100644 --- a/src/interp/c-doc.boot +++ b/src/interp/c-doc.boot @@ -833,8 +833,8 @@ hasNoVowels x == and/[not isVowel(x.i) for i in 0..max] isVowel c == - EQ(c,char 'a) or EQ(c,char 'e) or EQ(c,char 'i) or EQ(c,char 'o) or EQ(c,char 'u) or - EQ(c,char 'A) or EQ(c,char 'E) or EQ(c,char 'I) or EQ(c,char 'O) or EQ(c,char 'U) + c=char 'a or c=char 'e or c=char 'i or c=char 'o or c=char 'u or + c=char 'A or c=char 'E or c=char 'I or c=char 'O or c=char 'U checkAddBackSlashes s == diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot index 3bcf12c2..7aba9153 100644 --- a/src/interp/c-util.boot +++ b/src/interp/c-util.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -496,11 +496,26 @@ makeLiteral(x,e) == isSomeDomainVariable s == IDENTP s and #(x:= PNAME s)>2 and x.(0)="#" and x.(1)="#" - + +++ Return non-nil is the domain form `x' is a `subset' of domain +++ form `y' in the environment `e'. The relation of subdomain +++ is understood as equivalent to the fact that all values of +++ the domain designated by `x' are also values of the domain +++ designated by `y'. Examples include declaration of domain `x' +++ as satisfying SubsetCategory(SomeCategory, y). Or, when +++ x is defined as SubDomain(y,pred). In that case, the predicate +++ is returned and its parameter is `#1'. isSubset(x,y,e) == - ($useRepresentationHack and x="$" and y="Rep") or x=y or - LASSOC(opOf x,get(opOf y,"Subsets",e) or GETL(opOf y,"Subsets")) or - LASSOC(opOf x,get(opOf y,"SubDomain",e)) or opOf(y)="Type" + x = y => true + -- Every domain or catgory is a subset of Type. + y = $Type => true + -- When using the old style definition, the current domain + -- is considered a subset of its representation domain + x = "$" and y = "Rep" => $useRepresentationHack + -- Or, if x has the Subsets property set by SubsetCategory. + pred := LASSOC(opOf x,get(opOf y,"Subsets",e)) => pred + -- Or, they are related by subdomain chain. + isDomainForm(x,e) and isSubDomain(x,y) isDomainInScope(domain,e) == domainList:= getDomainsInScope e diff --git a/src/interp/category.boot b/src/interp/category.boot index 91a79604..15fe1efe 100644 --- a/src/interp/category.boot +++ b/src/interp/category.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -297,10 +297,10 @@ SigListOpSubsume([[name1,sig1,:.],:.],list) == --does m subsume another operator in the list? --see "operator subsumption" in SYSTEM SCRIPT --if it does, returns the subsumed member - lsig1:=LENGTH sig1 + lsig1 := #sig1 ans:=[] for (n:=[[name2,sig2,:.],:.]) in list repeat - name1=name2 and EQ(lsig1,LENGTH sig2) and SourceLevelSubsume(sig1,sig2) => + name1=name2 and lsig1 = #sig2 and SourceLevelSubsume(sig1,sig2) => ans:=[n,:ans] return ans @@ -320,9 +320,7 @@ SourceLevelSubset(a,b) == $noSubsumption=true => false b is ["Union",:blist] and member(a,blist) => true BOUNDP '$noSubsets and $noSubsets => false - atom b and assoc(a,GETL(b,"Subsets")) => true - a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true - nil + not null isSubDomain(a,b) MachineLevelSubsume([name1,[out1,:in1],:flag1],[name2,[out2,:in2],:flag2]) == -- Checks for machine-level subsumption in the sense of SYSTEM SCRIPT @@ -338,10 +336,8 @@ MachineLevelSubset(a,b) == b is ["Union",:blist] and member(a,blist) and (and/[STRINGP x for x in blist | x^=a]) => true --all other branches must be distinct objects - atom b and assoc(a,GETL(b,"Subsets")) => true - a is [a1] and b is [b1] and assoc(a1,GETL(b1,"Subsets")) => true + not null isSubDomain(a,b) --we assume all subsets are true at the machine level - nil --% Ancestor chasing code diff --git a/src/interp/clam.boot b/src/interp/clam.boot index 863b255c..a0414464 100644 --- a/src/interp/clam.boot +++ b/src/interp/clam.boot @@ -611,7 +611,7 @@ hputNewProp(ht,op,argList,val) == listTruncate(l,n) == u:= l n:= QSSUB1 n - while NEQ(n,0) and null atom u repeat + while n ^= 0 and null atom u repeat n:= QSSUB1 n u:= QCDR u if null atom u then diff --git a/src/interp/compiler.boot b/src/interp/compiler.boot index 6885ba74..bc56663c 100644 --- a/src/interp/compiler.boot +++ b/src/interp/compiler.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -407,7 +407,7 @@ primitiveType x == INTEGERP x => x=0 => $NonNegativeInteger x>0 => $PositiveInteger - true => $NegativeInteger + $Integer FLOATP x => $DoubleFloat nil @@ -458,10 +458,6 @@ mkUnion(a,b) == b is ["Union",:l] => ["Union",:union([a],l)] ["Union",a,b] -maxSuperType(m,e) == - typ:= get(m,"SuperDomain",e) => maxSuperType(typ,e) - m - hasType(x,e) == fn get(x,"condition",e) where fn x == @@ -822,7 +818,7 @@ setqSingle(id,val,m,E) == eval or return nil where eval() == T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and + not get(id,"mode",E) and m'' ^= (maxm'':=maximalSuperType m'') and (T:=comp(val,maxm'',E)) => T (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => assignError(val,T.mode,id,m'') @@ -1458,17 +1454,18 @@ coerceEasy(T,m) == T.mode=$EmptyMode or modeEqualSubst(T.mode,m,T.env) => [T.expr,m,T.env] +satisfies(val,pred) == + pred=false or pred=true => pred + eval ["LET",[["#1",val]],pred] coerceSubset: (%Triple,%Mode) -> %Maybe %Triple coerceSubset([x,m,e],m') == isSubset(m,m',e) => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and - -- obviously this is temporary - eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] + isDomainForm(m,e) and isSubDomain(m,m') => [x,m',e] + INTEGERP x => + -- obviously this is temporary + satisfies(x,isSubDomain(m',maximalSuperType m)) => [x,m',e] + nil nil coerceHard: (%Triple,%Mode) -> %Maybe %Triple @@ -1554,10 +1551,10 @@ compCoerce1(x,m',e) == T:=[T.expr,m1,T.env] T':= coerce(T,m') => T' T':= coerceByModemap(T,m') => T' - pred:=isSubset(m',T.mode,e) => - gg:=GENSYM() - pred:= substitute(gg,"*",pred) - code:= ['PROG1,["%LET",gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] + pred := isSubset(m',T.mode,e) => + gg := GENSYM() + pred := substitute(gg,"#1",pred) + code := ['PROG1,["%LET",gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] [code,m',T.env] coerceByModemap([x,m,e],m') == diff --git a/src/interp/cparse.boot b/src/interp/cparse.boot index 7f2c2971..c3b11c5b 100644 --- a/src/interp/cparse.boot +++ b/src/interp/cparse.boot @@ -264,7 +264,7 @@ npLeftAssoc(operations,parser)== else false npInfixOp()== - EQ(CAAR $stok,"key") and + CAAR $stok = "key" and GETL($ttok,"INFGENERIC") and npPushId() npInfixOperator()== npInfixOp() or @@ -279,7 +279,7 @@ npInfixOperator()== npInfixOp() or npRestore a false -npInfKey s== EQ(CAAR $stok,"key") and MEMQ($ttok,s) and npPushId() +npInfKey s== CAAR $stok="key" and MEMQ($ttok,s) and npPushId() npDDInfKey s== npInfKey s or @@ -334,20 +334,20 @@ npWConditional f== -- peek for keyword s, no advance of token stream -npEqPeek s == EQ(CAAR $stok,"key") and EQ(s,$ttok) +npEqPeek s == CAAR $stok="key" and EQ(s,$ttok) -- test for keyword s, if found advance token stream npEqKey s == - EQ(CAAR $stok,"key") and EQ(s,$ttok) and npNext() + CAAR $stok="key" and EQ(s,$ttok) and npNext() $npTokToNames:= ["~","#","[]","{}", "[||]","{||}"] npId() == - EQ(CAAR $stok,"id") => + CAAR $stok="id" => npPush $stok npNext() - EQ(CAAR $stok,"key") and MEMQ($ttok,$npTokToNames)=> + CAAR $stok="key" and MEMQ($ttok,$npTokToNames)=> npPush tokConstruct("id",$ttok,tokPosn $stok) npNext() false diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 9355c2a1..551925ee 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2008, Gabriel Dos Reis. +;; Copyright (C) 2007-2009, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -226,6 +226,7 @@ parents ; browse. users ; browse. dependents ; browse. + superdomain ; interp. spare ; superstition ) ; database structure @@ -557,11 +558,12 @@ ; constructormodemap for domains and packages so it is stored ; as NIL for them. it is valid for categories. ; niladic -- t or nil directly -; unused +; abbrev -- kept directly ; cosig -- kept directly ; constructorkind -- kept directly ; defaultdomain -- a short list, for %i ; ancestors -- used to compute new category updates +; superdomain -- valid for domain, NIL for category and package. ; ) (defun interpOpen () "open the interpreter database and hash the keys" @@ -590,7 +592,10 @@ (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert (setf (database-cosig dbstruct) (ninth item)) (setf (database-constructorkind dbstruct) (tenth item)) - (setf (database-ancestors dbstruct) (nth 11 item)))) + (setf (database-ancestors dbstruct) (nth 11 item)) + (setf (database-superdomain dbstruct) (nth 12 item)) + )) + (format t "~&"))) ; this is an initialization function for the constructor database @@ -828,11 +833,9 @@ (constructor? (|fatalError| "GETDATABASE called with CONSTRUCTOR?")) (superdomain ; only 2 superdomains in the world - (case constructor - (|NonNegativeInteger| - (setq data '((|Integer|) (IF (< |#1| 0) |false| |true|)))) - (|PositiveInteger| - (setq data '((|NonNegativeInteger|) (< 0 |#1|)))))) + (setq stream *interp-stream*) + (when (setq struct (get constructor 'database)) + (setq data (database-superdomain struct)))) (constructor (when (setq data (get constructor 'abbreviationfor)))) (defaultdomain @@ -881,7 +884,11 @@ (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) (file-position stream data) - (setq data (unsqueeze (read stream))) + ;; Don't attempt to uncompress codes -- they are not compressed. + (setq data (read stream)) + (unless (eq key 'superdomain) + (setq data (unsqueeze data))) + ;;(setq data (unsqueeze (read stream))) (case key ; cache the result of the database read (operation (setf (gethash constructor *operation-hash*) data)) @@ -919,6 +926,8 @@ (setf (database-documentation struct) data)) (parents (setf (database-parents struct) data)) + (superdomain + (setf (database-superdomain struct) data)) (users (setf (database-users struct) data)) (dependents @@ -1197,6 +1206,14 @@ (fetchdata alist in "predicates")) (setf (database-niladic dbstruct) (when (fetchdata alist in "NILADIC") t)) + (let ((super (fetchdata alist in "evalOnLoad2"))) + (setf (database-superdomain dbstruct) + (when super + (setq super (cddr super)) + ;; unquote the domain and predicate. + (rplaca super (second (first super))) + (rplacd super (cdr (second super))) + super))) (addoperations key oldmaps) (unless make-database? (if (eq kind '|category|) @@ -1408,7 +1425,7 @@ (declare (special *ancestors-hash*)) (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* concategory categorypos kind niladic cosig abbrev defaultdomain - ancestors ancestorspos out) + ancestors ancestorspos superpos out) (print "building interp.daase") (setq out (open "interp.build" :direction :output)) (princ " " out) @@ -1452,9 +1469,18 @@ (print ancestors out) (finish-output out)) (setq ancestorspos nil)) + (setq superpos + ;; We do NOT want to compress codes, as we may not be + ;; able to uncompress them to their original form. + (let ((super (database-superdomain struct))) + (when super + (prog1 (file-position out) + (print super out) + (finish-output out))))) + (push (list constructor opalistpos cmodemappos modemapspos obj categorypos niladic abbrev cosig kind defaultdomain - ancestorspos) master))) + ancestorspos superpos) master))) (finish-output out) (setq masterpos (file-position out)) (print (|squeezeAll| master) out) diff --git a/src/interp/define.boot b/src/interp/define.boot index 4492e042..a026ed33 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -1441,16 +1441,18 @@ compSubDomain1(domainForm,predicate,m,e) == compCompilerPredicate(predicate,e) or stackSemanticError(["predicate: ",predicate, " cannot be interpreted with #1: ",domainForm],nil) - prefixPredicate:= lispize u.expr + pred := lispize u.expr + -- For now, reject predicates that directly reference domains + CONTAINED("$",pred) => + stackAndThrow('"predicate %1pb is not simple enough",[predicate]) + -- Abstract over references to parameters of enclosing functor. + pred := eqSubst($AtVariables,rest $form, pred) $lisplibSuperDomain:= [domainForm,predicate] - evalAndRwriteLispForm('evalOnLoad2, - ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' - (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ - 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' - (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) + evalAndRwriteLispForm('evalOnLoad2, ["noteSubDomainInfo", quoteForm $op, + quoteForm domainForm, quoteForm pred]) [domainForm,m,e] - + compCapsuleInner(itemList,m,e) == e:= addInformation(m,e) --puts a new 'special' property of $Information diff --git a/src/interp/g-cndata.boot b/src/interp/g-cndata.boot index c0af28c2..58783619 100644 --- a/src/interp/g-cndata.boot +++ b/src/interp/g-cndata.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -94,13 +94,6 @@ categoryForm? c == getConstructorKindFromDB op = "category" => true false -getImmediateSuperDomain(d) == - IFCAR getSuperDomainFromDB opOf d - -maximalSuperType d == - d' := getSuperDomainFromDB opOf d => maximalSuperType first d' - d - -- probably will switch over to 'libName soon getLisplibName(c) == getConstructorAbbreviation(c) diff --git a/src/interp/g-opt.boot b/src/interp/g-opt.boot index f19a4d69..49c0229a 100644 --- a/src/interp/g-opt.boot +++ b/src/interp/g-opt.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -372,13 +372,6 @@ optLESSP u == ['GREATERP,b,a] u -optEQ u == - u is ['EQ,l,r] => - NUMBERP l and NUMBERP r => ['QUOTE,EQ(l,r)] - -- That undoes some weird work in Boolean to do with the definition of true - u - u - $simpleVMoperators == '(CONS CAR CDR LENGTH SIZE EQUAL EQL EQ NOT NULL OR AND SPADfirst QVELT _+ _- _* _< _= @@ -451,7 +444,6 @@ lispize x == first optimize [x] for x in '( (call optCall) _ (SEQ optSEQ)_ - (EQ optEQ)_ (MINUS optMINUS)_ (QSMINUS optQSMINUS)_ (_- opt_-)_ diff --git a/src/interp/g-util.boot b/src/interp/g-util.boot index 39302d6b..6f2961d8 100644 --- a/src/interp/g-util.boot +++ b/src/interp/g-util.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -41,6 +41,7 @@ module g_-util where getTypeOfSyntax: %Form -> %Mode pairList: (%List,%List) -> %List mkList: %List -> %List + isSubDomain: (%Mode,%Mode) -> %Form ++ $interpOnly := false @@ -62,6 +63,62 @@ isSharpVarWithNum x == ok := DIGITP d => c := 10*c + DIG2FIX d if ok then c else nil + +--% Sub-domains information handlers + +++ If `dom' is a subdomain, return its immediate super-domain. +superType: %Mode -> %Maybe %Mode +superType dom == + dom isnt [ctor,:args] => nil + [super,.] := getSuperDomainFromDB ctor or return nil + sublisFormal(args,super,$AtVariables) + +++ Return the root of the reflexive transitive closure of +++ the super-domain chain for the domain designated by the domain +++ form `d'. +maximalSuperType: %Mode -> %Mode +maximalSuperType d == + atom d => d + d' := superType d => maximalSuperType d' + d + +++ Note that the functor `sub' instantiates to domains that +++ are subdomains of `super' instances restricted by the +++ predicate `pred'. +noteSubDomainInfo: (%Symbol,%Instantiation,%Form) -> %Thing +noteSubDomainInfo(sub,super,pred) == + MAKEPROP(sub,"%SuperDomain",[super,pred]) + +++ Returns non-nil if `d1' is a sub-domain of `d2'. This is the +++ case when `d1' is transitively given by an instance of SubDomain +++ d1 == SubDomain(d2,pred) +++ The transitive closure of the predicate form is returned, where +++ the predicate parameter is `#1'. +isSubDomain(d1,d2) == + atom d1 or atom d2 => false + + -- 1. Easy, if by syntax constructs. + d1 is ["SubDomain",=d2,pred] => pred + + -- 2. Just say no, if there is no hope. + [sup,pred] := getSuperDomainFromDB first d1 or return false + + -- 3. We may be onto something. + -- `sup' and `pred' are in most general form. Instantiate. + first sup = first d2 => + -- sanity check. `d2' should be an instance of `sup'. + sublisFormal(rest d1,sup,$AtVariables) ^= d2 => + stackAndThrow('"unexpected instantiation mismatch",nil) + sublisFormal(rest d1,pred,$AtVariables) + + -- 4. Otherwise, lookup in the super-domain chain. + pred' := isSubDomain(sup,d2) => MKPF([pred',pred],"AND") + + -- 5. Lot of smoke, no fire. + false + +--% + mkList u == u => ["LIST",:u] nil @@ -512,7 +569,7 @@ mergeInPlace(f,g,p,q) == r mergeSort(f,g,p,n) == - if EQ(n,2) and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then + if n=2 and FUNCALL(f,FUNCALL(g,QCADR p),FUNCALL(g,QCAR p)) then t := p p := QCDR p QRPLACD(p,t) diff --git a/src/interp/i-analy.boot b/src/interp/i-analy.boot index 91ff077e..35c0ae0f 100644 --- a/src/interp/i-analy.boot +++ b/src/interp/i-analy.boot @@ -503,7 +503,7 @@ bottomUpForm3(t,op,opName,argl,argModeSetList) == bottomUpForm2(t,op,opName,argl,argModeSetList) bottomUpForm2(t,op,opName,argl,argModeSetList) == - not atom t and EQ(opName,"%%") => bottomUpPercent t + not atom t and opName="%%" => bottomUpPercent t opVal := getValue op -- for things with objects in operator position, be careful before @@ -749,7 +749,7 @@ bottomUpFormRetract(t,op,opName,argl,amsl) == if PAIRP(m) and CAR(m) = $EmptyMode then return NIL object:= retract getValue x a:= [x,:a] - EQ(object,'failed) => + object="failed" => putAtree(x,'retracted,nil) ms := [m, :ms] b:= true @@ -771,7 +771,7 @@ bottomUpFormRetract(t,op,opName,argl,amsl) == retractAtree atr == object:= retract getValue atr - EQ(object,'failed) => + object="failed" => putAtree(atr,'retracted,nil) nil putAtree(atr,'retracted,true) diff --git a/src/interp/i-coerce.boot b/src/interp/i-coerce.boot index 1ca27f51..75b88d46 100644 --- a/src/interp/i-coerce.boot +++ b/src/interp/i-coerce.boot @@ -441,12 +441,12 @@ canCoerce1(t1,t2) == nt1 := CAR t1 nt2 := CAR t2 - EQ(nt1,'Mapping) => EQ(nt2,'Any) - EQ(nt2,'Mapping) => - EQ(nt1,'Variable) or EQ(nt1,'FunctionCalled) => + nt1="Mapping" => nt2="Any" + nt2="Mapping" => + nt1="Variable" or nt1="FunctionCalled" => canCoerceExplicit2Mapping(t1,t2) NIL - EQ(nt1,'Union) or EQ(nt2,'Union) => canCoerceUnion(t1,t2) + nt1="Union" or nt2="Union" => canCoerceUnion(t1,t2) -- efficiency hack t1 is ['Segment, s1] and t2 is ['UniversalSegment, s2] and @@ -929,32 +929,15 @@ coerceInt1(triple,t2) == coerceSubDomain(val, tSuper, tSub) == -- Try to coerce from a sub domain to a super domain val = '_$fromCoerceable_$ => nil - super := getSuperDomainFromDB first tSub - superDomain := first super - superDomain = tSuper => - coerceImmediateSubDomain(val, tSuper, tSub, CADR super) - coerceSubDomain(val, tSuper, superDomain) => - coerceImmediateSubDomain(val, superDomain, tSub, CADR super) - nil - -coerceImmediateSubDomain(val, tSuper, tSub, pred) == - predfn := getSubDomainPredicate(tSuper, tSub, pred) - FUNCALL(predfn, val, nil) => objNew(val, tSub) + pred := isSubDomain(tSub,tSuper) => + predFun := getSubDomainPredicate(tSuper,tSub,pred) + FUNCALL(predFun,val) => objNew(val,tSub) nil getSubDomainPredicate(tSuper, tSub, pred) == - $env: local := $InteractiveFrame predfn := HGET($superHash, CONS(tSuper, tSub)) => predfn - name := GENSYM() - decl := ['_:, name, ['Mapping, $Boolean, tSuper]] - interpret(decl, nil) arg := GENSYM() - pred' := substitute(arg, "#1", pred) - defn := ['DEF, [name, arg], '(NIL NIL), '(NIL NIL), removeZeroOne pred'] - interpret(defn, nil) - op := mkAtree name - transferPropsToNode(name, op) - predfn := CADAR selectLocalMms(op, name, [tSuper],$Boolean) + predfn := COMPILE(nil,["LAMBDA",[arg],substitute(arg,"#1", pred)]) HPUT($superHash, CONS(tSuper, tSub), predfn) predfn diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot index daededbc..a4f279b6 100644 --- a/src/interp/i-funsel.boot +++ b/src/interp/i-funsel.boot @@ -663,13 +663,13 @@ hitListOfTarget(t) == t = '(Polynomial (Pi)) => 90000 - EQ(CAR t, 'Polynomial) => 300 - EQ(CAR t, 'List) => 400 - EQ(CAR t,'Matrix) => 910 - EQ(CAR t,'UniversalSegment) => 501 - EQ(CAR t,'RationalFunction) => 900 - EQ(CAR t,'Union) => 999 - EQ(CAR t,'Expression) => 1600 + CAR t ='Polynomial => 300 + CAR t = 'List => 400 + CAR t = 'Matrix => 910 + CAR t = 'UniversalSegment => 501 + CAR t = 'RationalFunction => 900 + CAR t = 'Union => 999 + CAR t = 'Expression => 1600 500 getFunctionFromDomain(op,dc,args) == @@ -856,16 +856,16 @@ findFunctionInDomain1(omm,op,tar,args1,args2,SL) == if CONTAINED('_#, sig) or CONTAINED('construct,sig) then sig := [replaceSharpCalls t for t in sig] matchMmCond cond and matchMmSig(mm,tar,args1,args2) and - EQ(y,'Subsumed) and + y="Subsumed" and -- hmmmm: do Union check in following because (as in DP) -- Unions are subsumed by total modemaps which are in the -- mm list in findFunctionInDomain. y := 'ELT -- if subsumed fails try it again not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f - EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] + y='ELT => [[CONS(dc,sig),osig,nreverse $RTC]] + y='CONST => [[CONS(dc,sig),osig,nreverse $RTC]] + y='ASCONST => [[CONS(dc,sig),osig,nreverse $RTC]] y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] sayKeyedMsg("S2IF0006",[y]) NIL @@ -1112,7 +1112,7 @@ selectMmsGen(op,tar,args1,args2) == NIL [c,t,:a] := sig if a then matchTypes(a,args1,args2) - not EQ($Subst,'failed) => + $Subst ^= 'failed => mmS := nconc(evalMm(op,tar,sig,mmC),mmS) mmS @@ -1145,7 +1145,7 @@ evalMm(op,tar,sig,mmC) == mS:= NIL for st in evalMmStack mmC repeat SL:= evalMmCond(op,sig,st) - not EQ(SL,'failed) => + SL ^= 'failed => SL := fixUpTypeArgs SL sig:= [subCopy(deepSubCopy(x,SL),$Subst) for x in sig] not containsVars sig => diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot index 15dd641d..e804fb2d 100644 --- a/src/interp/i-output.boot +++ b/src/interp/i-output.boot @@ -1676,7 +1676,7 @@ printBasic x == PRIN1(x,$algebraOutputStream) charybdis(u,start,linelength) == - EQ(keyp u,'EQUATNUM) and ^(CDDR u) => + keyp u='EQUATNUM and ^(CDDR u) => charybdis(['PAREN,u.1],start,linelength) charyTop(u,start,linelength) @@ -1692,7 +1692,7 @@ charyTop(u,start,linelength) == (w := WIDTH(b)) > linelength-start => charyTop(a,start,linelength) charyTop(b,half(linelength-start-w),linelength) v := charyTopWidth u - EQ(keyp u,'ELSE) => charyElse(u,v,start,linelength) + keyp u='ELSE => charyElse(u,v,start,linelength) WIDTH(v) > linelength => charyTrouble(u,v,start,linelength) d := APP(v,start,0,nil) n := superspan v @@ -1737,16 +1737,16 @@ charyTrouble1(u,v,start,linelength) == atom u => outputString(start,linelength,atom2String u) EQ(x:= keyp u,'_-) => charyMinus(u,v,start,linelength) MEMQ(x,'(_+ _* AGGLST)) => charySplit(u,v,start,linelength) - EQ(x,'EQUATNUM) => charyEquatnum(u,v,start,linelength) + x='EQUATNUM => charyEquatnum(u,v,start,linelength) d := GETL(x,'INFIXOP) => charyBinary(d,u,v,start,linelength) x = 'OVER => charyBinary(GETL("/",'INFIXOP),u,v,start,linelength) - EQ(3,LENGTH u) and GETL(x,'Led) => + 3=#u and GETL(x,'Led) => d:= PNAME first GETL(x,'Led) charyBinary(d,u,v,start,linelength) - EQ(x,'CONCAT) => + x='CONCAT => concatTrouble(rest v,d,start,linelength,nil) - EQ(x,'CONCATB) => + x='CONCATB => (rest v) is [loop, 'repeat, body] => charyTop(['CONCATB,loop,'repeat],start,linelength) charyTop(body,start+2,linelength-2) @@ -1756,21 +1756,21 @@ charyTrouble1(u,v,start,linelength) == charyTop(body,start+2,linelength-2) concatTrouble(rest v,d,start,linelength,true) GETL(x,'INFIXOP) => charySplit(u,v,start,linelength) - EQ(x,'PAREN) and + x='PAREN and (EQ(keyp u.1,'AGGLST) and (v:= ",") or EQ(keyp u.1,'AGGSET) and (v:= ";")) => bracketagglist(rest u.1,start,linelength,v,"_(","_)") - EQ(x,'PAREN) and EQ(keyp u.1,'CONCATB) => + x='PAREN and EQ(keyp u.1,'CONCATB) => bracketagglist(rest u.1,start,linelength," ","_(","_)") - EQ(x,'BRACKET) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => + x='BRACKET and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => bracketagglist(rest u.1,start,linelength,v, specialChar 'lbrk, specialChar 'rbrk) - EQ(x,'BRACE) and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => + x='BRACE and (EQ(keyp u.1,'AGGLST) and (v:= ",")) => bracketagglist(rest u.1,start,linelength,v, specialChar 'lbrc, specialChar 'rbrc) - EQ(x,'EXT) => longext(u,start,linelength) - EQ(x,'MATRIX) => MATUNWND() - EQ(x,'ELSE) => charyElse(u,v,start,linelength) - EQ(x,'SC) => charySemiColon(u,v,start,linelength) + x='EXT => longext(u,start,linelength) + x='MATRIX => MATUNWND() + x='ELSE => charyElse(u,v,start,linelength) + x='SC => charySemiColon(u,v,start,linelength) charybdis(x,start,linelength) if rest u then charybdis(['ELSE,:rest u],start,linelength) -- changed from charybdis(...) by JHD 2 Aug 89, since rest u might be null @@ -1964,7 +1964,7 @@ appext(u,x,y,d) == temp := 1 + WIDTH agg(2,u) + WIDTH agg(3,u) n := MAX(WIDTH CADR u, WIDTH agg(4,u), temp) if EQCAR(first(z := agg(5,u)), 'EXT) and - (EQ(n,3) or (n > 3 and ^(atom z)) ) then + (n=3 or (n > 3 and ^(atom z)) ) then n := 1 + n d := APP(z, x + n, y, d) @@ -2040,7 +2040,7 @@ extwidth(u) == 1 + WIDTH agg(2, u) + WIDTH agg(3, u) ) nil or (EQCAR(first(z := agg(5, u)), 'EXT) and _ - (EQ(n, 3) or ((n > 3) and null atom z) ) => + (n=3 or ((n > 3) and null atom z) ) => n := 1 + n) true => n + WIDTH agg(5, u) @@ -2332,7 +2332,7 @@ bracketagglist(u, start, linelength, tchr, open, close) == ((s := s + WIDTH first x + 1) >= linelength) => return(s) null rest x => return(s := -1) nil or - EQ(s, -1) => (nextu := nil) + s = -1 => (nextu := nil) EQ(lastx, u) => ((nextu := rest u); RPLACD(u, nil) ) true => ((nextu := lastx); RPLACD(PREDECESSOR(lastx, u), nil)) for x in tails u repeat diff --git a/src/interp/i-resolv.boot b/src/interp/i-resolv.boot index 658ddcec..75aca0e1 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-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -374,8 +374,7 @@ resolveTCat(t,c) == c = '(Ring) and t is ['FactoredForm,t0] => ['FactoredRing,t0] - (t is [t0]) and (sd := getImmediateSuperDomain(t0)) and sd ^= t0 => - resolveTCat(sd,c) + sd := superType t => resolveTCat(sd,c) SIZE(td := deconstructT t) ^= 2=> NIL SIZE(tc := deconstructT c) ^= 2 => NIL diff --git a/src/interp/i-spec2.boot b/src/interp/i-spec2.boot index a4abcc75..eb635d72 100644 --- a/src/interp/i-spec2.boot +++ b/src/interp/i-spec2.boot @@ -94,7 +94,7 @@ upDollar t == t2 := t (not $genValue) and "or"/[CONTAINED(var,D) for var in $localVars] => keyedMsgCompFailure("S2IS0032",NIL) - EQ(D,"Lisp") => upLispCall(op,form) + D="Lisp" => upLispCall(op,form) if VECP D and (SIZE(D) > 0) then D := D.0 t := evaluateType unabbrev D categoryForm? t => @@ -315,7 +315,7 @@ interpIF(op,cond,a,b) == val:= getValue cond val:= coerceInteractive(val,$Boolean) => objValUnwrap(val) => upIFgenValue(op,a) - EQ(b,"%noBranch") => setValueToVoid op + b="%noBranch" => setValueToVoid op upIFgenValue(op,b) throwKeyedMsg("S2IS0031",NIL) @@ -653,7 +653,7 @@ upLETWithFormOnLhs(op,lhs,rhs) == seteltable(lhs is [f,:argl],rhs) == -- produces the setelt form for trees such as "l.2:= 3" null (g := getUnnameIfCan f) => NIL - EQ(g,"elt") => altSeteltable [:argl, rhs] + g="elt" => altSeteltable [:argl, rhs] get(g,'value,$e) is [expr,:.] and isMapExpr expr => NIL transferPropsToNode(g,f) getValue(lhs) or getMode(lhs) => diff --git a/src/interp/i-util.boot b/src/interp/i-util.boot index 73fe7ce2..b1ce6575 100644 --- a/src/interp/i-util.boot +++ b/src/interp/i-util.boot @@ -1,5 +1,7 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. +-- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without -- modification, are permitted provided that the following conditions are @@ -101,16 +103,6 @@ LZeros n == -- subrToName x == BPINAME x --- formerly in clammed.boot - -isSubDomain(d1,d2) == - -- d1 and d2 are different domains - subDomainList := '(Integer NonNegativeInteger PositiveInteger) - ATOM d1 or ATOM d2 => nil - l := MEMQ(CAR d2, subDomainList) => - MEMQ(CAR d1, CDR l) - nil - $variableNumberAlist := nil variableNumber(x) == diff --git a/src/interp/interop.boot b/src/interp/interop.boot index 58b46b42..fde42557 100644 --- a/src/interp/interop.boot +++ b/src/interp/interop.boot @@ -360,7 +360,7 @@ basicLookupCheckDefaults(op,sig,domain,dollar) == $hasCatOpHash := hashString '"%%" opIsHasCat op == hashCode? op => EQL(op, $hasCatOpHash) - EQ(op, "%%") + op = "%%" -- has cat questions lookup up twice if false -- replace with following ? @@ -439,7 +439,7 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == nil slot := domain.loc null atom slot => - EQ(QCAR slot,'newGoGet) => someMatch:=true + QCAR slot = 'newGoGet => someMatch:=true --treat as if operation were not there --if EQ(QCAR slot,'newGoGet) then -- UNWIND_-PROTECT --break infinite recursion @@ -561,7 +561,7 @@ newHasAttribute(domain,attrib) == or/[x for x in domain.2 | attrib = hashType(first x, hashPercent)] LASSOC(attrib,domain.2) predIndex => - EQ(predIndex,0) => true + predIndex = 0 => true predvec := domain.3 testBitVector(predvec,predIndex) false @@ -575,7 +575,7 @@ newHasCategory(domain,catform) == #catvec > 0 and INTEGERP KDR catvec.0 => --old style predIndex := lazyMatchAssocV1(catform,catvec,domain) null predIndex => false - EQ(predIndex,0) => true + predIndex = 0 => true predvec := QVELT(domain,3) testBitVector(predvec,predIndex) lazyMatchAssocV(catform,auxvec,catvec,domain) --new style diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 74d05485..9fd15b53 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -573,7 +573,7 @@ findConstructorSlotNumber(domainForm,domain,op,sig) == "and"/[compare for a in sig for b in sig1]] where compare() == a=b => true FIXP b => a=constructorArglist.b - isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + isSubset(bustUnion a,bustUnion b,$CategoryFrame) tail is [.,["ELT",.,n]] => n systemErrorHere ["findConstructorSlotNumber",domainForm] @@ -599,7 +599,7 @@ sigsMatch(sig,sig1,domainForm) == partsMatch:= (item:= CAR sig)=(item1:= CAR sig1) => true --ok, go to next iteration FIXP item1 => item = domainForm.item1 --item1=n means nth arg - isSuperDomain(bustUnion item,bustUnion item1,$CategoryFrame) + isSubset(bustUnion item1,bustUnion item,$CategoryFrame) null partsMatch => return nil sig:= rest sig; sig1 := rest sig1 sig or sig1 => nil @@ -608,7 +608,7 @@ sigsMatch(sig,sig1,domainForm) == findDomainSlotNumber(domain,op,sig) == --using slot 1 of the domain nsig:=#sig tail:= or/[r for [[op1,sig1],:r] in domain.1 | op=op1 and nsig=#sig1 and - "and"/[a=b or isSuperDomain(bustUnion b,bustUnion a,$CategoryFrame) + "and"/[a=b or isSubset(bustUnion a,bustUnion b,$CategoryFrame) for a in sig for b in sig1]] tail is [.,["ELT",.,n]] => n systemErrorHere '"findDomainSlotNumber" diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index d836c3ed..9f0b5be0 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -47,10 +47,10 @@ $forceAdd := false addDomain(domain,e) == atom domain => - EQ(domain,"$EmptyMode") => e - EQ(domain,"$NoValueMode") => e + domain="$EmptyMode" => e + domain="$NoValueMode" => e not IDENTP domain or 2<#(s:= STRINGIMAGE domain) and - EQ(char "#",s.(0)) and EQ(char "#",s.(1)) => e + char "#" = s.0 and char "#" = s.1 => e MEMQ(domain,getDomainsInScope e) => e isLiteral(domain,e) => e addNewDomain(domain,e) @@ -190,7 +190,7 @@ mkNewModemapList(mc,sig,pred,fn,curModemapList,e,filenameOrNil) == mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == for (mmtail:= [[[mc',:sig'],[pred',:.],:.],:.]) in tails modemapList repeat - mc=mc' or isSuperDomain(mc',mc,e) => + mc=mc' or isSubset(mc,mc',e) => newmm:= nil mm:= modemapList while (not EQ(mm,mmtail)) repeat (newmm:= [first mm,:newmm]; mm:= rest mm) @@ -211,19 +211,13 @@ mergeModemap(entry is [[mc,:sig],[pred,:.],:.],modemapList,e) == -- In ptic., SubResGcd in SparseUnivariatePolynomial is miscompiled --mergeModemap(entry:=((mc,:sig),:.),modemapList,e) == -- for (mmtail:= (((mc',:sig'),:.),:.)) in tails modemapList do --- mc=mc' or isSuperDomain(mc',mc,e) => +-- mc=mc' or isSubset(mc,mc',e) => -- RPLACD(mmtail,(first mmtail,: rest mmtail)) -- RPLACA(mmtail,entry) -- entry := nil -- return modemapList -- if entry then (:modemapList,entry) else modemapList -isSuperDomain(domainForm,domainForm',e) == - isSubset(domainForm',domainForm,e) => true - --regard $ as a subdomain of Rep, only if using old style Rep - domainForm='Rep and domainForm'="$" => $useRepresentationHack - LASSOC(opOf domainForm',get(domainForm,"SubDomain",e)) - --substituteForRep(entry is [[mc,:sig],:.],curModemapList) == -- --change 'Rep to "$" unless the resulting signature is already in $ -- member(entry':= substitute("$",'Rep,entry),curModemapList) => @@ -232,14 +226,13 @@ isSuperDomain(domainForm,domainForm',e) == addNewDomain(domain,e) == augModemapsFromDomain(domain,domain,e) - + augModemapsFromDomain(name,functorForm,e) == member(KAR name or name,$DummyFunctorNames) => e name=$Category or isCategoryForm(name,e) => e member(name,curDomainsInScope:= getDomainsInScope e) => e - if u:= getSuperDomainFromDB opOf functorForm then - e:= addNewDomain(first u,e) - --need code to handle parameterized SuperDomains + if super := superType functorForm then + e := addNewDomain(super,e) if innerDom:= listOrVectorElementMode name then e:= addDomain(innerDom,e) if name is ["Union",:dl] then for d in stripUnionTags dl repeat e:= addDomain(d,e) diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index dcb5ecbe..49713af5 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -784,7 +784,7 @@ NRTputInHead bod == NRTputInTail x == for y in tails x repeat atom (u := first y) => - EQ(u,'$) or LASSOC(u,$devaluateList) => nil + u='$ or LASSOC(u,$devaluateList) => nil k:= NRTassocIndex u => atom u => RPLACA(y,[$elt,'_$,k]) -- u atomic means that the slot will always contain a vector diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot index fa3f742c..5ac53649 100644 --- a/src/interp/nrunfast.boot +++ b/src/interp/nrunfast.boot @@ -202,7 +202,7 @@ newLookupInTable(op,sig,dollar,[domain,opvec],flag) == nil slot := domain.loc null atom slot => - EQ(QCAR slot,'newGoGet) => someMatch:=true + QCAR slot='newGoGet => someMatch:=true --treat as if operation were not there --if EQ(QCAR slot,'newGoGet) then -- UNWIND_-PROTECT --break infinite recursion diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot index d2d5d9a5..944606f1 100644 --- a/src/interp/nrungo.boot +++ b/src/interp/nrungo.boot @@ -288,7 +288,7 @@ compareSigEqual(s,t,dollar,domain) == EQUAL(s,t) => true ATOM t => u := - EQ(t,'$) => dollar + t='$ => dollar isSharpVar t => VECP domain => ELT(rest domain.0,POSN1(t,$FormalMapVariableList)) ELT(rest domain,POSN1(t,$FormalMapVariableList)) @@ -297,7 +297,7 @@ compareSigEqual(s,t,dollar,domain) == s = '$ => compareSigEqual(dollar,u,dollar,domain) u => compareSigEqual(s,u,dollar,domain) EQUAL(s,u) - EQ(s,'$) => compareSigEqual(dollar,t,dollar,domain) + s='$ => compareSigEqual(dollar,t,dollar,domain) ATOM s => nil #s ^= #t => nil match := true diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot index d3fd3de2..39b52bc8 100644 --- a/src/interp/nrunopt.boot +++ b/src/interp/nrunopt.boot @@ -306,7 +306,7 @@ transHasCode x == atom x => x op := QCAR x MEMQ(op,'(HasCategory HasAttribute)) => x - EQ(op,'has) => compHasFormat x + op='has => compHasFormat x [transHasCode y for y in x] mungeAddGensyms(u,gal) == diff --git a/src/interp/postpar.boot b/src/interp/postpar.boot index 80bac6d4..7a5ae403 100644 --- a/src/interp/postpar.boot +++ b/src/interp/postpar.boot @@ -181,7 +181,7 @@ postAtom: %Atom -> %ParseForm postAtom x == x=0 => $Zero x=1 => $One - EQ(x,'T) => "T$" -- rename T in spad code to T$ + x='T => "T$" -- rename T in spad code to T$ IDENTP x and niladicConstructorFromDB x => [x] x="," => "%Comma" x = "^" => "**" -- always use `**' internally for exponentiation diff --git a/src/interp/property.lisp b/src/interp/property.lisp index ebf97157..62e93bf3 100644 --- a/src/interp/property.lisp +++ b/src/interp/property.lisp @@ -1,6 +1,6 @@ ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. -;; Copyright (C) 2007-2008, Gabriel Dos Reis. +;; Copyright (C) 2007-2009, Gabriel Dos Reis. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without @@ -140,23 +140,6 @@ (|PrimitiveSymbol| . (IDENTP |#1|)) )) (MAKEPROP (CAR X) '|BasicPredicate| (CDR X))) -(MAKEPROP '|Integer| '|Subsets| - '((|PositiveInteger| . (|>| * 0)) - (|NonNegativeInteger| . (|>=| * 0)) - (|NegativeInteger| . (|<| * 0)) - (|NonPositiveInteger| . (|<=| * 0)) - (|NonZeroInteger| . (^= * 0)) - (|SingleInteger| . (SMINTP *)) - )) - -(MAKEPROP '|NonNegativeInteger| '|Subsets| '( - (|PositiveInteger| . (|>| * 0)) - )) - -(MAKEPROP '|NonPositiveInteger| '|Subsets| '( - (|NegativeInteger| . (|<| * 0)) - )) - (FLAG '(|Union| |Record| |Enumration| |Mapping| |Enumeration|) 'FUNCTOR) (FLAG '(* + AND OR PROGN) 'NARY) diff --git a/src/interp/ptrees.boot b/src/interp/ptrees.boot index 3f867a1d..e8ff9ee6 100644 --- a/src/interp/ptrees.boot +++ b/src/interp/ptrees.boot @@ -126,8 +126,8 @@ pfInfApplication(op,left,right)== pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) pfCheckInfop right => pfWrong(pfDocument ['"infop as argument to infop"],pfListOf []) - EQ(pfIdSymbol op,"and")=> pfAnd (left,right) - EQ(pfIdSymbol op, "or")=> pfOr (left,right) + pfIdSymbol op = "and" => pfAnd (left,right) + pfIdSymbol op = "or" => pfOr (left,right) pfApplication(op,pfTuple pfListOf [left,right]) pfCheckInfop form== false diff --git a/src/interp/scan.boot b/src/interp/scan.boot index 674fe05e..eff296bf 100644 --- a/src/interp/scan.boot +++ b/src/interp/scan.boot @@ -448,7 +448,7 @@ scanPunct()== scanKeyTr sss scanKeyTr w== - if EQ(keyword w,"DOT") + if keyword w = "DOT" then if $floatok then scanPossFloat(w) else lfkey w diff --git a/src/interp/serror.boot b/src/interp/serror.boot index 1b3ead5c..59318cbd 100644 --- a/src/interp/serror.boot +++ b/src/interp/serror.boot @@ -61,7 +61,7 @@ syIgnoredFromTo(pos1, pos2) == npTrapForm: %Thing -> %Thing npTrapForm(x)== a:=pfSourceStok x - EQ(a,'NoToken)=> + a='NoToken => syGeneralErrorHere() THROW("TRAPPOINT","TRAPPED") ncSoftError(tokPosn a, 'S2CY0002, []) diff --git a/src/interp/sys-constants.boot b/src/interp/sys-constants.boot index fc1543e8..e3372db5 100644 --- a/src/interp/sys-constants.boot +++ b/src/interp/sys-constants.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -293,6 +293,10 @@ $TriangleVariableList == t_#31 t_#32 t_#33 t_#34 t_#35 t_#36 t_#37 t_#38 t_#39 t_#40 t_#41 t_#42 t_#43 t_#44 t_#45 t_#46 t_#47 t_#48 t_#49 t_#50) + +$AtVariables == + [INTERN strconc('"@",WRITE_-TO_-STRING i) for i in 1..50] + ++ List of basic predicates the system has a built-in optimization ++ support for. $BasicPredicates == @@ -371,18 +375,10 @@ $Integer == '(Integer) -++ The NegativeInteger domain constructor form -$NegativeInteger == - '(NegativeInteger) - ++ The NonNegativeInteger domain constructor form $NonNegativeInteger == '(NonNegativeInteger) -++ The NonPositiveInteger domain constructor form -$NonPositiveInteger == - '(NonPositiveInteger) - ++ The PositiveInteger domain constructor form $PositiveInteger == '(PositiveInteger) @@ -510,8 +506,7 @@ $StringCategory == ++ List of category constructors that do not have entries in the ++ constructor database. So, they are mostly recognized by their names. $CategoryNames == - '(Category _ - CATEGORY _ + '(CATEGORY _ RecordCategory _ Join _ EnumerationCategory _ diff --git a/src/interp/types.boot b/src/interp/types.boot index 219b8d18..505fbc30 100644 --- a/src/interp/types.boot +++ b/src/interp/types.boot @@ -1,4 +1,4 @@ --- Copyright (C) 2007-2008 Gabriel Dos Reis +-- Copyright (C) 2007-2009 Gabriel Dos Reis -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -124,7 +124,9 @@ namespace BOOT %Maybe a <=> null or a --% Data structures for the compiler +%Constructor <=> %Symbol -- constructor %Form <=> %Number or %Symbol or %String or cons -- input syntax form +%Instantiation <=> cons(%Constructor,%Form) -- constructor instance %Env <=> %List -- compiling env %Mode <=> %Symbol or %String or %List -- type of forms %Code <=> %Form -- generated code diff --git a/src/interp/wi1.boot b/src/interp/wi1.boot index 65ad705c..54f9f744 100644 --- a/src/interp/wi1.boot +++ b/src/interp/wi1.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -564,7 +564,7 @@ setqSingle(id,val,m,E) == (trialT and coerce(trialT,m'')) or eval or return nil where eval() == T:= comp(val,m'',E) => T - not get(id,"mode",E) and m'' ^= (maxm'':=maxSuperType(m'',E)) and + not get(id,"mode",E) and m'' ^= (maxm'':=maximalSuperType m'') and (T:=comp(val,maxm'',E)) => T (T:= comp(val,$EmptyMode,E)) and getmode(T.mode,E) => assignError(val,T.mode,id,m'') @@ -837,14 +837,11 @@ coerceSubset(T := [x,m,e],m') == m' = (r := get(x,'range,e)) or isSubset(r,m',e) => [x,r,e] nil -- pp [m, m'] - isSubset(m,m',e) or m="Rep" and m'="$" => [x,m',e] - m is ['SubDomain,=m',:.] => [x,m',e] - (pred:= LASSOC(opOf m',get(opOf m,'SubDomain,e))) and INTEGERP x and + isSubset(m,m',e) => [x,m',e] + -- if m is a type variable, we can't know. + (pred:= isSubset(m',m,e)) and INTEGERP x and -- obviously this is temporary eval substitute(x,"#1",pred) => [x,m',e] - (pred:= isSubset(m',maxSuperType(m,e),e)) and INTEGERP x -- again temporary - and eval substitute(x,"*",pred) => - [x,m',e] nil coerceRep(T,m) == @@ -925,7 +922,7 @@ compCoerce1(x,m',e) == T':= coerceByModemap(T,m') => T' pred:=isSubset(m',T.mode,e) => gg:=GENSYM() - pred:= substitute(gg,"*",pred) + pred:= substitute(gg,"#1",pred) code:= ['PROG1,["%LET",gg,T.expr], ['check_-subtype,pred,MKQ m',gg]] [code,m',T.env] diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot index 613a2ebf..a7c951ca 100644 --- a/src/interp/wi2.boot +++ b/src/interp/wi2.boot @@ -1,6 +1,6 @@ -- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. --- Copyright (C) 2007-2008, Gabriel Dos Reis. +-- Copyright (C) 2007-2009, Gabriel Dos Reis. -- All rights reserved. -- -- Redistribution and use in source and binary forms, with or without @@ -905,7 +905,7 @@ smallIntegerStep(it,index,start,inc,optFinal,e) == -----> assume that optFinal is $SmallInteger T := comp(final,$EmptyMode,inc'.env) or return nil final' := T - maxSuperType(T.mode,e) ^= $Integer => return nil + maximalSuperType T.mode ^= $Integer => return nil givenRange := T.mode indexmode:= $SmallInteger [.,.,e]:= compMakeDeclaration([":",index,indexmode],$EmptyMode, |