aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rwxr-xr-xconfigure18
-rw-r--r--configure.ac2
-rw-r--r--configure.ac.pamphlet2
-rw-r--r--src/ChangeLog18
-rw-r--r--src/boot/ast.boot17
-rw-r--r--src/boot/parser.boot17
-rw-r--r--src/boot/pile.boot2
-rw-r--r--src/boot/strap/ast.clisp32
-rw-r--r--src/boot/strap/parser.clisp12
-rw-r--r--src/boot/strap/tokens.clisp6
-rw-r--r--src/boot/tokens.boot1
-rw-r--r--src/interp/as.boot2
-rw-r--r--src/interp/ax.boot2
-rw-r--r--src/interp/br-con.boot2
-rw-r--r--src/interp/br-op1.boot2
-rw-r--r--src/interp/br-op2.boot2
-rw-r--r--src/interp/cattable.boot20
-rw-r--r--src/interp/database.boot2
-rw-r--r--src/interp/define.boot4
-rw-r--r--src/interp/functor.boot6
-rw-r--r--src/interp/i-funsel.boot26
-rw-r--r--src/interp/interop.boot2
-rw-r--r--src/interp/nruncomp.boot2
-rw-r--r--src/interp/nrunfast.boot2
-rw-r--r--src/interp/nrungo.boot2
-rw-r--r--src/interp/nrunopt.boot6
-rw-r--r--src/interp/wi2.boot2
27 files changed, 123 insertions, 88 deletions
diff --git a/configure b/configure
index 36bcf02a..64ab645f 100755
--- a/configure
+++ b/configure
@@ -1,6 +1,6 @@
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2009-09-16.
+# Generated by GNU Autoconf 2.63 for OpenAxiom 1.4.0-2009-09-19.
#
# Report bugs to <open-axiom-bugs@lists.sf.net>.
#
@@ -745,8 +745,8 @@ SHELL=${CONFIG_SHELL-/bin/sh}
# Identity of this package.
PACKAGE_NAME='OpenAxiom'
PACKAGE_TARNAME='openaxiom'
-PACKAGE_VERSION='1.4.0-2009-09-16'
-PACKAGE_STRING='OpenAxiom 1.4.0-2009-09-16'
+PACKAGE_VERSION='1.4.0-2009-09-19'
+PACKAGE_STRING='OpenAxiom 1.4.0-2009-09-19'
PACKAGE_BUGREPORT='open-axiom-bugs@lists.sf.net'
ac_unique_file="src/Makefile.pamphlet"
@@ -1501,7 +1501,7 @@ if test "$ac_init_help" = "long"; then
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures OpenAxiom 1.4.0-2009-09-16 to adapt to many kinds of systems.
+\`configure' configures OpenAxiom 1.4.0-2009-09-19 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
@@ -1571,7 +1571,7 @@ fi
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2009-09-16:";;
+ short | recursive ) echo "Configuration of OpenAxiom 1.4.0-2009-09-19:";;
esac
cat <<\_ACEOF
@@ -1674,7 +1674,7 @@ fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-OpenAxiom configure 1.4.0-2009-09-16
+OpenAxiom configure 1.4.0-2009-09-19
generated by GNU Autoconf 2.63
Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
@@ -1688,7 +1688,7 @@ cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by OpenAxiom $as_me 1.4.0-2009-09-16, which was
+It was created by OpenAxiom $as_me 1.4.0-2009-09-19, which was
generated by GNU Autoconf 2.63. Invocation command line was
$ $0 $@
@@ -17089,7 +17089,7 @@ exec 6>&1
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by OpenAxiom $as_me 1.4.0-2009-09-16, which was
+This file was extended by OpenAxiom $as_me 1.4.0-2009-09-19, which was
generated by GNU Autoconf 2.63. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
@@ -17152,7 +17152,7 @@ Report bugs to <bug-autoconf@gnu.org>."
_ACEOF
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_version="\\
-OpenAxiom config.status 1.4.0-2009-09-16
+OpenAxiom config.status 1.4.0-2009-09-19
configured by $0, generated by GNU Autoconf 2.63,
with options \\"`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`\\"
diff --git a/configure.ac b/configure.ac
index c5440b4d..de64ea5d 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,6 +1,6 @@
sinclude(config/open-axiom.m4)
sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.4.0-2009-09-16],
+AC_INIT([OpenAxiom], [1.4.0-2009-09-19],
[open-axiom-bugs@lists.sf.net])
AC_CONFIG_AUX_DIR(config)
diff --git a/configure.ac.pamphlet b/configure.ac.pamphlet
index 5ed5c590..8147cf53 100644
--- a/configure.ac.pamphlet
+++ b/configure.ac.pamphlet
@@ -1160,7 +1160,7 @@ information:
<<Autoconf init>>=
sinclude(config/open-axiom.m4)
sinclude(config/aclocal.m4)
-AC_INIT([OpenAxiom], [1.4.0-2009-09-16],
+AC_INIT([OpenAxiom], [1.4.0-2009-09-19],
[open-axiom-bugs@lists.sf.net])
@
diff --git a/src/ChangeLog b/src/ChangeLog
index 6df870d1..06a75817 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,21 @@
+2009-09-19 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * boot/tokens.boot: "has" is not a keyword.
+ * boot/ast.boot (bfHas): New.
+ (bfReduce): Use "has" instead "has".
+ (bfReduceCollect): Likewise.
+ (bfReName): Likewise.
+ (bfElt): Likewise.
+ (bfSetelt): Likewise.
+ * boot/parser.boot (bpSexpKey): Likewise.
+ (bpPrefixOperator): Likewise.
+ (bpInfixOperator): Likewise.
+ (bpThetaName): Likewise.
+ (bpIs): Parse "has" expressions.
+ * boot/pile.boot (shoePileCoagulate): Likewise.
+ * interp/: Fix unquoted use of "has".
+ * interp/interop.boot (has): Remove.
+
2009-09-16 Kosta Oikonomou <ko@research.att.com>
Gabriel Dos Reis <gdr@cs.tamu.edu>
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index c83e95c6..0e7b50a8 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -335,7 +335,7 @@ bfReduce(op,y)==
op is ["QUOTE",:.] => second op
op
op := bfReName a
- init := GET(a,"SHOETHETA") or GET(op,"SHOETHETA")
+ init := a has SHOETHETA or op has SHOETHETA
g := bfGenSymbol()
g1 := bfGenSymbol()
body := ['SETQ,g,[op,g,g1]]
@@ -357,7 +357,7 @@ bfReduceCollect(op,y)==
op is ["QUOTE",:.] => second op
op
op := bfReName a
- init := GET(a, "SHOETHETA") or GET(op,"SHOETHETA")
+ init := a has SHOETHETA or op has SHOETHETA
bfOpReduce(op,init,body,itl)
bfReduce(op,bfTupleConstruct (y.1))
@@ -666,14 +666,19 @@ bfIS1(lhs,rhs) ==
bfAND [rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),'T]]
bpSpecificErrorHere '"bad IS code is generated"
bpTrap()
-
+
+
+bfHas(expr,prop) ==
+ IDENTP prop => ["GET",expr,["QUOTE",prop]]
+ bpSpecificErrorAtToken('"expected identifier as property name")
+
bfApplication(bfop, bfarg) ==
bfTupleP bfarg => [bfop,:rest bfarg]
[bfop,bfarg]
-- returns the meaning of x in the appropriate Boot dialect.
bfReName x==
- a := GET(x,"SHOERENAME") => first a
+ a := x has SHOERENAME => first a
x
bfInfApplication(op,left,right)==
@@ -932,14 +937,14 @@ bfSetelt(e,l,r)==
bfSetelt(bfElt(e,first l),rest l,r)
bfElt(expr,sel)==
- y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
+ y:=SYMBOLP sel and sel has SHOESELFUNCTION
y =>
INTEGERP y => ["ELT",expr,y]
[y,expr]
["ELT",expr,sel]
defSETELT(var,sel,expr)==
- y := SYMBOLP sel and GET(sel,"SHOESELFUNCTION")
+ y := SYMBOLP sel and sel has SHOESELFUNCTION
y =>
INTEGERP y => ["SETF",["ELT",var,y],expr]
["SETF",[y,var],expr]
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index fa74a739..036f6375 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -521,7 +521,7 @@ bpExceptions()==
bpSexpKey()==
$stok is ["KEY",:.] and not bpExceptions()=>
- a:=GET($ttok,"SHOEINF")
+ a := $ttok has SHOEINF
null a=> bpPush $ttok and bpNext()
bpPush a and bpNext()
false
@@ -561,11 +561,11 @@ bpDot()== bpEqKey "DOT" and bpPush bfDot ()
bpPrefixOperator()==
$stok is ["KEY",:.] and
- GET($ttok,"SHOEPRE") and bpPushId() and bpNext()
+ $ttok has SHOEPRE and bpPushId() and bpNext()
bpInfixOperator()==
$stok is ["KEY",:.] and
- GET($ttok,"SHOEINF") and bpPushId() and bpNext()
+ $ttok has SHOEINF and bpPushId() and bpNext()
bpSelector()==
bpEqKey "DOT" and (bpPrimary()
@@ -626,7 +626,7 @@ bpString()==
bpPush(["QUOTE",INTERN $ttok]) and bpNext()
bpThetaName() ==
- $stok is ["ID",:.] and GET($ttok,"SHOETHETA") =>
+ $stok is ["ID",:.] and $ttok has SHOETHETA =>
bpPushId()
bpNext()
false
@@ -656,9 +656,12 @@ bpMinus()==
bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus)
bpIs()==
- bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap())
- and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1())
- or true)
+ bpArith() and
+ bpInfKey '(IS ISNT) and (bpPattern() or bpTrap()) =>
+ bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1())
+ bpEqKey "HAS" and (bpApplication() or bpTrap()) =>
+ bpPush bfHas(bpPop2(), bpPop1())
+ true
bpBracketConstruct(f)==
bpBracket f and bpPush bfConstruct bpPop1()
diff --git a/src/boot/pile.boot b/src/boot/pile.boot
index 52bebdea..9f9fcd96 100644
--- a/src/boot/pile.boot
+++ b/src/boot/pile.boot
@@ -109,7 +109,7 @@ shoePileCoagulate(a,b)==
d := second a
e := shoeTokPart d
d is ["KEY",:.] and
- (GET(e,"SHOEINF") or e = "COMMA" or e = "SEMICOLON") =>
+ (e has SHOEINF or e = "COMMA" or e = "SEMICOLON") =>
shoePileCoagulate(dqAppend(a,c),rest b)
cons(a,shoePileCoagulate(c,rest b))
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 0c52e92b..615c3f0d 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -1055,6 +1055,12 @@
(T (|bpSpecificErrorHere| "bad IS code is generated")
(|bpTrap|))))))
+(DEFUN |bfHas| (|expr| |prop|)
+ (COND
+ ((IDENTP |prop|) (LIST 'GET |expr| (LIST 'QUOTE |prop|)))
+ (T (|bpSpecificErrorAtToken|
+ "expected identifier as property name"))))
+
(DEFUN |bfApplication| (|bfop| |bfarg|)
(COND
((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|)))
@@ -2050,9 +2056,9 @@
(LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|))))))
(DEFCONSTANT |$NativeSimpleDataTypes|
- '(|char| |byte| |int| |int8| |uint8| |int16| |uint16| |int32|
- |uint32| |int64| |uint64| |float| |float32| |double|
- |float64|))
+ '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16|
+ |int32| |uint32| |int64| |uint64| |float| |float32|
+ |double| |float64|))
(DEFCONSTANT |$NativeSimpleReturnTypes|
(APPEND |$NativeSimpleDataTypes| '(|void| |string|)))
@@ -2148,6 +2154,14 @@
(T (|unknownNativeTypeError| |t|))))
((EQ |t| '|float32|) (|nativeType| '|float|))
((EQ |t| '|float64|) (|nativeType| '|double|))
+ ((EQ |t| '|pointer|)
+ (COND
+ ((|%hasFeature| :GCL) '|fixnum|)
+ ((|%hasFeature| :ECL) :POINTER-VOID)
+ ((|%hasFeature| :SBCL)
+ (LIST '* (|bfColonColon| 'SB-ALIEN 'VOID)))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
+ (T (|unknownNativeTypeError| |t|))))
(T (|unknownNativeTypeError| |t|))))
((EQ (CAR |t|) '|buffer|)
(COND
@@ -2156,13 +2170,7 @@
((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|))))
((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
(T (|unknownNativeTypeError| |t|))))
- ((EQ (CAR |t|) '|buffer|)
- (COND
- ((|%hasFeature| :GCL) '|fixnum|)
- ((|%hasFeature| :ECL) :OBJECT)
- ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|))))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
- (T (|unknownNativeTypeError| |t|))))
+ ((EQ (CAR |t|) '|pointer|) (|nativeType| '|pointer|))
(T (|unknownNativeTypeError| |t|))))))
(DEFUN |nativeReturnType| (|t|)
@@ -2188,7 +2196,7 @@
"missing modifier for argument type for a native function"))
((NOT (MEMBER |c| '(|buffer| |pointer|)))
(|coreError|
- "expect 'buffer' or 'pointer' type instance"))
+ "expected 'buffer' or 'pointer' type instance"))
((NOT (MEMBER |t'| |$NativeSimpleDataTypes|))
(|coreError| "expected simple native data type"))
(T (|nativeType| (CADR |t|)))))))))
@@ -2470,7 +2478,7 @@
((EQ |y| '|double|) "->vector.self.df")
(T (|coreError|
"unknown argument to buffer type constructor"))))
- ((EQ |c| '|pointer|) '||)
+ ((EQ |c| '|pointer|) "")
(T (|coreError| "unknown type constructor"))))))))
(DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 716b86d1..5683aef5 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -700,11 +700,13 @@
(DEFUN |bpIs| ()
(AND (|bpArith|)
- (OR (AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|))
- (|bpPush|
- (|bfISApplication| (|bpPop2|) (|bpPop2|)
- (|bpPop1|))))
- T)))
+ (COND
+ ((AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|)))
+ (|bpPush|
+ (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))
+ ((AND (|bpEqKey| 'HAS) (OR (|bpApplication|) (|bpTrap|)))
+ (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|))))
+ (T T))))
(DEFUN |bpBracketConstruct| (|f|)
(AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|)))))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index 9deef054..ce8f5cac 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -8,9 +8,9 @@
(DEFCONSTANT |shoeKeyWords|
(LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
(LIST "catch" 'CATCH) (LIST "cross" 'CROSS)
- (LIST "else" 'ELSE) (LIST "for" 'FOR) (LIST "if" 'IF)
- (LIST "import" 'IMPORT) (LIST "in" 'IN) (LIST "is" 'IS)
- (LIST "isnt" 'ISNT) (LIST "module" 'MODULE)
+ (LIST "else" 'ELSE) (LIST "for" 'FOR) (LIST "has" 'HAS)
+ (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN)
+ (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "module" 'MODULE)
(LIST "namespace" 'NAMESPACE) (LIST "of" 'OF) (LIST "or" 'OR)
(LIST "repeat" 'REPEAT) (LIST "return" 'RETURN)
(LIST "structure" 'STRUCTURE) (LIST "then" 'THEN)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 1116654d..39a40df2 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -45,6 +45,7 @@ shoeKeyWords == [ _
['"cross","CROSS"] , _
['"else", "ELSE"] , _
['"for", "FOR"] , _
+ ['"has", "HAS"] , _
['"if", "IF"], _
['"import", "IMPORT"], _
['"in", "IN" ], _
diff --git a/src/interp/as.boot b/src/interp/as.boot
index 15242412..68e0b01f 100644
--- a/src/interp/as.boot
+++ b/src/interp/as.boot
@@ -1012,7 +1012,7 @@ asyCattranOp1(op, item, predlist) ==
asyPredTran p == asyPredTran1 asyJoinPart p
asyPredTran1 p ==
- p is ['Has,x,y] => ['has,x, simpCattran y]
+ p is ['Has,x,y] => ["has",x, simpCattran y]
p is ['Test, q] => asyPredTran1 q
p is [op,:r] and MEMQ(op,'(AND OR NOT)) =>
[op,:[asyPredTran1 q for q in r]]
diff --git a/src/interp/ax.boot b/src/interp/ax.boot
index 7ddee7e8..f70ad4bc 100644
--- a/src/interp/ax.boot
+++ b/src/interp/ax.boot
@@ -265,7 +265,7 @@ axFormatPred pred ==
atom pred => pred
[op,:args] := pred
op = 'IF => axFormatOp pred
- op = 'has =>
+ op = "has" =>
[name,type] := args
if name = '$ then name := '%
else name := axFormatOp name
diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot
index d1c1911c..d8499ed6 100644
--- a/src/interp/br-con.boot
+++ b/src/interp/br-con.boot
@@ -273,7 +273,7 @@ domainDescendantsOf(conform,domform) == main where --called by kargPage
for x in r repeat
x isnt [op1,:.] and MEMQ(op1,'(ATTRIBUTE SIGNATURE)) => systemError x
alist := [[item,:npred] for [item,:pred] in alist |
- (pred1 := simpHasPred ['has,item,x]) and (npred := quickAnd(pred1,pred))]
+ (pred1 := simpHasPred ["has",item,x]) and (npred := quickAnd(pred1,pred))]
alist
--=======================================================================
diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot
index c5d51419..9348194d 100644
--- a/src/interp/br-op1.boot
+++ b/src/interp/br-op1.boot
@@ -970,7 +970,7 @@ evalDomainOpPred(dom,pred) == process(dom,pred) where
MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]]
MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]]
MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)]
- op = 'has =>
+ op = "has" =>
[arg,p] := argl
p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a]
['HasCategory,arg,convertCatArg p]
diff --git a/src/interp/br-op2.boot b/src/interp/br-op2.boot
index 2171a7ae..c89e727d 100644
--- a/src/interp/br-op2.boot
+++ b/src/interp/br-op2.boot
@@ -609,7 +609,7 @@ getSigSubst(u, pl, vl, fl) ==
key = 'isDomain => getSigSubst(r, pl, [v, :vl], [f, :fl])
key = 'ofCategory => getSigSubst(r, pl, ['D, :vl], [f, :fl])
key = 'ofType => getSigSubst(r, pl, vl, fl)
- key = 'has => getSigSubst(r, [item, :pl], vl, fl)
+ key = "has" => getSigSubst(r, [item, :pl], vl, fl)
key = 'not => getSigSubst(r, [item, :pl], vl, fl)
systemError()
[pl, vl, fl]
diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot
index 25c909b7..2c8129b8 100644
--- a/src/interp/cattable.boot
+++ b/src/interp/cattable.boot
@@ -96,19 +96,19 @@ simpHasPred(pred,:options) == main where
simp pred ==
pred is [op,:r] =>
op = "has" => simpHas(pred,first r,first rest r)
- op = 'HasCategory => simp ['has,CAR r,simpDevaluate CADR r]
+ op = 'HasCategory => simp ["has",CAR r,simpDevaluate CADR r]
op = 'HasSignature =>
[op,sig] := simpDevaluate CADR r
["has",CAR r,['SIGNATURE,op,sig]]
op = 'HasAttribute =>
- form := ['has,a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]]
+ form := ["has",a := CAR r,['ATTRIBUTE,b := simpDevaluate CADR r]]
simpHasAttribute(form,a,b)
MEMQ(op,'(AND OR NOT)) =>
null (u := MKPF([simp p for p in r],op)) => nil
u is '(QUOTE T) => true
simpBool u
op = 'hasArgs => ($hasArgs => $hasArgs = r; pred)
- null r and opOf op = 'has => simp first pred
+ null r and opOf op = "has" => simp first pred
pred is '(QUOTE T) => true
op1 := LASSOC(op,'((and . AND)(or . OR)(not . NOT))) => simp [op1,:r]
simp first pred --REMOVE THIS HACK !!!!
@@ -123,7 +123,7 @@ simpHasPred(pred,:options) == main where
npred := eval pred
IDENTP npred or null hasIdent npred => npred
pred
- eval (pred := ['has,d,cat]) ==
+ eval (pred := ["has",d,cat]) ==
x := hasCat(CAR d,CAR cat)
y := CDR cat =>
npred := or/[p for [args,:p] in x | y = args] => simp npred
@@ -233,7 +233,7 @@ encodeUnion(id,new:=[a,:b],alist) ==
moreGeneralCategoryPredicate(id,new,old) ==
old = 'T or new = 'T => 'T
- old is ['has,a,b] and new is ['has,=a,c] =>
+ old is ["has",a,b] and new is ["has",=a,c] =>
tempExtendsCat(b,c) => new
tempExtendsCat(c,b) => old
['OR,old,new]
@@ -246,10 +246,10 @@ mkCategoryOr(new,old) ==
simpCategoryOr(new,l) ==
newExtendsAnOld:= false
anOldExtendsNew:= false
- ['has,a,b] := new
+ ["has",a,b] := new
newList:= nil
for pred in l repeat
- pred is ['has,=a,c] =>
+ pred is ["has",=a,c] =>
tempExtendsCat(c,b) => anOldExtendsNew:= true
if tempExtendsCat(b,c) then newExtendsAnOld:= true
newList:= [pred,:newList]
@@ -331,7 +331,7 @@ simpOrUnion1(x,l) ==
[first l,:simpOrUnion1(x,rest l)]
mergeOr(x,y) ==
- x is ["has",a,b] and y is ['has,=a,c] =>
+ x is ["has",a,b] and y is ["has",=a,c] =>
testExtend(b,c) => y
testExtend(c,b) => x
nil
@@ -356,12 +356,12 @@ getConstrCat(x) ==
makeCatPred(zz, cats, thePred) ==
- if zz is ['IF,curPred := ['has,z1,z2],ats,.] then
+ if zz is ['IF,curPred := ["has",z1,z2],ats,.] then
ats := if ats is ['PROGN,:atl] then atl else [ats]
for at in ats repeat
if at is ['ATTRIBUTE,z3] and not atom z3 and
constructor? CAR z3 then
- cats:= CONS(['IF,quickAnd(['has,z1,z2], thePred),z3,'%noBranch],cats)
+ cats:= CONS(['IF,quickAnd(["has",z1,z2], thePred),z3,'%noBranch],cats)
at is ['IF, pred, :.] =>
cats := makeCatPred(at, cats, curPred)
cats
diff --git a/src/interp/database.boot b/src/interp/database.boot
index 1f4b8c0f..622f1051 100644
--- a/src/interp/database.boot
+++ b/src/interp/database.boot
@@ -395,7 +395,7 @@ isDomainSubst u == main where
signatureTran pred ==
atom pred => pred
- pred is ['has,D,catForm] and isCategoryForm(catForm,$e) =>
+ pred is ["has",D,catForm] and isCategoryForm(catForm,$e) =>
['ofCategory,D,catForm]
[signatureTran p for p in pred]
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 0780dc52..b74fc64a 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -417,7 +417,7 @@ makeCategoryPredicates(form,u) ==
fn(u,pl) ==
u is ['Join,:.,a] => fn(a,pl)
u is ["IF",p,:x] => fnl(x,insert(EQSUBSTLIST($mvl,$tvl,p),pl))
- u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl)
+ u is ["has",:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl)
u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl
atom u => pl
fnl(u,pl)
@@ -810,7 +810,7 @@ makeFunctorArgumentParameters(argl,sigl,target) ==
findExtrasP(a,x) ==
x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
- x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y]
+ x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
nil
nil
augmentSig(s,ss) ==
diff --git a/src/interp/functor.boot b/src/interp/functor.boot
index 18d412ec..3c97b449 100644
--- a/src/interp/functor.boot
+++ b/src/interp/functor.boot
@@ -368,7 +368,7 @@ sublisProp(subst,props) ==
--keep original CONS
cond is ['or,:x] =>
(or/[inspect(u,subst) for u in x] => [a,true,:l]; nil)
- cond is ['has,nam,b] and (val:= ASSQ(nam,subst)) =>
+ cond is ["has",nam,b] and (val:= ASSQ(nam,subst)) =>
ev:=
b is ['ATTRIBUTE,c] => HasAttribute(rest val,c)
b is ['SIGNATURE,c] => HasSignature(rest val,c)
@@ -764,7 +764,7 @@ CheckVector(vec,name,catvecListMaker) ==
makeMissingFunctionEntry(alist,i) ==
tran SUBLIS(alist,$MissingFunctionInfo.i) where
tran x ==
- x is ["HasCategory",a,["QUOTE",b]] => ['has,a,b]
+ x is ["HasCategory",a,["QUOTE",b]] => ["has",a,b]
x is [op,:l] and op in '(AND OR NOT) => [op,:[tran y for y in l]]
x
@@ -878,7 +878,7 @@ InvestigateConditions catvecListMaker ==
ICformat u ==
atom u => u
- u is ['has,:.] => compHasFormat u
+ u is ["has",:.] => compHasFormat u
u is ['AND,:l] or u is ['and,:l] =>
l:= REMDUP [ICformat v for [v,:l'] in tails l | not member(v,l')]
-- we could have duplicates after, even if not before
diff --git a/src/interp/i-funsel.boot b/src/interp/i-funsel.boot
index 9fcff10e..da2d49db 100644
--- a/src/interp/i-funsel.boot
+++ b/src/interp/i-funsel.boot
@@ -915,7 +915,7 @@ matchMmCond(cond) ==
and/[matchMmCond c for c in conds]
cond is ['OR,:conds] or cond is ['or,:conds] =>
or/[matchMmCond c for c in conds]
- cond is ['has,dom,x] =>
+ cond is ["has",dom,x] =>
hasCaty(dom,x,NIL) ~= 'failed
cond is ['not,cond1] => not matchMmCond cond1
keyedSystemError("S2GE0016",
@@ -1174,7 +1174,7 @@ evalMmStack(mmC) ==
mmC is ['ofCategory,pvar,cat] and cat is ['Join,:args] =>
evalMmStack CONS('AND,[['ofCategory,pvar,c] for c in args])
mmC is ['ofType,:.] => [NIL]
- mmC is ['has,pat,x] =>
+ mmC is ["has",pat,x] =>
MEMQ(x,'(ATTRIBUTE SIGNATURE)) =>
[[['ofCategory,pat,['CATEGORY,'unknown,x]]]]
[['ofCategory,pat,x]]
@@ -1189,7 +1189,7 @@ evalMmStackInner(mmC) ==
[['ofCategory, pvar, c] for c in args]
mmC is ['ofType,:.] => NIL
mmC is ['isAsConstant] => NIL
- mmC is ['has,pat,x] =>
+ mmC is ["has",pat,x] =>
MEMQ(x,'(ATTRIBUTE SIGNATURE)) =>
[['ofCategory,pat,['CATEGORY,'unknown,x]]]
[['ofCategory,pat,x]]
@@ -1495,12 +1495,12 @@ hasCaty(d,cat,SL) ==
if not (S1='failed) then S1:=
atom cond => S1
ncond := subCopy(cond, S)
- ncond is ['has, =d, =cat] => 'failed
+ ncond is ["has", =d, =cat] => 'failed
hasCaty1(ncond,S1)
S1
atom x => SL
ncond := subCopy(x, constructSubst d)
- ncond is ['has, =d, =cat] => 'failed
+ ncond is ["has", =d, =cat] => 'failed
hasCaty1(ncond, SL)
'failed
@@ -1523,20 +1523,20 @@ hasCaty1(cond,SL) ==
-- cond is either a (has a b) or an OR clause of such conditions
-- SL is augmented, if cond is true, otherwise the result is 'failed
$domPvar: local := NIL
- cond is ['has,a,b] => hasCate(a,b,SL)
+ cond is ["has",a,b] => hasCate(a,b,SL)
cond is ['AND,:args] =>
for x in args while not (S='failed) repeat S:=
- x is ['has,a,b] => hasCate(a,b, SL)
+ x is ["has",a,b] => hasCate(a,b, SL)
-- next line is for an obscure bug in the table
- x is [['has,a,b]] => hasCate(a,b, SL)
+ x is [["has",a,b]] => hasCate(a,b, SL)
--'failed
hasCaty1(x, SL)
S
cond is ['OR,:args] =>
for x in args until not (S='failed) repeat S:=
- x is ['has,a,b] => hasCate(a,b,copy SL)
+ x is ["has",a,b] => hasCate(a,b,copy SL)
-- next line is for an obscure bug in the table
- x is [['has,a,b]] => hasCate(a,b,copy SL)
+ x is [["has",a,b]] => hasCate(a,b,copy SL)
--'failed
hasCaty1(x, copy SL)
S
@@ -1559,7 +1559,7 @@ hasSigAnd(andCls, S0, SL) ==
for cls in andCls while not dead repeat
SA :=
atom cls => copy SL
- cls is ['has,a,b] =>
+ cls is ["has",a,b] =>
hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
keyedSystemError("S2GE0016",
['"hasSigAnd",'"unexpected condition for signature"])
@@ -1572,7 +1572,7 @@ hasSigOr(orCls, S0, SL) ==
for cls in orCls until found repeat
SA :=
atom cls => copy SL
- cls is ['has,a,b] =>
+ cls is ["has",a,b] =>
hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
cls is ['AND,:andCls] or cls is ['and,:andCls] =>
hasSigAnd(andCls, S0, SL)
@@ -1591,7 +1591,7 @@ hasSig(dom,foo,sig,SL) ==
for [x,.,cond,.] in CDR p until not (S='failed) repeat
S:=
atom cond => copy SL
- cond is ['has,a,b] =>
+ cond is ["has",a,b] =>
hasCate(subCopy(a,S0),subCopy(b,S0),copy SL)
cond is ['AND,:andCls] or cond is ['and,:andCls] =>
hasSigAnd(andCls, S0, SL)
diff --git a/src/interp/interop.boot b/src/interp/interop.boot
index 249f7b1b..e56e396a 100644
--- a/src/interp/interop.boot
+++ b/src/interp/interop.boot
@@ -589,8 +589,6 @@ getCatForm(catvec, index, domain) ==
HasSignature(domain,[op,sig]) ==
compiledLookup(op,sig,domain)
-has(domain,catform') == HasCategory(domain,catform')
-
HasCategory(domain,catform') ==
catform' is ['SIGNATURE,:f] => HasSignature(domain,f)
catform' is ['ATTRIBUTE,f] => HasAttribute(domain,f)
diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot
index 751bf073..7fd6aa3c 100644
--- a/src/interp/nruncomp.boot
+++ b/src/interp/nruncomp.boot
@@ -650,7 +650,7 @@ NRToptimizeHas u ==
a='HasCategory => LASSOC(u,$hasCategoryAlist) or
$hasCategoryAlist := [[u,:(y:=GENSYM())],:$hasCategoryAlist]
y
- a='has => NRToptimizeHas ['HasCategory,first b,MKQ first rest b]
+ a="has" => NRToptimizeHas ['HasCategory,first b,MKQ first rest b]
a = 'QUOTE => u
[NRToptimizeHas a,:NRToptimizeHas b]
u
diff --git a/src/interp/nrunfast.boot b/src/interp/nrunfast.boot
index 03429303..0a33b680 100644
--- a/src/interp/nrunfast.boot
+++ b/src/interp/nrunfast.boot
@@ -646,7 +646,7 @@ newHasTest(domform,catOrAtt) ==
evalCond x ==
ATOM x => x
[pred,:l] := x
- pred = 'has =>
+ pred = "has" =>
l is [ w1,['ATTRIBUTE,w2]] => newHasTest(w1,w2)
l is [ w1,['SIGNATURE,:w2]] => compiledLookup(CAR w2,CADR w2, eval mkEvalable w1)
newHasTest(first l ,first rest l)
diff --git a/src/interp/nrungo.boot b/src/interp/nrungo.boot
index 171dcdcf..d49177a8 100644
--- a/src/interp/nrungo.boot
+++ b/src/interp/nrungo.boot
@@ -252,7 +252,7 @@ lookupPred(pred,dollar,domain) ==
or/[lookupPred(p,dollar,domain) for p in pl]
pred is ['NOT,p] or pred is ['not,p] => not lookupPred(p,dollar,domain)
pred is ['is,dom1,dom2] => domainEqual(dom1,dom2)
- pred is ['has,a,b] =>
+ pred is ["has",a,b] =>
VECP a =>
keyedSystemError("S2GE0016",['"lookupPred",
'"vector as first argument to has"])
diff --git a/src/interp/nrunopt.boot b/src/interp/nrunopt.boot
index 62fb4935..401cf9a4 100644
--- a/src/interp/nrunopt.boot
+++ b/src/interp/nrunopt.boot
@@ -231,7 +231,7 @@ predicateBitIndexRemop p==
--transform attribute predicates taken out by removeAttributePredicates
p is [op,:argl] and op in '(AND and OR or NOT not) =>
simpBool makePrefixForm([predicateBitIndexRemop x for x in argl],op)
- p is ['has,'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist)
+ p is ["has",'$,['ATTRIBUTE,a]] => LASSOC(a,$NRTattributeAlist)
p
predicateBitRef x ==
@@ -291,7 +291,7 @@ removeAttributePredicates pl ==
fn p ==
p is [op,:argl] and op in '(AND and OR or NOT not) =>
makePrefixForm(fnl argl,op)
- p is ['has,'$,['ATTRIBUTE,a]] =>
+ p is ["has",'$,['ATTRIBUTE,a]] =>
sayBrightlyNT '"Predicate: "
PRINT p
sayBrightlyNT '" replaced by: "
@@ -303,7 +303,7 @@ transHasCode x ==
atom x => x
op := QCAR x
MEMQ(op,'(HasCategory HasAttribute)) => x
- op='has => compHasFormat x
+ op="has" => compHasFormat x
[transHasCode y for y in x]
mungeAddGensyms(u,gal) ==
diff --git a/src/interp/wi2.boot b/src/interp/wi2.boot
index ca28c739..fa3f48bc 100644
--- a/src/interp/wi2.boot
+++ b/src/interp/wi2.boot
@@ -236,7 +236,7 @@ makeFunctorArgumentParameters(argl,sigl,target) ==
findExtrasP(a,x) ==
x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l]
x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l]
- x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y]
+ x is ["has",=a,y] and y is ['SIGNATURE,:.] => [y]
nil
nil
augmentSig(s,ss) ==
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-28 19:15:05 +0000