edwinb/Idris2-boot
1
1
Fork 0
mirror of https://github.com/edwinb/Idris2-boot.git synced 2024-11-27 00:38:13 +03:00
Code Issues Projects Releases Wiki Activity

Bitwise operators

Browse Source
This commit is contained in:
Edwin Brady 2020-01-31 10:47:34 +00:00
parent 854e39936e
commit e69c1529d9
12 changed files with 63 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Compiler/Scheme/Common.idr
View File

@ -88,6 +88,9 @@ schOp (Mod ty) [x, y] = op "remainder" [x, y]
schOp (Neg ty) [x] = op "-" [x]
schOp (ShiftL ty) [x, y] = op "blodwen-shl" [x, y]
schOp (ShiftR ty) [x, y] = op "blodwen-shr" [x, y]
schOp (BAnd ty) [x, y] = op "blodwen-and" [x, y]
schOp (BOr ty) [x, y] = op "blodwen-or" [x, y]
schOp (BXOr ty) [x, y] = op "blodwen-xor" [x, y]
schOp (LT CharType) [x, y] = boolop "char<?" [x, y]
schOp (LTE CharType) [x, y] = boolop "char<=?" [x, y]
schOp (EQ CharType) [x, y] = boolop "char=?" [x, y]

31
src/Core/Primitives.idr
View File

@ -139,12 +139,28 @@ mod _ _ = Nothing
shiftl : Constant -> Constant -> Maybe Constant
shiftl (I x) (I y) = pure $ I (shiftL x y)
shiftl (BI x) (BI y) = pure $ BI (prim__shlBigInt x y)
shiftl _ _ = Nothing
shiftr : Constant -> Constant -> Maybe Constant
shiftr (I x) (I y) = pure $ I (shiftR x y)
shiftr (BI x) (BI y) = pure $ BI (prim__ashrBigInt x y)
shiftr _ _ = Nothing
band : Constant -> Constant -> Maybe Constant
band (I x) (I y) = pure $ I (prim__andInt x y)
band (BI x) (BI y) = pure $ BI (prim__andBigInt x y)
band _ _ = Nothing
bor : Constant -> Constant -> Maybe Constant
bor (I x) (I y) = pure $ I (prim__orInt x y)
bor (BI x) (BI y) = pure $ BI (prim__orBigInt x y)
bor _ _ = Nothing
bxor : Constant -> Constant -> Maybe Constant
bxor (I x) (I y) = pure $ I (prim__xorInt x y)
bxor _ _ = Nothing
neg : Constant -> Maybe Constant
neg (BI x) = pure $ BI (-x)
neg (I x) = pure $ I (-x)
@ -290,6 +306,10 @@ getOp (Neg ty) = unaryOp neg
getOp (ShiftL ty) = binOp shiftl
getOp (ShiftR ty) = binOp shiftr
getOp (BAnd ty) = binOp band
getOp (BOr ty) = binOp bor
getOp (BXOr ty) = binOp bxor
getOp (LT ty) = binOp lt
getOp (LTE ty) = binOp lte
getOp (EQ ty) = binOp eq
@ -335,6 +355,9 @@ opName (Mod ty) = prim $ "mod_" ++ show ty
opName (Neg ty) = prim $ "negate_" ++ show ty
opName (ShiftL ty) = prim $ "shl_" ++ show ty
opName (ShiftR ty) = prim $ "shr_" ++ show ty
opName (BAnd ty) = prim $ "and_" ++ show ty
opName (BOr ty) = prim $ "or_" ++ show ty
opName (BXOr ty) = prim $ "xor_" ++ show ty
opName (LT ty) = prim $ "lt_" ++ show ty
opName (LTE ty) = prim $ "lte_" ++ show ty
opName (EQ ty) = prim $ "eq_" ++ show ty
@ -371,8 +394,12 @@ allPrimitives =
map (\t => MkPrim (Div t) (arithTy t) notCovering) [IntType, IntegerType, DoubleType] ++
map (\t => MkPrim (Mod t) (arithTy t) notCovering) [IntType, IntegerType] ++
map (\t => MkPrim (Neg t) (predTy t t) isTotal) [IntType, IntegerType, DoubleType] ++
map (\t => MkPrim (ShiftL t) (arithTy t) notCovering) [IntType] ++
map (\t => MkPrim (ShiftR t) (arithTy t) notCovering) [IntType] ++
map (\t => MkPrim (ShiftL t) (arithTy t) notCovering) [IntType, IntegerType] ++
map (\t => MkPrim (ShiftR t) (arithTy t) notCovering) [IntType, IntegerType] ++
map (\t => MkPrim (BAnd t) (arithTy t) notCovering) [IntType, IntegerType] ++
map (\t => MkPrim (BOr t) (arithTy t) notCovering) [IntType, IntegerType] ++
map (\t => MkPrim (BXOr t) (arithTy t) notCovering) [IntType] ++
map (\t => MkPrim (LT t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType] ++
map (\t => MkPrim (LTE t) (cmpTy t) isTotal) [IntType, IntegerType, CharType, DoubleType, StringType] ++

7
src/Core/TT.idr
View File

@ -113,6 +113,10 @@ data PrimFn : Nat -> Type where
ShiftL : (ty : Constant) -> PrimFn 2
ShiftR : (ty : Constant) -> PrimFn 2
BAnd : (ty : Constant) -> PrimFn 2
BOr : (ty : Constant) -> PrimFn 2
BXOr : (ty : Constant) -> PrimFn 2
LT : (ty : Constant) -> PrimFn 2
LTE : (ty : Constant) -> PrimFn 2
EQ : (ty : Constant) -> PrimFn 2
@ -153,6 +157,9 @@ Show (PrimFn arity) where
show (Neg ty) = "neg " ++ show ty
show (ShiftL ty) = "shl " ++ show ty
show (ShiftR ty) = "shr " ++ show ty
show (BAnd ty) = "and " ++ show ty
show (BOr ty) = "or " ++ show ty
show (BXOr ty) = "xor " ++ show ty
show (LT ty) = "<" ++ show ty
show (LTE ty) = "<=" ++ show ty
show (EQ ty) = "==" ++ show ty

6
src/Core/TTC.idr
View File

@ -464,6 +464,9 @@ TTC (PrimFn n) where
toBuf b (Neg ty) = do tag 5; toBuf b ty
toBuf b (ShiftL ty) = do tag 35; toBuf b ty
toBuf b (ShiftR ty) = do tag 36; toBuf b ty
toBuf b (BAnd ty) = do tag 37; toBuf b ty
toBuf b (BOr ty) = do tag 38; toBuf b ty
toBuf b (BXOr ty) = do tag 39; toBuf b ty
toBuf b (LT ty) = do tag 6; toBuf b ty
toBuf b (LTE ty) = do tag 7; toBuf b ty
toBuf b (EQ ty) = do tag 8; toBuf b ty
@ -543,6 +546,9 @@ TTC (PrimFn n) where
16 => pure StrAppend
35 => do ty <- fromBuf b; pure (ShiftL ty)
36 => do ty <- fromBuf b; pure (ShiftR ty)
37 => do ty <- fromBuf b; pure (BAnd ty)
38 => do ty <- fromBuf b; pure (BOr ty)
39 => do ty <- fromBuf b; pure (BXOr ty)
_ => corrupt "PrimFn 2"
fromBuf3 : Ref Bin Binary ->

3
support/chez/support.ss
View File

@ -10,6 +10,9 @@
(define blodwen-shl (lambda (x y) (ash x y)))
(define blodwen-shr (lambda (x y) (ash x (- y))))
(define blodwen-and (lambda (x y) (logand x y)))
(define blodwen-or (lambda (x y) (logor x y)))
(define blodwen-xor (lambda (x y) (logxor x y)))
(define cast-num
(lambda (x)

3
support/chicken/support.scm
View File

@ -10,6 +10,9 @@
(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
(define blodwen-and (lambda (x y) (bitwise-and x y)))
(define blodwen-or (lambda (x y) (bitwise-or x y)))
(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
(define cast-num
(lambda (x)

3
support/racket/support.rkt
View File

@ -10,6 +10,9 @@
(define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
(define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
(define blodwen-and (lambda (x y) (bitwise-and x y)))
(define blodwen-or (lambda (x y) (bitwise-or x y)))
(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
(define cast-num
(lambda (x)

2
tests/ttimp/basic006/expected
View File

@ -2,5 +2,5 @@ Processing as TTImp
Written TTC
Yaffle> ((Main.Just [Just a = ((Main.Vect.Vect (Main.S Main.Z)) Integer)]) ((((Main.Vect.Cons [Just k = Main.Z]) [Just a = Integer]) 1) (Main.Vect.Nil [Just a = Integer])))
Yaffle> ((Main.MkInfer [Just a = (Main.List.List Integer)]) (((Main.List.Cons [Just a = Integer]) 1) (Main.List.Nil [Just a = Integer])))
Yaffle> (repl):1:9--1:12:Ambiguous elaboration [($resolved109 ?Main.{a:54}_[]), ($resolved91 ?Main.{a:54}_[])]
Yaffle> (repl):1:9--1:12:Ambiguous elaboration [($resolved116 ?Main.{a:54}_[]), ($resolved98 ?Main.{a:54}_[])]
Yaffle> Bye for now!

6
tests/ttimp/coverage001/expected
View File

@ -2,10 +2,10 @@ Processing as TTImp
Written TTC
Yaffle> Bye for now!
Processing as TTImp
Vect2.yaff:25:1--26:1:{pat 0 {b:27} : Type} => {pat 0 {a:26} : Type} => ($resolved108 {b:27}[1] {a:26}[0] $resolved90 ($resolved99 {a:26}[0]) ($resolved99 {b:27}[1])) is not a valid impossible pattern because it typechecks
Vect2.yaff:25:1--26:1:{pat 0 {b:27} : Type} => {pat 0 {a:26} : Type} => ($resolved115 {b:27}[1] {a:26}[0] $resolved97 ($resolved106 {a:26}[0]) ($resolved106 {b:27}[1])) is not a valid impossible pattern because it typechecks
Yaffle> Bye for now!
Processing as TTImp
Vect3.yaff:25:1--26:1:Not a valid impossible pattern:
Vect3.yaff:25:9--25:11:When unifying: $resolved89 and ($resolved97 ?Main.{n:21}_[] ?Main.{b:19}_[])
Vect3.yaff:25:9--25:11:Type mismatch: $resolved89 and ($resolved97 ?Main.{n:21}_[] ?Main.{b:19}_[])
Vect3.yaff:25:9--25:11:When unifying: $resolved96 and ($resolved104 ?Main.{n:21}_[] ?Main.{b:19}_[])
Vect3.yaff:25:9--25:11:Type mismatch: $resolved96 and ($resolved104 ?Main.{n:21}_[] ?Main.{b:19}_[])
Yaffle> Bye for now!

2
tests/ttimp/coverage002/expected
View File

@ -2,6 +2,6 @@ Processing as TTImp
Written TTC
Yaffle> Main.lookup: All cases covered
Yaffle> Main.lookup':
($resolved135 {arg:0} {arg:1} (Main.FZ {m:0}) {arg:3})
($resolved142 {arg:0} {arg:1} (Main.FZ {m:0}) {arg:3})
Yaffle> Main.lookup'': Calls non covering function Main.lookup'
Yaffle> Bye for now!

6
tests/ttimp/dot001/expected
View File

@ -3,13 +3,13 @@ Written TTC
Yaffle> Bye for now!
Processing as TTImp
Dot2.yaff:15:1--16:1:When elaborating left hand side of Main.half:
Dot2.yaff:15:28--15:30:Pattern variable {P:n:94} unifies with ?{P:m:94}_[]
Dot2.yaff:15:28--15:30:Pattern variable {P:n:101} unifies with ?{P:m:101}_[]
Yaffle> Bye for now!
Processing as TTImp
Dot3.yaff:18:1--20:1:When elaborating left hand side of Main.addBaz3:
Dot3.yaff:18:10--18:15:Can't match on ($resolved86 ?{P:x:99}_[] ?{P:x:99}_[]) (Not a constructor application or primitive) - it elaborates to ($resolved86 ?Main.{_:13}_[] ?Main.{_:14}_[])
Dot3.yaff:18:10--18:15:Can't match on ($resolved93 ?{P:x:106}_[] ?{P:x:106}_[]) (Not a constructor application or primitive) - it elaborates to ($resolved93 ?Main.{_:13}_[] ?Main.{_:14}_[])
Yaffle> Bye for now!
Processing as TTImp
Dot4.yaff:17:1--19:1:When elaborating left hand side of Main.addBaz4:
Dot4.yaff:17:33--17:34:Can't match on ?{P:x:101}_[] (Non linear pattern variable) - it elaborates to ?Main.{dotTm:15}_[]
Dot4.yaff:17:33--17:34:Can't match on ?{P:x:108}_[] (Non linear pattern variable) - it elaborates to ?Main.{dotTm:15}_[]
Yaffle> Bye for now!

2
tests/ttimp/eta002/expected
View File

@ -1,5 +1,5 @@
Processing as TTImp
Eta.yaff:16:1--17:1:When elaborating right hand side of Main.etaBad:
Eta.yaff:16:10--17:1:When unifying: ($resolved91 ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved99)) ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved99)) ?Main.{x:18}_[] ?Main.{x:18}_[]) and ($resolved91 ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved99)) (({arg:10} : Integer) -> (({arg:11} : Integer) -> $resolved99)) $resolved100 \x : Char => \y : ?Main.{_:14}_[x[0]] => ($resolved100 ?Main.{_:15}_[x[1], y[0]] ?Main.{_:16}_[x[1], y[0]]))
Eta.yaff:16:10--17:1:When unifying: ($resolved98 ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved106)) ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved106)) ?Main.{x:18}_[] ?Main.{x:18}_[]) and ($resolved98 ((x : Char) -> ((y : ?Main.{_:14}_[x[0]]) -> $resolved106)) (({arg:10} : Integer) -> (({arg:11} : Integer) -> $resolved106)) $resolved107 \x : Char => \y : ?Main.{_:14}_[x[0]] => ($resolved107 ?Main.{_:15}_[x[1], y[0]] ?Main.{_:16}_[x[1], y[0]]))
Eta.yaff:16:10--17:1:Type mismatch: Char and Integer
Yaffle> Bye for now!