aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2009-01-03 10:26:16 +0000
committerdos-reis <gdr@axiomatics.org>2009-01-03 10:26:16 +0000
commitad0d6445de436a1c7c04cfe14316d620cb9202b3 (patch)
tree2165a9a2446cc52a27bd6545359607e7dc376599 /src/interp
parent844be40b5b876fffd816f285f87711cca6ef3121 (diff)
downloadopen-axiom-ad0d6445de436a1c7c04cfe14316d620cb9202b3.tar.gz
2009-01-03 Gabriel Dos Reis <gdr@cs.tamu.edu>
* Makefile.pamphlet (AXIOM_SRC_TARGETS): Add all-databases. src/ChangeLog 2009-01-03 Gabriel Dos Reis <gdr@cs.tamu.edu> * lisp/core.lisp.in (|%algebraSystemIsComplete|): New. (|%basicSystemIsComplete|): Use it. * interp/wi1.boot (setqSingle): Use maximalSuperType. (coerceSubset): Simplify. (compCoerce1): Tidy. * interp/i-resolv.boot (resolveTCat): Use superType. * interp/lisplib.boot (findConstructorSlotNumber): Use isSubset. (sigsMatch): Likewise. (findDomainSlotNumber): Likewise. * interp/define.boot (compSubDomain1): Reject for complex subdomain predicate. Support paramterized subdomains. * interp/daase.lisp (interpOpen): Read superdomain slot. (getdatabase): Remove adhoc hardcoded superdomain info. Return superdomain info stored in database. (localnrlib): Read superdomain info. (write-interpdb): Write superdomain info. (database): Add superdomain slot. * interp/g-util.boot (superType): New. (maximalSuperType): Rework. Support parameterized subdomains. (noteSubDomainInfo): New. (isSubDomain): Rework. * interp/c-util.boot (isSubset): Rework. * interp/g-opt.boot (optEQ): Remove. * interp/g-cndata.boot (getImmediateSuperDomain): Remove. (maximalSuperType): Move to g-util.boot. * interp/types.boot (%Constructor): New type specifier. (%Instantiation): Likewise. * interp/compiler.boot (primitiveType): Don't return $NegativeInteger. (maxSuperType): Remove. (hasType): Use maximalSuperType. (satisfies): New. (coerceSubset): Use it. Simplify. * interp/wi2.boot (smallIntegerStep): Use maximalSuperType. * interp/sys-constants.boot ($AtVariables): New. ($NegativeInteger): Remove. ($NonPositiveInteger): Likewise. ($CategoryNames): Category is not a category. * interp/property.lisp: Remove Subsets property settings. * interp/i-coerce.boot (coerceSubDomain): Simplify. (coerceImmediateSubDomain): Remove. (getSubDomainPredicate): Simplify. * interp/category.boot (SourceLevelSubset): Use isSubDomain. (MachineLevelSubset): Likewise. * interp/modemap.boot (mergeModemap): Likewise. (isSuperDomain): Remove. (augModemapsFromDomain): Support parameterized subdomains. * interp/i-util.boot (isSubDomain): Move to g-util.boot. * Makefile.pamphlet (all-databases): New target. * interp/Makefile.pamphlet ($(AXIOMSYS)): Push :open-axiom-algebra-system onto *FEATURES*. * etc/Makefile.in (all-databases): New target.
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in2
-rw-r--r--src/interp/Makefile.pamphlet2
-rw-r--r--src/interp/c-doc.boot4
-rw-r--r--src/interp/c-util.boot25
-rw-r--r--src/interp/category.boot14
-rw-r--r--src/interp/clam.boot2
-rw-r--r--src/interp/compiler.boot33
-rw-r--r--src/interp/cparse.boot12
-rw-r--r--src/interp/daase.lisp48
-rw-r--r--src/interp/define.boot18
-rw-r--r--src/interp/g-cndata.boot9
-rw-r--r--src/interp/g-opt.boot10
-rw-r--r--src/interp/g-util.boot61
-rw-r--r--src/interp/i-analy.boot6
-rw-r--r--src/interp/i-coerce.boot33
-rw-r--r--src/interp/i-funsel.boot26
-rw-r--r--src/interp/i-output.boot34
-rw-r--r--src/interp/i-resolv.boot5
-rw-r--r--src/interp/i-spec2.boot6
-rw-r--r--src/interp/i-util.boot12
-rw-r--r--src/interp/interop.boot8
-rw-r--r--src/interp/lisplib.boot8
-rw-r--r--src/interp/modemap.boot25
-rw-r--r--src/interp/nruncomp.boot2
-rw-r--r--src/interp/nrunfast.boot2
-rw-r--r--src/interp/nrungo.boot4
-rw-r--r--src/interp/nrunopt.boot2
-rw-r--r--src/interp/postpar.boot2
-rw-r--r--src/interp/property.lisp19
-rw-r--r--src/interp/ptrees.boot4
-rw-r--r--src/interp/scan.boot2
-rw-r--r--src/interp/serror.boot2
-rw-r--r--src/interp/sys-constants.boot17
-rw-r--r--src/interp/types.boot4
-rw-r--r--src/interp/wi1.boot15
-rw-r--r--src/interp/wi2.boot4
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,