aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-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
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" ], _
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-05 00:42:44 +0000