├── .gitignore
├── LICENSE
├── README.md
├── idris-chez.cabal
├── idris
    ├── Chez.idr
    └── chez.ipkg
├── rts
    └── rts.ss
├── src
    ├── Chez
    │   ├── Codegen.hs
    │   ├── Compatibility.hs
    │   ├── Operators.hs
    │   └── Util.hs
    └── Main.hs
└── test
    ├── runtest.hs
    └── samples
        ├── loadshared.idr
        └── scheme.idr


/.gitignore:
--------------------------------------------------------------------------------
 1 | /.cabal-sandbox
 2 | /cabal.sandbox.config
 3 | /dist
 4 | /dist-newstyle
 5 | test/tests
 6 | 
 7 | *.exe
 8 | *.o
 9 | *~
10 | .vscode
11 | 
12 | *.ibc


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2017, Niklas Larsson
 2 | 
 3 | Permission to use, copy, modify, and/or distribute this software for any purpose with or
 4 | without fee is hereby granted, provided that the above copyright notice and this
 5 | permission notice appear in all copies.
 6 | 
 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO
 8 | THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO
 9 | EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
10 | DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
11 | AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
12 | CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
13 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
 1 | # idris-chez
 2 | 
 3 | A [ChezScheme](https://cisco.github.io/ChezScheme/) backend for [Idris](http://idris-lang.org)
 4 | 
 5 | ## Usage
 6 | 
 7 | A Chez Scheme installation is a prerequisite to use idris-chez. It uses Chez Scheme extensions and would need to be modified to work with other Scheme flavors.
 8 | 
 9 | Run `cabal install` to install idris-chez.
10 | 
11 | Then idris-chez is invoked when running idris with `--codegen chez` like
12 | 
13 | ```idris --codegen chez example.idr -o example.ss```
14 | 
15 | ```scheme --script example.ss```
16 | 
17 | Files are compiled only to Scheme source for now, if desired they can be built into object files using Chez Scheme.
18 | 
19 | ## Features
20 | 
21 | * Speed!
22 | * C FFI
23 | * A compatibility layer for the base libraries dependence on the C rts. for example, the C calls in Prelude.Files are substituted by Scheme calls.
24 | * Chez Scheme provides excellent stack handling and garbage collection 
25 | 
26 | ## To do
27 | 
28 | * Scheme FFI (In progress!)
29 | * Map some common but non-primitive Idris types like lists and bools to the corresponding primitives in Scheme.
30 | * Stabilization
31 | 
32 | ## Directives
33 | 
34 | ```%lib chez "<shared lib>"```
35 | 
36 | In the chez backend `%lib` names dynamic libs that should be loaded at startup. The functions in that lib will then be available for FFI. See `test/samples/loadshared.idr` for an example.
37 | 
38 | ```%include chez "<any scheme code>"```
39 | 
40 | In the chez backend `%include` includes arbitrary Scheme code into the resulting program. Chez Scheme's `load` or `import` can be used in an `%include` directive to actually include code from another file.     
41 | 
42 | ## Benchmarks
43 | 
44 | Let's run the `pidigits` benchmark from idris' benchmarks folder!
45 | 
46 | #### idris-chez
47 | ```
48 | $ time ./pidigits.ss 5000 > /dev/null
49 | 
50 | real    0m3.219s
51 | user    0m0.000s
52 | sys     0m0.030s
53 | ```
54 | #### C backend
55 | ```
56 | $ time ./pidigits.exe 5000 > /dev/null
57 | 
58 | real    0m10.005s
59 | user    0m0.000s
60 | sys     0m0.000s
61 | ```
62 | 
63 | 
64 | Lets try 10000....
65 | #### idris-chez
66 | ```
67 | $ time ./pidigits.ss 10000 > /dev/null
68 | 
69 | real    0m12.900s
70 | user    0m0.030s
71 | sys     0m0.000s
72 | ```
73 | #### C backend
74 | ```
75 | $ time ./pidigits.exe 10000 > /dev/null
76 | Segmentation fault
77 | 
78 | real    1m17.884s
79 | user    0m0.016s
80 | sys     0m0.000s
81 | ```
82 | Ooops....


--------------------------------------------------------------------------------
/idris-chez.cabal:
--------------------------------------------------------------------------------
 1 | Name:           idris-chez
 2 | Version:        0.0.1
 3 | License:        BSD3
 4 | Author:         Niklas Larsson <niklas@mm.st>
 5 | Maintainer:     Niklas Larsson <niklas@mm.st>
 6 | Build-Type:     Simple
 7 | Cabal-Version:  >= 1.22
 8 | 
 9 | Data-files:     rts/rts.ss
10 | 
11 | source-repository head
12 |   type:     git
13 |   location: https://github.com/melted/idris-chez
14 | 
15 | Executable idris-codegen-chez
16 |   Main-is:        Main.hs
17 |   hs-source-dirs: src
18 | 
19 |   Build-depends:  idris
20 |                 , base
21 |                 , containers
22 |                 , directory
23 |                 , filepath
24 |                 , haskeline >= 0.7
25 |                 , mtl
26 |                 , transformers
27 |                 , text
28 | 
29 |   other-modules: 
30 |     Chez.Codegen,
31 |     Chez.Compatibility,
32 |     Chez.Operators,
33 |     Chez.Util
34 |     Paths_idris_chez
35 | 
36 |   if os(windows)
37 |      build-depends: Win32 < 2.4
38 |   else
39 |      build-depends: unix < 2.8
40 |    
41 |   ghc-prof-options: -auto-all -caf-all
42 |   ghc-options:      -threaded -rtsopts -funbox-strict-fields
43 | 


--------------------------------------------------------------------------------
/idris/Chez.idr:
--------------------------------------------------------------------------------
 1 | module Chez
 2 | 
 3 | public export
 4 | data SchemeVal = Op1
 5 | 
 6 | 
 7 |     
 8 | -- TODO: need lists and vector. Should fix representation of them first
 9 | public export
10 | data SchemeTypes : Type -> Type where
11 |     S_Int : SchemeTypes Int
12 |     S_Nat : SchemeTypes Nat
13 |     S_Integer : SchemeTypes Integer
14 |     S_Real : SchemeTypes Double
15 |     S_Bool : SchemeTypes Bool
16 |     S_Unit : SchemeTypes ()
17 |     S_Char : SchemeTypes Char
18 |     S_String : SchemeTypes String
19 | 
20 |     S_Fun : SchemeTypes a -> SchemeTypes b -> SchemeTypes (a -> b)
21 |     S_Opaque : SchemeTypes SchemeVal
22 | 
23 | public export
24 | FFI_S : FFI
25 | FFI_S = MkFFI SchemeTypes String String
26 | 
27 | public export
28 | SIO : Type -> Type
29 | SIO = IO' FFI_S


--------------------------------------------------------------------------------
/idris/chez.ipkg:
--------------------------------------------------------------------------------
1 | package chez
2 | 
3 | modules = Chez


--------------------------------------------------------------------------------
/rts/rts.ss:
--------------------------------------------------------------------------------
  1 | ;; The runtime library for idris-chez
  2 | 
  3 | (define-record-type con (fields tag vals))
  4 | 
  5 | ;; Implements the LSystemInfo primitive
  6 | (define (idris-systeminfo n)
  7 |     (case n 
  8 |         ((0) "chez")
  9 |         ((1) (symbol->string (machine-type)))
 10 |         ((2) "")))
 11 | 
 12 | ;; Implements the substring primitive
 13 | (define (idris-substring off len s) 
 14 |     (let* ((l (string-length s))
 15 |           (b (max 0 off))
 16 |           (x (max 0 len))
 17 |           (end (min l (+ b x))))
 18 |             (substring s b end)))
 19 | 
 20 | ;; Wrap an idris function application in a function for FFI
 21 | ;; TODO: Check for more args and use {APPLY2_0} in that case
 22 | (define (idris-chez-make-wrapper f)
 23 |     (lambda args
 24 |         (let loop ((a args) (fun f))
 25 |             (let ((v (if (null? a) '() (car a))))
 26 |                 (let ((out (|{APPLY_0}| fun v)))
 27 |                     (if (idris-chez-isfcon? out)
 28 |                         (loop (if (null? a) '() (cdr a)) out)
 29 |                         out))))))
 30 | 
 31 | ;; Last error. errno substitute.
 32 | (define last-idris-io-error #f)
 33 | ;; Id's of errored ports
 34 | (define idris-errored-ports '())
 35 | 
 36 | (define (idris-chez-isnull p)
 37 |     (cond
 38 |         ((number? p) (= p 0))
 39 |         (else #f)))
 40 | 
 41 | (define (idris-chez-isfcon? c)
 42 |     (and (con? c) (> (con-tag c) 65535)))
 43 | 
 44 | (define (idris-chez-error-handler x)
 45 |     (cond 
 46 |         ((i/o-read-error? x) (set! last-idris-io-error 1))
 47 |         ((i/o-write-error? x) (set! last-idris-io-error 2))
 48 |         ((i/o-file-does-not-exist-error? x) (set! last-idris-io-error 3))
 49 |         ((i/o-file-protection-error? x) (set! last-idris-io-error 4))
 50 |         (else (set! last-idris-io-error 5)))
 51 |     0)
 52 | 
 53 | (define (idris-chez-fileopen file mode)
 54 |     (guard
 55 |         ;; exception handler
 56 |         (x ((i/o-error? x) (idris-chez-error-handler x)))
 57 |         ;; open file
 58 |         (idris-chez-open file mode)))
 59 | 
 60 | 
 61 | (define (idris-chez-open file mode)
 62 |     (define tc (make-transcoder (utf-8-codec)))
 63 |     (define bm (buffer-mode line))
 64 |     (case mode 
 65 |         (("r") (open-file-input-port file (file-options) bm tc))
 66 |         (("w") (open-file-output-port file (file-options no-fail) bm tc))
 67 |         (("wx") (open-file-output-port file (file-options) bm tc))
 68 |         (("a") (open-file-output-port file (file-options no-fail no-truncate) bm tc))
 69 |         (("r+") (open-file-input/output-port file (file-options no-create) bm tc))
 70 |         (("w+") (open-file-input/output-port file (file-options no-fail) bm tc))
 71 |         (("w+x") (open-file-input/output-port file (file-options) bm tc))
 72 |         (("a+") (open-file-input/output-port file (file-options no-fail no-truncate) bm tc))
 73 |         (else (raise (make-i/o-error)))))
 74 | 
 75 | (define (idris-chez-getfileerror)
 76 |     (if (last-idris-io-error)
 77 |         (if (< last-idris-io-error 5)
 78 |              (make-con last-idris-io-error '())
 79 |              (make-con 0 '(1)))
 80 |         (make-con 0 '(0))))
 81 | 
 82 | (define (idris-chez-showerror n)
 83 |     (case n
 84 |         ((0) "No error"))
 85 |         ((1) "Generic error"))
 86 | 
 87 | (define (idris-chez-fileerror p)
 88 |     (member (port-file-descriptor p) idris-errored-ports))
 89 | 
 90 | 
 91 | (define (idris-chez-fgetc p)
 92 |     (guard (x (else (set! idris-errored-ports (cons (port-file-descriptor p) idris-errored-ports))
 93 |                     #\x0))
 94 |             (let ((ch (get-char p))) ;; TODO: need to handle eof??
 95 |                 ch)))
 96 | 
 97 | (define (idris-chez-popen cmd mode)
 98 |     (guard
 99 |         (x ((i/o-error? x) (idris-chez-error-handler x)))
100 |         (case mode
101 |             (("r" "w") (let* ((p (process cmd))
102 |                                 (i (car p))
103 |                                 (o (cadr p)))
104 |                             (case mode
105 |                                 (("r") (close-port o) i)
106 |                                 (("w") (close-port i) o)
107 |             (else 0)))))))
108 | 
109 | (define (idris-chez-close-port p)
110 |     (when (port? p) (close-port p)))
111 | 
112 | (define (idris-chez-get-line p)
113 |     (if (and (port? p) (not (port-eof? p))) 
114 |         (let ((str (get-line p)))
115 |             (string-append str "\n"))
116 |         ""))
117 | 
118 | (define (idris-chez-get-n n p)
119 |     (if (port? p) (get-string-n p n) ""))
120 | 
121 | (define (idris-chez-putstring p s)
122 |     (if (port? p) (put-string p s) void)
123 |     0)
124 | 
125 | 
126 | ;; disable buffering for stdin and stdout
127 | ;; using chez specific forms of the io functions
128 | (define (idris-chez-disable-buffering)
129 |     (current-input-port (standard-input-port 'none (make-transcoder (utf-8-codec))))
130 |     (current-output-port (standard-output-port 'none (make-transcoder (utf-8-codec)))))
131 | 
132 | (define (idris-chez-stringbuilder)
133 |     (let ((xs '()))
134 |         (case-lambda 
135 |             (() (apply string-append (reverse xs)))
136 |             ((a) (set! xs (cons a xs))))))
137 | 
138 | ;; TODO: memoize foreign functions (that goes for compileForeign too)
139 | (define (idris-chez-memset ptr off val size)
140 |     ((foreign-procedure "memset" (void* int size_t) void*) (+ ptr off) val size)
141 |     void)
142 | 
143 | (define (idris-chez-memmove src srcoff dst dstoff size)
144 |     ((foreign-procedure "memmove" (void* void* size_t) void*) (+ src srcoff) (+ dst dstoff) size)
145 |     void)
146 | 
147 | (define (idris-chez-loadlib lib)
148 |     (guard
149 |         (x (else void)) ;; Accept failure to load a lib
150 |         (load-shared-object lib)))
151 | 
152 | (define (idris-chez-init libs)
153 |     (let* ((mt (symbol->string (machine-type)))
154 |             (l (string-length mt))
155 |             (pf (substring mt (- l 2) l))
156 |             (clib (case pf
157 |                 (("nt") "msvcrt")
158 |                 (else "libc"))))
159 |         (idris-chez-loadlib clib)
160 |         (map idris-chez-loadlib libs)))
161 | 
162 | 


--------------------------------------------------------------------------------
/src/Chez/Codegen.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | 
  3 | module Chez.Codegen(codegenChez) where
  4 | 
  5 | import IRTS.CodegenCommon
  6 | import IRTS.Lang
  7 | import IRTS.Simplified
  8 | import Idris.Core.TT as TT
  9 | import Idris.Core.CaseTree
 10 | 
 11 | import Data.Bits
 12 | import Data.List
 13 | import Data.Maybe
 14 | import Data.Char
 15 | import Data.String(IsString, fromString)
 16 | 
 17 | import qualified Data.Text as T
 18 | 
 19 | import Chez.Compatibility (fixup, intercept)
 20 | import Chez.Operators
 21 | import Chez.Util
 22 | 
 23 | import Paths_idris_chez
 24 | 
 25 | 
 26 | codegenChez :: CodeGenerator
 27 | codegenChez ci = do let decls = fixup (simpleDecls ci)
 28 |                     let out = map doCodegen decls ++ [start]++["(exit 0)\n"]
 29 |                     let init = initCall (compileLibs ci)
 30 |                     let include = intercalate "\n" (includes ci)
 31 |                     let code = concat out
 32 |                     dir <- getDataDir
 33 |                     let top = "#!/usr/bin/env scheme-script\n" ++
 34 |                               "#!chezscheme\n" ++
 35 |                               "(import (chezscheme))\n"
 36 |                     rtslib <- readFile $ dir ++ "/rts/rts.ss"
 37 |                     writeFile (outputFile ci) (top ++ rtslib ++ init ++ include ++ code)
 38 | 
 39 | initCall :: [String] -> String
 40 | initCall libs = call "idris-chez-init" [call "list" (map sstr libs)] ++ "\n"
 41 | 
 42 | start :: String
 43 | start = "(" ++ sname (MN 0 "runMain") ++ ")\n"
 44 | 
 45 | 
 46 | doCodegen :: (Name, SDecl) -> String
 47 | doCodegen (n, SFun n' as locs exp) = 
 48 |     defineFun (sname n) (map (loc . fst) (zip [0..] as)) (compileExpr exp)
 49 | 
 50 | compileExpr :: SExp -> String
 51 | compileExpr (SV v) = compileVar v
 52 | compileExpr (SApp _ n args) = call (sname n) (compileVars args)
 53 | compileExpr (SLet var exp body) = slet (compileVar var) (compileExpr exp) (compileExpr body)
 54 | compileExpr (SUpdate var exp) = call "begin" [call "set!" [compileVar var, compileExpr exp],
 55 |                                               compileVar var]  
 56 | -- TODO: SCon check for scheme primitive types and use them instead
 57 | compileExpr (SCon _ t n xs) = call "make-con" [show t, call "list" (compileVars xs)]
 58 | compileExpr (SCase ctype var alts) = compileCase var alts
 59 | compileExpr (SChkCase var alts) = compileCase var alts
 60 | compileExpr (SProj var i) = call "list-ref" [call "con-vals" [compileVar var], show i]
 61 | compileExpr (SConst c) = compileConst c
 62 | compileExpr (SForeign ret name args) = handleForeign ret name args
 63 | compileExpr (SOp prim args) = compileOp prim args
 64 | compileExpr SNothing = "'()"
 65 | compileExpr (SError what) = sexp ["error", sstr "idris", sstr what]
 66 | 
 67 | 
 68 | 
 69 | -- TODO: Add case where all alts are const
 70 | -- TODO: if-stat for 1 alt plus default?
 71 | compileCase :: LVar -> [SAlt] -> String
 72 | compileCase var alts = cond $ map (compileAlt var) (salts alts)
 73 |     where
 74 |         salts [] = []
 75 |         salts (sd@(SDefaultCase _):_) = [sd]
 76 |         salts (x:xs) = x:(salts xs)
 77 | 
 78 | 
 79 | -- TODO: Special case scheme primitive types
 80 | compileAlt :: LVar -> SAlt -> String
 81 | compileAlt var (SConCase lv t n args body) =
 82 |              sexp [call "=" [call "con-tag" [compileVar var],show t], project 1 lv args body]
 83 |     where
 84 |         project i v ns body = apply (lambda (map (loc . fst) (zip [v..] ns))
 85 |                                          (compileExpr body)) (call "con-vals" [compileVar var]) 
 86 | compileAlt var (SConstCase c body) = sexp [compileCompare var c, compileExpr body]
 87 | compileAlt _ (SDefaultCase body) = sexp ["else", compileExpr body]
 88 | 
 89 | compileCompare :: LVar -> Const -> String
 90 | compileCompare var c@(Ch _) = call "char=?" [compileVar var, compileConst c]
 91 | compileCompare var c@(Str _) = call "string=?" [compileVar var, compileConst c]
 92 | compileCompare var c = call "=" [compileVar var, compileConst c] 
 93 | 
 94 | compileConst :: Const -> String
 95 | compileConst (I i) = show i
 96 | compileConst (BI bi) = show bi
 97 | compileConst (Fl d) = show d
 98 | compileConst (Ch c) = schemeChar c
 99 | compileConst (Str s) = schemeString s
100 | compileConst (B8 w) = show w
101 | compileConst (B16 w) = show w
102 | compileConst (B32 w) = show w
103 | compileConst (B64 w) = show w
104 | -- type const, won't be used, hopefully
105 | compileConst t | isTypeConst t = "#f"
106 | compileConst x = error $ "Unimplemented const " ++ show x
107 | 
108 | 
109 | handleForeign ret name args = if isCType ret
110 |                                  then compileForeign ret name args `fromMaybe` intercept ret name args
111 |                                  else compileSchemeForeign ret name args 
112 | 
113 | compileForeign :: FDesc -> FDesc -> [(FDesc, LVar)] -> String
114 | compileForeign rty (FStr ('&':name)) [] = call "foreign-entry" [sstr name]
115 | compileForeign rty (FStr "%dynamic") (f:args) = foreignProcedure (compileVar $ snd f) rty args
116 | compileForeign rty (FStr "%wrapper") (f:args) = makeWrapper (fst f) (compileVar (snd f))
117 | compileForeign rty (FStr name) args = foreignProcedure (sstr name) rty args
118 | 
119 | compileForeign _ _ _ = error "Illegal ffi call"
120 | 
121 | foreignProcedure proc rty args = handleFFIReturn (toFType rty) $
122 |     sexp $ [call "foreign-procedure" [proc, sexp (map (ffiType . fst) args), ffiType rty]]
123 |         ++ map compileFFIVar args
124 | 
125 | compileFFIVar (fd, x) | isFunction fd = makeWrapper fd (compileVar x)
126 | compileFFIVar (_,x) = compileVar x
127 | 
128 | handleFFIReturn :: FType -> String -> String
129 | handleFFIReturn FUnit s = call "begin" [s, "'()"]
130 | handleFFIReturn _ s = s
131 | 
132 | makeWrapper fd s = slet "ff" callable body  
133 |   where
134 |     (rty, args) = getSignature fd
135 |     callable = call "foreign-callable" [wrapper, sexp args, rty]
136 |     wrapper = call "idris-chez-make-wrapper" [s] 
137 |     body = call "lock-object" ["ff"] ++ call "foreign-callable-entry-point" ["ff"]
138 | 
139 | -- Scheme FFI
140 | 
141 | compileSchemeForeign ret (FStr name) args = handleSchemeReturn ret (call name (map compileSchemeVar args))
142 | 
143 | -- TODO: If there are datatypes that need to translated when passing to Scheme, do it here
144 | compileSchemeVar :: (FDesc, LVar) -> String
145 | compileSchemeVar (FCon c, x) | c == sUN "S_Bool" = call "=" ["1",call "car" [compileVar x]] 
146 | compileSchemeVar (_, x) = compileVar x
147 | 
148 | -- TODO: If any return types needs marshalling, do it here
149 | handleSchemeReturn :: FDesc -> String -> String
150 | handleSchemeReturn (FCon c) s | c == sUN "S_Bool" = call "list" [call "if" [s, "1", "0"]]
151 | handleSchemeReturn ret s = s


--------------------------------------------------------------------------------
/src/Chez/Compatibility.hs:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | module Chez.Compatibility (fixup, intercept) where
  4 | 
  5 | import Idris.Core.TT
  6 | 
  7 | import IRTS.Lang
  8 | import IRTS.Simplified
  9 | 
 10 | import Chez.Util
 11 | 
 12 | -- This module is where we sweep all the ugly things under the rug.
 13 | -- The aim of idris-chez is to be fully compatible with the C backend,
 14 | -- but as some functionality in the libraries depend on the C rts or
 15 | -- C standard lib functions we have a choice to make: implement those in
 16 | -- C or make them in Scheme and patch the call points to point right
 17 | -- at compilation time.
 18 | -- We will use both approaches. The Prelude.File library should use
 19 | -- the Scheme functions for file handling. The CFFI usage of "malloc"
 20 | -- and friends should as clearly be left as is.
 21 | 
 22 | 
 23 | -- Change the sdecls, this is used when we need
 24 | -- to be aware of the context.
 25 | fixup :: [(Name, SDecl)] -> [(Name, SDecl)]
 26 | fixup decls = map rewriteDecl decls
 27 | 
 28 | -- Check a foreign call, and return substitute code if a match
 29 | intercept :: FDesc -> FDesc -> [(FDesc, LVar)] -> Maybe String
 30 | -- Prelude.Strings
 31 | intercept _ (FStr "isNull") [(_, p)] = Just $ predicate (call "idris-chez-isnull" [compileVar p])
 32 | intercept _ (FStr "idris_makeStringBuffer") [(_, n)] = Just $ call "idris-chez-stringbuilder" []
 33 | intercept _ (FStr "idris_addToString") [(_, p), (_, s)] = Just $ call (compileVar p) [compileVar s]
 34 | intercept _ (FStr "idris_getString") [(_, _), (_, p)] = Just $ call (compileVar p) []
 35 | 
 36 | -- Prelude.File
 37 | intercept _ (FStr "fileOpen") [(_, file), (_, mode)] = 
 38 |                             Just $ call "idris-chez-fileopen" [compileVar file, compileVar mode]
 39 | intercept _ (FStr "fileSize") [(_, p)] = Just $ call "file-length" [compileVar p]
 40 | intercept _ (FStr "idris_showerror") [(_, i)] = Just $ call "idris-chez-showerror" [compileVar i]
 41 | intercept _ (FStr "idris_mkFileError") [(_, p)] = Just $ call "idris-chez-makefileerror" []
 42 | intercept _ (FStr "fileError") [(_, p)] = Just $ predicate $ call "idris-chez-fileerror" [compileVar p]
 43 | intercept _ (FStr "fileClose") [(_, p)] = Just $ call "idris-chez-close-port" [compileVar p]
 44 | intercept _ (FStr "idris_fgetc") [(_, p)] = Just $ call "idris-chez-fgetc" [compileVar p]
 45 | intercept _ (FStr "idris_fflush") [(_, p)] = Just $ call "flush-output-port" [compileVar p]
 46 | intercept _ (FStr "fileEOF") [(_, p)] = Just $ predicate (call "port-eof?" [compileVar p])
 47 | -- This doesn't do exactly what fpoll does, but close enough
 48 | intercept _ (FStr "fpoll") [(_, p)] = Just $ predicate (call "input-port-ready?" [compileVar p])
 49 | intercept _ (FStr "do_popen") [(_, f), (_, m)] = Just $ predicate (call "idris-chez-popen" [compileVar f, compileVar m])
 50 | intercept _ (FStr "idris_pclose") [(_, p)] = Just $ call "idris-chez-close-port" [compileVar p]
 51 | -- Prelude.Interactive
 52 | -- No need to touch getchar and putchar
 53 | intercept _ (FStr "idris_disableBuffering") [] = Just $ call "idris-chez-disable-buffering" []
 54 | intercept _ (FStr "idris_numArgs") [] = Just $ call "length" [call "command-line" []]
 55 | intercept _ (FStr "idris_getArg") [(_, n)] = Just $ call "list-ref" [call "command-line" [], compileVar n]
 56 | -- Prelude
 57 | -- TODO: Hmmm, collect doesn't like other active threads. Is there a simple fix?
 58 | -- For now, let the user beware. 
 59 | intercept _ (FStr "idris_forceGC") [_] = Just $ call "collect" []
 60 | -- getErrno uses idris_errno: errno is a C macro, what to do? Write a C function...
 61 | -- But I want something way more substantial before I go to the bother of including
 62 | -- a shared lib.
 63 | intercept _ (FStr "idris_errno") [] = Just "0"
 64 | 
 65 | -- base
 66 | -- System
 67 | -- Leave all the standard C functions, just replace idris_time and getEnvPair
 68 | intercept _ (FStr "idris_time") [] = Just $ call "time-second" [call "current-time" []]
 69 | -- System.Concurrency
 70 | --    TODO: Implement
 71 | -- Data.Buffer
 72 | --    TODO: Implement
 73 | -- Data.IORef
 74 | intercept _ (FStr "idris_newRef") [(_, r)] = Just $ call "box" [compileVar r] 
 75 | intercept _ (FStr "idris_readRef") [(_, r)] = Just $ call "unbox" [compileVar r]
 76 | intercept _ (FStr "idris_writeRef") [(_, b), (_, r)] = Just $ call "set-box!" [compileVar b, compileVar r]
 77 | 
 78 | -- contrib
 79 | -- CFFI: Fine as is
 80 | -- Network.Socket
 81 | --    TODO: Implement
 82 | 
 83 | -- effects
 84 | intercept _ (FStr "idris_memset") [(_, p), (_, o), (_, v), (_, s)] = Just $
 85 |                      call "idris-chez-memset" [compileVar p, compileVar o, compileVar v, compileVar s]
 86 | intercept _ (FStr "idris_memmove") [(_, p), (_, d), (_, op), (_, od),(_, s)] = Just $
 87 |                      call "idris-chez-memmove" [compileVar p, compileVar op, compileVar d, compileVar od, compileVar s]
 88 | intercept _ (FStr "idris_peek") [(_, o), (_, p)] = Just $
 89 |                      call "foreign-ref" ["'unsigned-8", compileVar p, compileVar o]
 90 | intercept _ (FStr "idris_poke") [(_, p), (_, o), (_, v)] = Just $
 91 |                      call "foreign-set!" ["'unsigned-8", compileVar p, compileVar o, compileVar v]
 92 | 
 93 | intercept _ _ _ = Nothing
 94 | 
 95 | rewriteDecl :: (Name, SDecl) -> (Name, SDecl)
 96 | rewriteDecl (n, sd) | n == sUN "Prelude.File.fgetc" = (n, rewriteFFI "fgetc" "idris_fgetc" sd)
 97 | rewriteDecl (n, sd) | n == sUN "Prelude.File.fflush" = (n, rewriteFFI "ffflush" "idris_fflush" sd)
 98 | rewriteDecl (n, sd) | n == sUN "Prelude.File.pclose" = (n, rewriteFFI "pclose" "idris_pclose" sd)
 99 | rewriteDecl d = d
100 | 
101 | 
102 | rewriteFFI :: String -> String -> SDecl -> SDecl
103 | rewriteFFI from to (SFun a b c exp) = SFun a b c (rewriteExp exp)
104 |     where
105 |         rewriteExp (SForeign r (FStr from) a) = SForeign r (FStr to) a
106 |         rewriteExp (SLet v exp body) = SLet v (rewriteExp exp) (rewriteExp body)
107 |         rewriteExp (SCase a b alts) = SCase a b (map rewriteAlt alts)
108 |         rewriteExp (SChkCase a alts) = SChkCase a (map rewriteAlt alts)
109 |         rewriteExp e = e
110 | 
111 |         rewriteAlt (SConCase a b c d exp) = SConCase a b c d (rewriteExp exp)
112 |         rewriteAlt (SConstCase a exp) = SConstCase a (rewriteExp exp)
113 |         rewriteAlt (SDefaultCase exp) = SDefaultCase (rewriteExp exp)


--------------------------------------------------------------------------------
/src/Chez/Operators.hs:
--------------------------------------------------------------------------------
  1 | 
  2 | 
  3 | module Chez.Operators(compileOp, compileVar, compileVars) where
  4 | 
  5 | import Idris.Core.TT
  6 | 
  7 | import IRTS.Lang
  8 | 
  9 | import Chez.Util
 10 | 
 11 | 
 12 | compileOp :: PrimFn -> [LVar] -> String
 13 | -- char is not like other numeric types in scheme
 14 | -- arithmetic on them should be rare, so represent
 15 | -- them like scheme chars anyway
 16 | compileOp (LPlus (ATInt ITChar)) xs = charOp "+" xs
 17 | compileOp (LMinus (ATInt ITChar)) xs = charOp "-" xs
 18 | compileOp (LTimes (ATInt ITChar)) xs = charOp "*" xs
 19 | compileOp (LUDiv ITChar) xs = charOp "quotient" xs
 20 | compileOp (LSDiv (ATInt ITChar)) xs = charOp "/" xs
 21 | compileOp (LURem ITChar) xs = charOp "remainder" xs
 22 | compileOp (LSRem (ATInt ITChar)) xs = charOp "remainder" xs
 23 | compileOp (LAnd ITChar) xs = charOp "bitwise-and" xs
 24 | compileOp (LOr ITChar) xs = charOp "bitwise-ior" xs
 25 | compileOp (LXOr ITChar) xs = charOp "bitwise-xor" xs
 26 | compileOp (LCompl ITChar) [x] = call "integer->char" [call "bitwise-xor" [call "char->integer" [compileVar x], full ITChar]]
 27 | -- we don't have to worry about negative chars but we need keep the result in 32 bits
 28 | compileOp (LSHL ITChar) xs = charShift True "bitwise-arithmetic-shift-left" xs 
 29 | compileOp (LLSHR ITChar) xs = charShift False "bitwise-arithmetic-shift-right" xs
 30 | compileOp (LASHR ITChar) xs = charShift False "bitwise-arithmetic-shift-right" xs
 31 | compileOp (LEq (ATInt ITChar)) xs = cmp "char=?" xs
 32 | compileOp (LLt ITChar) xs = cmp "char<?" xs
 33 | compileOp (LLe ITChar) xs = cmp "char<=?" xs
 34 | compileOp (LGt ITChar) xs = cmp "char>?" xs
 35 | compileOp (LGe ITChar) xs = cmp "char>=?" xs
 36 | compileOp (LSLt (ATInt ITChar)) xs = cmp "char<?" xs
 37 | compileOp (LSLe (ATInt ITChar)) xs = cmp "char<=?" xs
 38 | compileOp (LSGt (ATInt ITChar)) xs = cmp "char>?" xs
 39 | compileOp (LSGe (ATInt ITChar)) xs = cmp "char>=?" xs
 40 | 
 41 | -- All other numeric types are just a scheme number
 42 | -- TODO, constrain to correct ranges
 43 | compileOp (LPlus ATFloat) xs = op "+" xs
 44 | compileOp (LPlus (ATInt ITBig)) xs = op "+" xs
 45 | compileOp (LPlus (ATInt it)) xs = clamp it (op "+" xs)
 46 | compileOp (LMinus ATFloat) xs = op "-" xs
 47 | compileOp (LMinus (ATInt ITBig)) xs = op "-" xs
 48 | compileOp (LMinus (ATInt it)) xs = clamp it (op "-" xs)
 49 | compileOp (LTimes ATFloat) xs = op "*" xs
 50 | compileOp (LTimes (ATInt ITBig)) xs = op "*" xs
 51 | compileOp (LTimes (ATInt it)) xs = clamp it (op "*" xs)
 52 | 
 53 | compileOp (LUDiv _) xs = op "quotient" xs
 54 | compileOp (LSDiv ATFloat) xs = op "/" xs
 55 | compileOp (LSDiv (ATInt _)) xs = op "quotient" xs
 56 | 
 57 | compileOp (LURem _) xs = op "remainder" xs
 58 | compileOp (LSRem _) xs = op "remainder" xs
 59 | compileOp (LAnd _) xs = op "bitwise-and" xs
 60 | compileOp (LOr _) xs = op "bitwise-ior" xs
 61 | compileOp (LXOr _) xs = op "bitwise-xor" xs
 62 | compileOp (LCompl ITBig) xs = op "bitwise-not" xs
 63 | compileOp (LCompl ty) [x] = call "bitwise-xor" [compileVar x, full ty]
 64 | compileOp (LSHL ITBig) xs = op "bitwise-arithmetic-shift-left" xs 
 65 | compileOp (LSHL ty@(ITFixed _)) [x, y] = call "bitwise-and" [call "bitwise-arithmetic-shift-left" 
 66 |                                             [compileVar x, compileVar y], full ty]
 67 | compileOp (LSHL ty) [x, y] = call "bitwise-and" [(makeSigned ty (call "bitwise-arithmetic-shift-left" 
 68 |                                             [makeUnsigned ty (compileVar x), compileVar y])), full ty]
 69 | compileOp (LLSHR ty@(ITFixed _)) xs = op "bitwise-arithmetic-shift-right" xs
 70 | compileOp (LLSHR ty) [x, y] = makeSigned ty (call "bitwise-arithmetic-shift-right" [makeUnsigned ty (compileVar x), compileVar y])
 71 | compileOp (LASHR ty) xs = op "bitwise-arithmetic-shift-right" xs
 72 | compileOp (LEq _) xs = cmp "=" xs
 73 | compileOp (LLt ty) xs = ucmp ty "<" xs
 74 | compileOp (LLe ty) xs = ucmp ty "<=" xs
 75 | compileOp (LGt ty) xs = ucmp ty ">" xs
 76 | compileOp (LGe ty) xs = ucmp ty ">=" xs
 77 | compileOp (LSLt _) xs = cmp "<" xs
 78 | compileOp (LSLe _) xs = cmp "<=" xs
 79 | compileOp (LSGt _) xs = cmp ">" xs
 80 | compileOp (LSGe _) xs = cmp ">=" xs
 81 | compileOp (LSExt from@(ITFixed _) to@(ITFixed _)) [x] = makeUnsigned to $ makeSigned from $ compileVar x
 82 | compileOp (LSExt ty@(ITFixed _) _) [x] = makeSigned ty $ compileVar x
 83 | compileOp (LSExt _ _) [x] = compileVar x
 84 | compileOp (LZExt (ITFixed _) _) [x] = compileVar x
 85 | compileOp (LZExt ty _) [x] =  makeUnsigned ty (compileVar x)
 86 | compileOp (LTrunc from to) [x] = call "bitwise-and" [compileVar x, full to]
 87 | compileOp LStrConcat xs =  op "string-append" xs
 88 | compileOp LStrLt xs = cmp "string<?" xs
 89 | compileOp LStrEq xs = cmp "string=?" xs
 90 | compileOp LStrLen xs =  op "string-length" xs
 91 | compileOp (LIntFloat ty) [x] = compileVar x
 92 | compileOp (LFloatInt ty) xs = op "floor" xs
 93 | compileOp (LIntStr _) xs = op "number->string" xs
 94 | compileOp (LStrInt _) xs = op "string->number" xs
 95 | compileOp LFloatStr xs = op "number->string" xs
 96 | compileOp LStrFloat xs = op "string->number" xs
 97 | compileOp (LChInt _) xs = op "char->integer" xs
 98 | compileOp (LIntCh _) xs = op "integer->char" xs
 99 | compileOp (LBitCast _ _) [x] = compileVar x
100 | compileOp LFExp xs = op "exp" xs 
101 | compileOp LFLog xs = op "log" xs
102 | compileOp LFSin xs = op "sin" xs 
103 | compileOp LFCos xs = op "cos" xs
104 | compileOp LFTan xs = op "tan" xs 
105 | compileOp LFASin xs = op "asin" xs 
106 | compileOp LFACos xs = op "acos" xs 
107 | compileOp LFATan xs = op "atan" xs
108 | compileOp LFSqrt xs = op "sqrt" xs 
109 | compileOp LFFloor xs = op "floor" xs 
110 | compileOp LFCeil xs = op "ceiling" xs 
111 | compileOp LFNegate xs = op "-" xs
112 | compileOp LStrHead [x] = call "string-ref" [compileVar x, "0"] 
113 | compileOp LStrTail [x] = call "substring" [compileVar x, "1", call "string-length" [compileVar x]] 
114 | compileOp LStrCons [c, x] = call "string-append" [call "string" [compileVar c], compileVar x] 
115 | compileOp LStrIndex xs = op "string-ref" xs 
116 | compileOp LStrRev [x] = call "list->string" [call "reverse" [call "string->list" [compileVar x]]] 
117 | compileOp LStrSubstr xs = op "idris-substring" xs
118 | compileOp LReadStr [_] = call "get-line" [sexp ["current-input-port"]] 
119 | compileOp LWriteStr [_, x] = call "put-string" [sexp ["current-output-port"], compileVar x]
120 | compileOp LSystemInfo [x] = call "idris-systeminfo" [compileVar x] 
121 | compileOp LFork [x] = call "fork-thread" [lambda [] (call (sname (sMN 0 "EVAL")) [compileVar x])]
122 | compileOp LPar [x] = compileVar x
123 | compileOp LCrash [x] = call "error" [show "idris", compileVar x]
124 | compileOp LNoOp xs = compileVar (last xs)
125 | compileOp (LExternal n) xs = externalOp n xs 
126 | 
127 | compileOp op _ = error "Unknown SOp: " ++ show op
128 | 
129 | 
130 | 
131 | externalOp :: Name -> [LVar] -> String
132 | externalOp n [_, x] | n == sUN "prim__readFile" = call "idris-chez-get-line" [compileVar x]
133 | externalOp n [_, len, x] | n == sUN "prim__readChars" = call "idris-chez-get-n" [compileVar len, compileVar x]
134 | externalOp n [_, x, s] | n == sUN "prim__writeFile" = call "idris-chez-putstring" [compileVar x, compileVar s]
135 | externalOp n [] | n == sUN "prim__stdin" = call "current-input-port" []
136 | externalOp n [] | n == sUN "prim__stdout" = call "current-output-port" []
137 | externalOp n [] | n == sUN "prim__stderr" = call "current-error-port" []
138 | externalOp n [_] | n == sUN "prim__vm" = "'vm" -- just a token, let's elaborate if needed
139 | externalOp n [] | n == sUN "prim__null" = "0"
140 | externalOp n [x, y] | n == sUN "prim__eqPtr" = call "eqv?" [compileVar x, compileVar y]
141 | externalOp n [x, y] | n == sUN "prim__eqManagedPtr" = call "eq?" [car (compileVar x), car (compileVar y)]
142 | -- TODO: Fix managed pointers
143 | externalOp n [x, y] | n == sUN "prim__registerPtr" = compileVar x
144 | externalOp n [_, x, y] | n == sUN "prim__peek8" = call "foreign-ref" ["'unsigned-8", compileVar x, compileVar y]
145 | externalOp n [_, x, y, z] | n == sUN "prim__poke8" = call "foreign-set!" ["'unsigned-8", compileVar x, compileVar y, compileVar z]
146 | externalOp n [_, x, y] | n == sUN "prim__peek16" = call "foreign-ref" ["'unsigned-16", compileVar x, compileVar y]
147 | externalOp n [_, x, y, z] | n == sUN "prim__poke16" = call "foreign-set!" ["'unsigned-16", compileVar x, compileVar y, compileVar z]
148 | externalOp n [_, x, y] | n == sUN "prim__peek32" = call "foreign-ref" ["'unsigned-32", compileVar x, compileVar y]
149 | externalOp n [_, x, y, z] | n == sUN "prim__poke32" = call "foreign-set!" ["'unsigned-32", compileVar x, compileVar y, compileVar z]
150 | externalOp n [_, x, y] | n == sUN "prim__peek64" = call "foreign-ref" ["'unsigned-64", compileVar x, compileVar y]
151 | externalOp n [_, x, y, z] | n == sUN "prim__poke64" = call "foreign-set!" ["'unsigned-64", compileVar x, compileVar y, compileVar z]
152 | externalOp n [_, x, y] | n == sUN "prim__peekPtr" = call "foreign-ref" ["'void*", compileVar x, compileVar y]
153 | externalOp n [_, x, y, z] | n == sUN "prim__pokePtr" = call "foreign-set!" ["'void*", compileVar x, compileVar y, compileVar z]
154 | externalOp n [_, x, y] | n == sUN "prim__peekSingle" = call "foreign-ref" ["'float", compileVar x, compileVar y]
155 | externalOp n [_, x, y, z] | n == sUN "prim__pokeSingle" = call "foreign-set!" ["'float", compileVar x, compileVar y, compileVar z]
156 | externalOp n [_, x, y] | n == sUN "prim__peekDouble" = call "foreign-ref" ["'double", compileVar x, compileVar y]
157 | externalOp n [_, x, y, z] | n == sUN "prim__pokeDouble" = call "foreign-set!" ["'double", compileVar x, compileVar y, compileVar z]
158 | 
159 | -- TODO: Fix managed pointers
160 | externalOp n [x] | n == sUN "prim__asPtr" = call "car" [compileVar x]
161 | externalOp n [] | n == sUN "prim__sizeofPtr" = call "foreign-sizeof" ["'void*"]
162 | externalOp n [x, y] | n == sUN "prim__ptrOffset" = call "+" [compileVar x, compileVar y]
163 | 
164 | externalOp n _ = call "error" [sstr "idris", sstr $ "Unimplemented external primitive " ++ show n]
165 | 


--------------------------------------------------------------------------------
/src/Chez/Util.hs:
--------------------------------------------------------------------------------
  1 | -- Common utility functions
  2 | 
  3 | module Chez.Util where
  4 | 
  5 | import Idris.Core.TT
  6 | 
  7 | import IRTS.Lang
  8 | 
  9 | import Data.Char
 10 | import Data.List
 11 | 
 12 | import Numeric (showHex)
 13 | 
 14 | 
 15 | compileVar :: LVar -> String
 16 | compileVar (Loc i) = loc i
 17 | compileVar (Glob n) = sname n
 18 | 
 19 | compileVars = map compileVar
 20 | 
 21 | -- Size of numbers
 22 | width (ITFixed IT8) = 8
 23 | width (ITFixed IT16) = 16
 24 | width (ITFixed IT32) = 32
 25 | width (ITFixed IT64) = 64
 26 | width ITNative = 64
 27 | width ITChar = 32
 28 | 
 29 | range ty = show $ 2^(width ty)
 30 | full ty = show (2^(width ty) - 1)
 31 | 
 32 | halfrange ty = show $ 2^(width ty-1)
 33 | 
 34 | 
 35 | -- Output Helpers
 36 | --
 37 | -- Implementing a Scheme pretty printer is hard, and there are plenty of
 38 | -- them out there, so don't bother to do nice output.
 39 | sname :: Name -> String
 40 | sname n = "|" ++ map legalize (showCG n) ++ "|"
 41 |     where
 42 |         legalize '#' = '\xa4'
 43 |         legalize '|' = '\xa6'
 44 |         legalize x = x
 45 | 
 46 | loc i = "v" ++ show i
 47 | 
 48 | sexp xs = "(" ++ intercalate " " xs ++ ")" 
 49 | defineFun name args body = sexp ["define", sexp (name:args), body] ++ "\n\n"
 50 | call f args = sexp (f:args)
 51 | 
 52 | slet n exp body = sexp ["let", sexp [sexp [n, exp]], body]
 53 | sset n exp = call "set!" [n, exp]
 54 | cond xs = sexp ("cond":xs)
 55 | car l = call "car" [l]
 56 | cdr l = call "cdr" [l]
 57 | lambda args body = sexp ["lambda", sexp args, body]
 58 | apply f l = call "apply" [f, l]
 59 | quote s = "'" ++ s
 60 | 
 61 | -- Scheme predicates return #t and #f and Idris
 62 | -- expects 1 and 0. Fix it up.
 63 | predicate p = call "if" [p, "1", "0"] 
 64 | 
 65 | cmp f args = predicate $ op f args
 66 | 
 67 | ucmp ty f args = predicate $ call f (map (makeUnsigned ty . compileVar) args) 
 68 | 
 69 | op f args = call f (compileVars args)
 70 | 
 71 | charOp o args = call "integer->char" [call o (map charToInt args)]
 72 | 
 73 | charShift True o [x, y] = call "integer->char" 
 74 |                             [call "and"
 75 |                               [call o [charToInt x, compileVar y]], full ITChar]
 76 | charShift False o [x, y] = call "integer->char" [call o [charToInt x, compileVar y]]
 77 | charToInt x = call "char->integer" [compileVar x]
 78 | 
 79 | clamp :: IntTy -> String -> String
 80 | clamp ITBig o = o
 81 | clamp ty@(ITFixed _) o = call "modulo" [o, range ty]
 82 | clamp it o = call "-" [call "modulo" [call "+" [halfrange it, o], range it], halfrange it]
 83 | 
 84 | -- Convert negative numbers to two-complements positive
 85 | -- TODO: take string instead of LVar
 86 | makeUnsigned :: IntTy -> String -> String
 87 | -- TODO: ITBig doesn't really make sense here
 88 | makeUnsigned ITBig x = x
 89 | makeUnsigned ty x = slet "n" x (call "if" [call "negative?" ["n"],
 90 |                                 call "+" ["n", range ty],"n"])
 91 | 
 92 | makeSigned :: IntTy -> String -> String
 93 | makeSigned ty o = slet "n" o (call "if" [call ">" ["n", halfrange ty],
 94 |                                 call "-" ["n", range ty], "n"])
 95 | 
 96 | sstr = schemeString 
 97 | -- Translate a string literal to Scheme format
 98 | -- Let's make it easy for us and render everything
 99 | -- outside printable ascii stuff as unicode escapes
100 | schemeString :: String -> String
101 | schemeString s = "\"" ++ sift s ++ "\""
102 |     where
103 |         sift "" = ""
104 |         sift ('\\':cs) = "\\\\" ++ sift cs
105 |         sift ('"':cs) = "\\\"" ++ sift cs
106 |         sift (c:cs) | isAscii c && isPrint c = c:sift cs
107 |         sift (c:cs) = "\\x" ++ showHex (ord c) "" ++ ";" ++ sift cs
108 | 
109 | schemeChar :: Char -> String
110 | schemeChar c = "#\\x" ++ showHex (ord c) "" ++ " "
111 | 
112 | -- deconstruct FDesc to FType and, FType to Chez cffi types.
113 | 
114 | ffiType = toChezCType . toFType
115 | 
116 | toFType :: FDesc -> FType
117 | toFType (FCon c)
118 |     | c == sUN "C_Str" = FString
119 |     | c == sUN "C_Float" = FArith ATFloat
120 |     | c == sUN "C_Ptr" = FPtr
121 |     | c == sUN "C_MPtr" = FManagedPtr
122 |     | c == sUN "C_CData" = FCData
123 |     | c == sUN "C_Unit" = FUnit
124 | toFType (FApp c [_,ity])
125 |     | c == sUN "C_IntT" = FArith (toAType ity)
126 |     | c == sUN "C_FnT" = toFunType ity
127 | toFType (FApp c [_])
128 |     | c == sUN "C_Any" = FAny
129 | toFType t = FAny
130 | 
131 | toAType (FCon i)
132 |     | i == sUN "C_IntChar" = ATInt ITChar
133 |     | i == sUN "C_IntNative" = ATInt ITNative
134 |     | i == sUN "C_IntBits8" = ATInt (ITFixed IT8)
135 |     | i == sUN "C_IntBits16" = ATInt (ITFixed IT16)
136 |     | i == sUN "C_IntBits32" = ATInt (ITFixed IT32)
137 |     | i == sUN "C_IntBits64" = ATInt (ITFixed IT64)
138 | toAType t = error (show t ++ " not defined in toAType")
139 | 
140 | toFunType (FApp c [_,ity])
141 |     | c == sUN "C_FnBase" = FFunction
142 |     | c == sUN "C_FnIO" = FFunctionIO
143 | toFunType (FApp c [_,_,_,ity])
144 |     | c == sUN "C_Fn" = toFunType ity
145 | toFunType _ = FAny
146 | 
147 | toChezCType :: FType -> String
148 | toChezCType FString = "utf-8"
149 | toChezCType FPtr = "void*"
150 | toChezCType FManagedPtr = "void*"
151 | toChezCType FCData = "void*"
152 | toChezCType FUnit = "void"
153 | toChezCType FAny = "void*"
154 | toChezCType (FArith ATFloat) = "double"
155 | toChezCType (FArith (ATInt ITChar)) = "wchar_t"
156 | toChezCType (FArith (ATInt ITNative)) = "int"
157 | toChezCType (FArith (ATInt (ITFixed IT8))) = "unsigned-8"
158 | toChezCType (FArith (ATInt (ITFixed IT16))) = "unsigned-16"
159 | toChezCType (FArith (ATInt (ITFixed IT32))) = "unsigned-32"
160 | toChezCType (FArith (ATInt (ITFixed IT64))) = "unsigned-64"
161 | toChezCType _ = "void*"
162 | 
163 | isCType (FCon c) = head (showCG c) == 'C'   
164 | isCType (FApp c x) = head (showCG c) == 'C'
165 | 
166 | isFunction fd = case toFType fd of
167 |     FFunction -> True
168 |     FFunctionIO -> True
169 |     _ -> False
170 | 
171 | getSignature :: FDesc -> (String, [String])
172 | getSignature desc = (fst $ rty desc, map fst $ args desc)
173 |     where
174 |         rty (FApp c [_,ty])
175 |             | c == sUN "C_FnBase" = (ffiType ty, ty)
176 |             | c == sUN "C_FnIO" = (ffiType ty, ty)
177 |             | c == sUN "C_FnT" = rty ty
178 |         rty (FApp c [_,_,ty,fn])
179 |             | c == sUN "C_Fn" = rty fn
180 |         rty x = ("", x)
181 |         args (FApp c [_,ty])
182 |             | c == sUN "C_FnBase" = []
183 |             | c == sUN "C_FnIO" = []
184 |             | c == sUN "C_FnT" = args ty
185 |         args (FApp c [_,_,ty,fn])
186 |             | toFType ty == FUnit = []
187 |             | c == sUN "C_Fn" = (ffiType ty, ty) : args fn
188 |         args _ = []
189 | 
190 | -- Scheme ffi types
191 | 


--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
 1 | module Main where
 2 | 
 3 | import Idris.Core.TT
 4 | import Idris.AbsSyntax
 5 | import Idris.ElabDecls
 6 | import Idris.REPL
 7 | import Idris.Options
 8 | import Idris.Main
 9 | 
10 | import IRTS.CodegenCommon
11 | import IRTS.Compiler
12 | 
13 | import Chez.Codegen
14 | 
15 | import System.Environment
16 | import System.Exit
17 | 
18 | import Paths_idris_chez
19 | 
20 | data Opts = Opts { inputs :: [FilePath],
21 |                    output :: FilePath,
22 |                    outTy :: OutputType }
23 | 
24 | showUsage = do putStrLn "Usage: idris-codegen-chez <ibc-files> [-o <output-file>]"
25 |                exitWith ExitSuccess
26 | 
27 | getOpts :: IO Opts
28 | getOpts = do xs <- getArgs
29 |              return $ process (Opts [] "a.ss" Executable) xs
30 |   where
31 |     process opts ("-o":o:xs) = process (opts { output = o }) xs
32 |     process opts ("-S":xs) = process (opts { outTy = Raw }) xs
33 |     process opts ("-c":xs) = process (opts { outTy = Object }) xs
34 |     process opts (x:xs) = process (opts { inputs = x:inputs opts }) xs
35 |     process opts [] = opts
36 | 
37 | build :: Opts -> Idris ()
38 | build opts = do elabPrims
39 |                 loadInputs (inputs opts) Nothing
40 |                 mainProg <- elabMain
41 |                 ir <- compile (Via IBCFormat "chez") (output opts) (Just mainProg)
42 |                 runIO $ codegenChez (ir { outputType = outTy opts })
43 | 
44 | main :: IO ()
45 | main = do opts <- getOpts
46 |           if null (inputs opts)
47 |              then showUsage
48 |              else runMain (build opts)
49 | 


--------------------------------------------------------------------------------
/test/runtest.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE CPP #-}
  2 | module Main where
  3 | 
  4 | import Control.Monad
  5 | import Data.Char
  6 | import Data.List
  7 | import Data.Maybe
  8 | import qualified Data.Set as S
  9 | import Data.Time.Clock
 10 | import System.Directory
 11 | import System.Environment
 12 | import System.FilePath
 13 | import System.Exit
 14 | import System.Info
 15 | import System.IO
 16 | import System.Process
 17 | 
 18 | -- Because GHC earlier than 7.8 lacks setEnv
 19 | -- Install the setenv package on Windows.
 20 | #if __GLASGOW_HASKELL__ < 708
 21 | #ifndef mingw32_HOST_OS
 22 | import qualified System.Posix.Env as PE(setEnv)
 23 | 
 24 | setEnv k v = PE.setEnv k v True
 25 | #else
 26 | import System.SetEnv(setEnv)
 27 | #endif
 28 | #endif
 29 | 
 30 | data Flag = Update | Diff | ShowOutput | Quiet | Time deriving (Eq, Show, Ord)
 31 | 
 32 | type Flags = S.Set Flag
 33 | 
 34 | data Status = Success | Failure | Updated deriving (Eq, Show)
 35 | 
 36 | data Config = Config {
 37 |     flags :: Flags,
 38 |     idrOpts :: [String],
 39 |     tests :: [String]
 40 | } deriving (Show, Eq)
 41 | 
 42 | isQuiet conf = Quiet `S.member` (flags conf)
 43 | showOutput conf = ShowOutput `S.member` (flags conf)
 44 | showTime conf = Time  `S.member` (flags conf)
 45 | showDiff conf = Diff `S.member` (flags conf)
 46 | doUpdate conf = Update  `S.member` (flags conf)
 47 | 
 48 | checkTestName :: String -> Bool
 49 | checkTestName d = (all isDigit $ take 3 $ reverse d)
 50 |                     && (not $ isInfixOf "disabled" d)
 51 | 
 52 | enumTests :: IO [String]
 53 | enumTests = do
 54 |     cwd <- getCurrentDirectory
 55 |     dirs <- getDirectoryContents cwd
 56 |     return $ sort $ filter checkTestName dirs
 57 | 
 58 | parseFlag :: String -> Maybe Flag
 59 | parseFlag s = case s of
 60 |     "-u" -> Just Update
 61 |     "-d" -> Just Diff
 62 |     "-s" -> Just ShowOutput
 63 |     "-t" -> Just Time
 64 |     "-q" -> Just Quiet
 65 |     _    -> Nothing
 66 | 
 67 | parseFlags :: [String] -> (S.Set Flag, [String])
 68 | parseFlags xs = (S.fromList f, i)
 69 |     where
 70 |         f = catMaybes $ map parseFlag fl
 71 |         (fl, i) = partition (\s -> parseFlag s /= Nothing) xs
 72 | 
 73 | parseArgs :: [String] -> IO Config
 74 | parseArgs args = do
 75 |     (tests, rest) <- case args of
 76 |         ("all":xs) -> do
 77 |             et <- enumTests
 78 |             return (et, xs)
 79 |         ("without":xs) -> do
 80 |             t <- enumTests
 81 |             (blacklist, ys) <- return $ break (== "opts") xs
 82 |             return (t \\ blacklist, ys \\ ["opts"])
 83 |         (x:xs) -> do
 84 |             exists <- doesDirectoryExist x
 85 |             return (if checkTestName x && exists then [x] else [], xs)
 86 |         [] -> do
 87 |             et <- enumTests
 88 |             return (et, [])
 89 |     let (testOpts, idOpts) = parseFlags rest
 90 |     return $ Config testOpts (idOpts++["--codegen", "chez"]) tests
 91 | 
 92 | -- "bash" needed because Haskell has cmd as the default shell on windows, and
 93 | -- we also want to run the process with another current directory, so we get
 94 | -- this thing.
 95 | runInShell :: String -> [String] -> IO (ExitCode, String)
 96 | runInShell test opts = do
 97 |     (ec, output, _) <- readCreateProcessWithExitCode
 98 |                             ((proc "bash" ("run":opts)) { cwd = Just test,
 99 |                                                           std_out = CreatePipe })
100 |                             ""
101 |     return (ec, output)
102 | 
103 | runTest :: Config -> String -> IO Status
104 | runTest conf test = do
105 |     -- don't touch the current directory as we want to run these things
106 |     -- in parallel in the future
107 |     let inTest s = test ++ "/" ++ s
108 |     t1 <- getCurrentTime
109 |     (exitCode, output) <- runInShell test (idrOpts conf)
110 |     t2 <- getCurrentTime
111 |     expected <- readFile $ inTest "expected"
112 |     writeFile (inTest "output") output
113 |     res <- if (norm output == norm expected)
114 |                 then do putStrLn $ test ++ " finished...success"
115 |                         return Success
116 |                 else if doUpdate conf
117 |                     then do putStrLn $ test ++ " finished...UPDATE"
118 |                             writeFile (inTest "expected") output
119 |                             return Updated
120 |                     else do putStrLn $ test ++ " finished...FAILURE"
121 |                             _ <- rawSystem "diff" [inTest "output", inTest "expected"]
122 |                             return Failure
123 |     when (showTime conf) $ do
124 |         let dt = diffUTCTime t2 t1
125 |         putStrLn $ "Duration of " ++ test ++ " was " ++ show dt
126 |     return res
127 |   where 
128 |     -- just pretend that backslashes are slashes for comparison
129 |     -- purposes to avoid path problems, so don't write any tests
130 |     -- that depend on that distinction in other contexts.
131 |     -- Also rewrite newlines for consistency.
132 |        norm ('\r':'\n':xs) = '\n' : norm xs
133 |        norm ('\\':'\\':xs) = '/' : norm xs
134 |        norm ('\\':xs) = '/' : norm xs
135 |        norm (x : xs) = x : norm xs
136 |        norm [] = []
137 | 
138 | printStats :: Config -> [Status] -> IO ()
139 | printStats conf stats = do
140 |     let total = length stats
141 |     let successful = length $ filter (== Success) stats
142 |     let failures = length $ filter (== Failure) stats
143 |     let updates = length $ filter (== Updated) stats
144 |     putStrLn "\n----"
145 |     putStrLn $ show total ++ " tests run: " ++ show successful ++ " succesful, "
146 |                 ++ show failures ++ " failed, " ++ show updates ++ " updated."
147 |     let failed = map fst $ filter ((== Failure) . snd) $ zip (tests conf) stats
148 |     when (failed /= []) $ do
149 |         putStrLn "\nFailed tests:"
150 |         mapM_ putStrLn failed
151 |         putStrLn ""
152 | 
153 | runTests :: Config -> IO Bool
154 | runTests conf = do
155 |     stats <- mapM (runTest conf) (tests conf)
156 |     unless (isQuiet conf) $ printStats conf stats
157 |     return $ all (== Success) stats
158 | 
159 | runShow :: Config -> IO Bool
160 | runShow conf = do
161 |     mapM_ (\t -> callProcess "cat" [t++"/output"]) (tests conf)
162 |     return True
163 | 
164 | runDiff :: Config -> IO Bool
165 | runDiff conf = do
166 |     mapM_ (\t -> do putStrLn $ "Differences in " ++ t ++ ":"
167 |                     ec <- rawSystem "diff" [t++"/output", t++"/expected"]
168 |                     when (ec == ExitSuccess) $ putStrLn "No differences found.")
169 |           (tests conf)
170 |     return True
171 | 
172 | whisper :: Config -> String -> IO ()
173 | whisper conf s = do unless (isQuiet conf) $ putStrLn s
174 | 
175 | isWindows :: Bool
176 | isWindows = os `elem` ["win32", "mingw32", "cygwin32"]
177 | 
178 | setPath :: Config -> IO ()
179 | setPath conf = do
180 |     maybeEnv <- lookupEnv "IDRIS"
181 |     idrisExists <- case maybeEnv of
182 |         Just idrisExe -> do
183 |             let exeExtension = if isWindows then ".exe" else ""
184 |             doesFileExist (idrisExe ++ exeExtension)
185 |         Nothing -> return False
186 |     if (idrisExists)
187 |         then do
188 |             idrisAbs <- makeAbsolute $ fromMaybe "" maybeEnv
189 |             setEnv "IDRIS" idrisAbs
190 |             whisper conf $ "Using " ++ idrisAbs
191 |         else do
192 |             path <- getEnv "PATH"
193 |             setEnv "IDRIS" ""
194 |             let sandbox = "../.cabal-sandbox/bin"
195 |             hasBox <- doesDirectoryExist sandbox
196 |             bindir <- if hasBox
197 |                             then do
198 |                                 whisper conf $ "Using Cabal sandbox at " ++ sandbox
199 |                                 makeAbsolute sandbox
200 |                             else do
201 |                                 stackExe <- findExecutable "stack"
202 |                                 case stackExe of
203 |                                     Just stack -> do
204 |                                         out <- readProcess stack ["path", "--dist-dir"] []
205 |                                         stackDistDir <- return $ takeWhile (/= '\n') out
206 |                                         let stackDir = "../" ++ stackDistDir ++ "/build/idris"
207 |                                         whisper conf $ "Using stack work dir at " ++ stackDir
208 |                                         makeAbsolute stackDir
209 |                                     Nothing -> return ""
210 |             when (bindir /= "") $ setEnv "PATH" (bindir ++ [searchPathSeparator] ++ path)
211 | 
212 | main = do
213 |     hSetBuffering stdout LineBuffering
214 |     withCabal <- doesDirectoryExist "test"
215 |     when withCabal $ do
216 |       setCurrentDirectory "test"
217 |     args <- getArgs
218 |     conf <- parseArgs args
219 |     -- setPath conf
220 |     t1 <- getCurrentTime
221 |     res <- case tests conf of
222 |                 [] -> return True
223 |                 xs | showOutput conf -> runShow conf
224 |                 xs | showDiff conf -> runDiff conf
225 |                 xs -> runTests conf
226 |     t2 <- getCurrentTime
227 |     when (showTime conf) $ do
228 |         let dt = diffUTCTime t2 t1
229 |         putStrLn $ "Duration of Entire Test Suite was " ++ show dt
230 |     unless res exitFailure
231 | 


--------------------------------------------------------------------------------
/test/samples/loadshared.idr:
--------------------------------------------------------------------------------
 1 | module Main
 2 | 
 3 | -- Yeah, this is for windows only 
 4 | %lib chez "kernel32"
 5 | 
 6 | %include chez "(display \"beep\")"
 7 | 
 8 | beep : Int -> Int -> IO Int
 9 | beep freq dur = foreign FFI_C "Beep" (Int -> Int -> IO Int) freq dur
10 | 
11 | main : IO ()
12 | main = do
13 |     ok <- beep 1000 1000
14 |     print ok


--------------------------------------------------------------------------------
/test/samples/scheme.idr:
--------------------------------------------------------------------------------
 1 | module Main
 2 | 
 3 | import Chez
 4 | 
 5 | display : String -> SIO ()
 6 | display s = foreign FFI_S "display" (String -> SIO ()) s
 7 | 
 8 | displayBool : Bool -> SIO ()
 9 | displayBool b = foreign FFI_S "display" (Bool -> SIO ()) b
10 | 
11 | schemeEqual : Int -> Int -> SIO Bool
12 | schemeEqual x y = foreign FFI_S "=" (Int -> Int -> SIO Bool) x y
13 | 
14 | main : SIO ()
15 | main = do
16 |     display "O RLY?"
17 |     displayBool True
18 |     a <-  schemeEqual 1 2
19 |     displayBool a


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