nanohs/PrimOps.hs at master · bkomuves/nanohs · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102

{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
{-# LANGUAGE OverloadedStrings, OverloadedLists #-}

module PrimOps where

--------------------------------------------------------------------------------

import Prelude ( Int , Char , Eq , Show )
import PrimGHC

--------------------------------------------------------------------------------

import Base
import Containers
import Types

{-% include "Base.hs"       %-}
{-% include "Containers.hs" %-}
{-% include "Types.hs"      %-}

--------------------------------------------------------------------------------
-- ** Primops

data Prim
  = Negate | Plus | Minus | Times | Div | Mod | Chr | Ord
  | BitAnd | BitOr | BitXor | ShiftL | ShiftR
  | IFTE | Not | And | Or | GenEQ | IntEQ | IntLT | IntLE
  | GetChar | PutChar | GetArg | Exit | Error | Print | RunIO | IOBind | IOReturn
  | OpenFile | HClose | HGetChar | HPutChar | HPutStr | StdIn | StdOut | StdErr
  deriving (Eq,Show)

isLazyPrim :: Prim -> Bool
isLazyPrim prim = case prim of
  { IFTE -> True
  ; And  -> True
  ; Or   -> True
  ; _    -> False }

showPrim :: Prim -> String
showPrim prim = case prim of
  { Negate   -> "Negate"   ; Plus     -> "Plus"     ; Minus   -> "Minus"
  ; Times    -> "Times"    ; Div      -> "Div"      ; Mod     -> "Mod"
  ; BitAnd   -> "BitAnd"   ; BitOr    -> "BitOr"    ; BitXor  -> "BitXor"
  ; ShiftL   -> "ShiftL"   ; ShiftR   -> "ShiftR"
  ; Chr      -> "Chr"      ; Ord      -> "Ord"      ; IFTE    -> "IFTE"
  ; Not      -> "Not"      ; And      -> "And"      ; Or      -> "Or"
  ; IntEQ    -> "IntEQ"    ; IntLT    -> "IntLT"    ; IntLE   -> "IntLE"
  ; GenEQ    -> "GenEQ"    ; Error    -> "Error"    ; Exit    -> "Exit"
  ; GetChar  -> "GetChar"  ; PutChar  -> "PutChar"  ; GetArg  -> "GetArg"
  ; StdIn    -> "StdIn"    ; StdOut   -> "StdOut"   ; StdErr  -> "StdErr"
  ; HGetChar -> "HGetChar" ; HPutChar -> "HPutChar" ; HClose  -> "HClose"
  ; OpenFile -> "OpenFile" ; HPutStr  -> "HPutStr"  ; Print   -> "Print"
  ; IOBind   -> "IOBind"   ; IOReturn -> "IOReturn" ; RunIO   -> "RunIO"    }

data PrimOp = PrimOp Arity Prim deriving Show

thePrimOps :: Mode -> Trie PrimOp
thePrimOps mode = let { io m = case mode of { Compile -> inc m ; Interpret -> id m } } in trieFromList
  [ Pair "error"     (PrimOp  1      Error   )
  , Pair "negate"    (PrimOp  1      Negate  )
  , Pair "plus"      (PrimOp  2      Plus    )
  , Pair "minus"     (PrimOp  2      Minus   )
  , Pair "times"     (PrimOp  2      Times   )
  , Pair "div"       (PrimOp  2      Div     )
  , Pair "mod"       (PrimOp  2      Mod     )
  , Pair "bitAnd"    (PrimOp  2      BitAnd  )
  , Pair "bitOr"     (PrimOp  2      BitOr   )
  , Pair "bitXor"    (PrimOp  2      BitXor  )
  , Pair "shiftL"    (PrimOp  2      ShiftL  )
  , Pair "shiftR"    (PrimOp  2      ShiftR  )
  , Pair "chr"       (PrimOp  1      Chr     )
  , Pair "ord"       (PrimOp  1      Ord     )
  , Pair "ifte"      (PrimOp  3      IFTE    )
  , Pair "not"       (PrimOp  1      Not     )
  , Pair "and"       (PrimOp  2      And     )
  , Pair "or"        (PrimOp  2      Or      )
  , Pair "geq"       (PrimOp  2      GenEQ   )
  , Pair "eq"        (PrimOp  2      IntEQ   )
  , Pair "lt"        (PrimOp  2      IntLT   )
  , Pair "le"        (PrimOp  2      IntLE   )
  , Pair "getChar"   (PrimOp (io 0)  GetChar )
  , Pair "putChar"   (PrimOp (io 1)  PutChar )
  , Pair "getArg"    (PrimOp (io 1)  GetArg  )
  , Pair "exit"      (PrimOp (io 1)  Exit    )
  , Pair "openFile"  (PrimOp (io 2)  OpenFile)
  , Pair "hClose"    (PrimOp (io 1)  HClose  )
  , Pair "hGetChar"  (PrimOp (io 1)  HGetChar)
  , Pair "hPutChar"  (PrimOp (io 2)  HPutChar)
  , Pair "hPutStr"   (PrimOp (io 2)  HPutStr )
  , Pair "print"     (PrimOp (io 1)  Print   )
  , Pair "iobind"    (PrimOp (io 2)  IOBind  )
  , Pair "ioreturn"  (PrimOp (io 1)  IOReturn)
  , Pair "stdin"     (PrimOp  0      StdIn   )
  , Pair "stdout"    (PrimOp  0      StdOut  )
  , Pair "stderr"    (PrimOp  0      StdErr  )
  , Pair "runIO"     (PrimOp  1      RunIO   )
  ]

--------------------------------------------------------------------------------