mirror of
https://github.com/edwinb/Idris2-boot.git
synced 2024-09-20 04:17:38 +03:00
Add getChar, putChar and putCharLn to prelude
This commit is contained in:
parent
0e98f6383f
commit
c8c0c5fb49
@ -36,6 +36,8 @@ io_bind (MkIO fn)
|
||||
|
||||
%extern prim__putStr : String -> (1 x : %World) -> IORes ()
|
||||
%extern prim__getStr : (1 x : %World) -> IORes String
|
||||
%extern prim__putChar : Char -> (1 x : %World) -> IORes ()
|
||||
%extern prim__getChar : (1 x : %World) -> IORes Char
|
||||
|
||||
-- A pointer representing a given parameter type
|
||||
-- The parameter is a phantom type, to help differentiate between
|
||||
@ -76,25 +78,43 @@ export %inline
|
||||
cCall : (ret : Type) -> String -> FArgList -> IO ret
|
||||
cCall ret fn args = primIO (prim__cCall ret fn args)
|
||||
|
||||
||| Output a string to stdout without a trailing newline
|
||||
export
|
||||
putStr : String -> IO ()
|
||||
putStr str = primIO (prim__putStr str)
|
||||
|
||||
||| Output a string to stdout with a trailing newline
|
||||
export
|
||||
putStrLn : String -> IO ()
|
||||
putStrLn str = putStr (prim__strAppend str "\n")
|
||||
|
||||
||| Read one line of input from stdin, without the trailing newline
|
||||
export
|
||||
getLine : IO String
|
||||
getLine = primIO prim__getStr
|
||||
|
||||
||| Write a single character to stdout
|
||||
export
|
||||
putChar : Char -> IO ()
|
||||
putChar c = primIO (prim__putChar c)
|
||||
|
||||
||| Write a single character to stdout, with a trailing newline
|
||||
export
|
||||
putCharLn : Char -> IO ()
|
||||
putCharLn c = putStrLn (prim__cast_CharString c)
|
||||
|
||||
||| Read a single character from stdin
|
||||
export
|
||||
getChar : IO Char
|
||||
getChar = primIO prim__getChar
|
||||
|
||||
export
|
||||
fork : (1 prog : IO ()) -> IO ThreadID
|
||||
fork (MkIO act) = schemeCall ThreadID "blodwen-thread" [act]
|
||||
|
||||
export
|
||||
prim_fork : (1 prog : PrimIO ()) -> PrimIO ThreadID
|
||||
prim_fork act w = prim__schemeCall ThreadID "blodwen-thread" [act] w
|
||||
prim_fork act w = prim__schemeCall ThreadID "blodwen-thread" [act] w
|
||||
|
||||
unsafeCreateWorld : (1 f : (1 x : %World) -> a) -> a
|
||||
unsafeCreateWorld f = f %MkWorld
|
||||
|
@ -157,7 +157,8 @@ schOp BelieveMe [_,_,x] = x
|
||||
|
||||
||| Extended primitives for the scheme backend, outside the standard set of primFn
|
||||
public export
|
||||
data ExtPrim = CCall | SchemeCall | PutStr | GetStr
|
||||
data ExtPrim = CCall | SchemeCall
|
||||
| PutStr | GetStr | PutChar | GetChar
|
||||
| FileOpen | FileClose | FileReadLine | FileWriteLine | FileEOF
|
||||
| NewIORef | ReadIORef | WriteIORef
|
||||
| NewArray | ArrayGet | ArraySet
|
||||
@ -173,6 +174,8 @@ Show ExtPrim where
|
||||
show SchemeCall = "SchemeCall"
|
||||
show PutStr = "PutStr"
|
||||
show GetStr = "GetStr"
|
||||
show PutChar = "PutChar"
|
||||
show GetChar = "GetChar"
|
||||
show FileOpen = "FileOpen"
|
||||
show FileClose = "FileClose"
|
||||
show FileReadLine = "FileReadLine"
|
||||
@ -201,6 +204,8 @@ toPrim pn@(NS _ n)
|
||||
(n == UN "prim__cCall", CCall),
|
||||
(n == UN "prim__putStr", PutStr),
|
||||
(n == UN "prim__getStr", GetStr),
|
||||
(n == UN "prim__putChar", PutChar),
|
||||
(n == UN "prim__getChar", GetChar),
|
||||
(n == UN "prim__open", FileOpen),
|
||||
(n == UN "prim__close", FileClose),
|
||||
(n == UN "prim__readLine", FileReadLine),
|
||||
@ -341,6 +346,10 @@ parameters (schExtPrim : {vars : _} -> Int -> SVars vars -> ExtPrim -> List (CEx
|
||||
= pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
|
||||
schExtCommon i vs GetStr [world]
|
||||
= pure $ mkWorld "(blodwen-get-line (current-input-port))"
|
||||
schExtCommon i vs PutChar [arg, world]
|
||||
= pure $ "(display " ++ !(schExp i vs arg) ++ ") " ++ mkWorld (schConstructor 0 []) -- code for MkUnit
|
||||
schExtCommon i vs GetChar [world]
|
||||
= pure $ mkWorld "(blodwen-get-char (current-input-port))"
|
||||
schExtCommon i vs FileOpen [file, mode, bin, world]
|
||||
= pure $ mkWorld $ fileOp $ "(blodwen-open "
|
||||
++ !(schExp i vs file) ++ " "
|
||||
|
@ -14,8 +14,8 @@
|
||||
(define blodwen-or (lambda (x y) (logor x y)))
|
||||
(define blodwen-xor (lambda (x y) (logxor x y)))
|
||||
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(if (number? x) x 0)))
|
||||
(define destroy-prefix
|
||||
(lambda (x)
|
||||
@ -30,14 +30,14 @@
|
||||
(define get-tag (lambda (x) (vector-ref x 0)))
|
||||
(define string-reverse (lambda (x)
|
||||
(list->string (reverse (string->list x)))))
|
||||
(define (string-substr off len s)
|
||||
(define (string-substr off len s)
|
||||
(let* ((l (string-length s))
|
||||
(b (max 0 off))
|
||||
(x (max 0 len))
|
||||
(end (min l (+ b x))))
|
||||
(substring s b end)))
|
||||
|
||||
(define either-left
|
||||
(define either-left
|
||||
(lambda (x)
|
||||
(vector 0 #f #f x)))
|
||||
|
||||
@ -109,10 +109,10 @@
|
||||
;; Files: Much of the following adapted from idris-chez, thanks to Niklas
|
||||
;; Larsson
|
||||
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; Either Int x, where the Int is an error code:
|
||||
(define (blodwen-error-code x)
|
||||
(cond
|
||||
(cond
|
||||
((i/o-read-error? x) 1)
|
||||
((i/o-write-error? x) 2)
|
||||
((i/o-file-does-not-exist-error? x) 3)
|
||||
@ -136,7 +136,7 @@
|
||||
(define (blodwen-open file mode bin)
|
||||
(define tc (if (= bin 1) #f (make-transcoder (utf-8-codec))))
|
||||
(define bm (buffer-mode line))
|
||||
(case mode
|
||||
(case mode
|
||||
(("r") (open-file-input-port file (file-options) bm tc))
|
||||
(("w") (open-file-output-port file (file-options no-fail) bm tc))
|
||||
(("wx") (open-file-output-port file (file-options) bm tc))
|
||||
@ -151,11 +151,16 @@
|
||||
(when (port? p) (close-port p)))
|
||||
|
||||
(define (blodwen-get-line p)
|
||||
(if (and (port? p) (not (port-eof? p)))
|
||||
(if (and (port? p) (not (port-eof? p)))
|
||||
(let ((str (get-line p)))
|
||||
(string-append str "\n"))
|
||||
""))
|
||||
|
||||
(define (blodwen-get-char p)
|
||||
(if (and (port? p) (not (port-eof? p)))
|
||||
(get-char p)
|
||||
#\nul))
|
||||
|
||||
(define (blodwen-file-size p)
|
||||
(port-length p))
|
||||
|
||||
@ -216,7 +221,7 @@
|
||||
(define (blodwen-condition-broadcast c) (condition-broadcast c))
|
||||
|
||||
(define (blodwen-sleep s) (sleep (make-time 'time-duration 0 s)))
|
||||
(define (blodwen-usleep s)
|
||||
(define (blodwen-usleep s)
|
||||
(let ((sec (div s 1000000))
|
||||
(micro (mod s 1000000)))
|
||||
(sleep (make-time 'time-duration (* 1000 micro) sec))))
|
||||
|
@ -14,8 +14,8 @@
|
||||
(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)
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(if (number? x) x 0)))
|
||||
(define destroy-prefix
|
||||
(lambda (x)
|
||||
@ -30,14 +30,14 @@
|
||||
(define get-tag (lambda (x) (vector-ref x 0)))
|
||||
(define string-reverse (lambda (x)
|
||||
(list->string (reverse (string->list x)))))
|
||||
(define (string-substr off len s)
|
||||
(define (string-substr off len s)
|
||||
(let* ((l (string-length s))
|
||||
(b (max 0 off))
|
||||
(x (max 0 len))
|
||||
(end (min l (+ b x))))
|
||||
(substring s b end)))
|
||||
|
||||
(define either-left
|
||||
(define either-left
|
||||
(lambda (x)
|
||||
(vector 0 #f #f x)))
|
||||
|
||||
@ -54,7 +54,7 @@
|
||||
;; Files: Much of the following adapted from idris-chez, thanks to Niklas
|
||||
;; Larsson
|
||||
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; Either Int x, where the Int is an error code
|
||||
|
||||
;; If the file operation raises an error, catch it and return an appropriate
|
||||
@ -72,13 +72,13 @@
|
||||
0)
|
||||
|
||||
(define (blodwen-open file mode bin)
|
||||
(cond
|
||||
(cond
|
||||
((string=? mode "r") (open-input-file file))
|
||||
((string=? mode "w") (open-output-file file))
|
||||
(else (abort "I haven't worked that one out yet, sorry..."))))
|
||||
|
||||
(define (blodwen-close-port p)
|
||||
(cond
|
||||
(cond
|
||||
((input-port? p) (close-input-port p))
|
||||
((output-port? p) (close-output-port p))))
|
||||
|
||||
@ -90,6 +90,14 @@
|
||||
(string-append str "\n")))
|
||||
void))
|
||||
|
||||
(define (blodwen-get-char p)
|
||||
(if (port? p)
|
||||
(let ((char (read-char p)))
|
||||
(if (eof-object? char)
|
||||
#\nul
|
||||
char))
|
||||
void))
|
||||
|
||||
(define (blodwen-eof p)
|
||||
(if (eof-object? (peek-char p))
|
||||
1
|
||||
@ -112,7 +120,7 @@
|
||||
(define (blodwen-thisthread) (current-thread))
|
||||
|
||||
(define (blodwen-condition) (make-condition-variable))
|
||||
(define (blodwen-condition-wait c m)
|
||||
(define (blodwen-condition-wait c m)
|
||||
(mutex-unlock! m c)
|
||||
(mutex-lock! m)) ;; lock again, for consistency with other CGs
|
||||
(define (blodwen-condition-wait-timeout c m t) (mutex-unlock! m c t))
|
||||
|
@ -14,8 +14,8 @@
|
||||
(define blodwen-or (lambda (x y) (bitwise-ior x y)))
|
||||
(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
|
||||
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(define cast-num
|
||||
(lambda (x)
|
||||
(if (number? x) x 0)))
|
||||
(define destroy-prefix
|
||||
(lambda (x)
|
||||
@ -30,14 +30,14 @@
|
||||
(define get-tag (lambda (x) (vector-ref x 0)))
|
||||
(define string-reverse (lambda (x)
|
||||
(list->string (reverse (string->list x)))))
|
||||
(define (string-substr off len s)
|
||||
(define (string-substr off len s)
|
||||
(let* ((l (string-length s))
|
||||
(b (max 0 off))
|
||||
(x (max 0 len))
|
||||
(end (min l (+ b x))))
|
||||
(substring s b end)))
|
||||
|
||||
(define either-left
|
||||
(define either-left
|
||||
(lambda (x)
|
||||
(vector 0 #f #f x)))
|
||||
|
||||
@ -111,10 +111,10 @@
|
||||
;; Files : Much of the following adapted from idris-chez, thanks to Niklas
|
||||
;; Larsson
|
||||
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; All the file operations are implemented as primitives which return
|
||||
;; Either Int x, where the Int is an error code
|
||||
(define (blodwen-error-code x)
|
||||
(cond
|
||||
(cond
|
||||
((eq? x (lookup-errno 'ENOENT)) 3)
|
||||
((eq? x (lookup-errno 'EACCES)) 4)
|
||||
((eq? x (lookup-errno 'EEXIST)) 5)
|
||||
@ -123,11 +123,11 @@
|
||||
;; If the file operation raises an error, catch it and return an appropriate
|
||||
;; error code
|
||||
(define (blodwen-file-op op)
|
||||
(with-handlers
|
||||
(with-handlers
|
||||
([exn:fail:filesystem:errno?
|
||||
(lambda (exn) (either-left (blodwen-error-code
|
||||
(car (exn:fail:filesystem:errno-errno exn)))))]
|
||||
[exn:fail:filesystem?
|
||||
[exn:fail:filesystem?
|
||||
(lambda (exn) (either-left 255))]
|
||||
)
|
||||
(either-right (op))))
|
||||
@ -139,7 +139,7 @@
|
||||
(define (blodwen-open file mode bin)
|
||||
(define tc (if (= bin 1) #f (make-transcoder (utf-8-codec))))
|
||||
(define bm (buffer-mode line))
|
||||
(case mode
|
||||
(case mode
|
||||
(("r") (open-file-input-port file (file-options) bm tc))
|
||||
(("w") (open-file-output-port file (file-options no-fail) bm tc))
|
||||
(("wx") (open-file-output-port file (file-options) bm tc))
|
||||
@ -152,7 +152,7 @@
|
||||
|
||||
|
||||
(define (blodwen-close-port p)
|
||||
(cond
|
||||
(cond
|
||||
((input-port? p) (close-input-port p))
|
||||
((output-port? p) (close-output-port p))))
|
||||
|
||||
@ -164,6 +164,14 @@
|
||||
(string-append str "\n")))
|
||||
void))
|
||||
|
||||
(define (blodwen-get-char p)
|
||||
(if (port? p)
|
||||
(let ((char (read-char p)))
|
||||
(if (eof-object? char)
|
||||
#\nul
|
||||
char))
|
||||
void))
|
||||
|
||||
(define (blodwen-eof p)
|
||||
(if (eof-object? (peek-char p))
|
||||
1
|
||||
@ -235,6 +243,6 @@
|
||||
(if (null? args)
|
||||
(vector 0 '())
|
||||
(vector 1 '() (car args) (blodwen-build-args (cdr args)))))
|
||||
(blodwen-build-args
|
||||
(blodwen-build-args
|
||||
(cons (path->string (find-system-path 'run-file))
|
||||
(vector->list (current-command-line-arguments)))))
|
||||
|
@ -1,6 +1,6 @@
|
||||
1/1: Building CaseInf (CaseInf.idr)
|
||||
CaseInf.idr:7:24--9:1:While processing right hand side of Main.test3bad at CaseInf.idr:6:1--9:1:
|
||||
While processing right hand side of Main.case block in 1148(179) at CaseInf.idr:7:14--9:1:
|
||||
While processing right hand side of Main.case block in 1153(179) at CaseInf.idr:7:14--9:1:
|
||||
When unifying Integer and Nat
|
||||
Mismatch between:
|
||||
Integer
|
||||
|
Loading…
Reference in New Issue
Block a user