* 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.

7 files changed, 53 insertions, 34 deletions

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" ], _