mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-03 00:36:37 +03:00
0a246af449
Meaning that the FFI is aware of it, so you can send arbitrary byte data to foreign calls. Fixes #209 This means that we no longer need the hacky way of reading and writing binary data via scheme, so can have a more general interface for reading and writing buffer data in files. It will also enable more interesting high level interfaces to binary data, with C calls being used where necessary. Note that the Buffer primitive are unsafe! They always have been, of course... so perhaps (later) they should have 'unsafe' as part of their name and better high level safe interfaces on top. This requires updating the scheme to support Buffer as an FFI primitive, but shouldn't affect Idris2-boot which loads buffers its own way.
235 lines
7.1 KiB
Racket
235 lines
7.1 KiB
Racket
(define (blodwen-os)
|
|
(cond
|
|
[(eq? (system-type 'os) 'unix) "unix"]
|
|
[(eq? (system-type 'os) 'osx) "darwin"]
|
|
[(eq? (system-type 'os) 'windows) "windows"]
|
|
[else "unknown"]))
|
|
|
|
(define blodwen-read-args (lambda (desc)
|
|
(case (vector-ref desc 0)
|
|
((0) '())
|
|
((1) (cons (vector-ref desc 2)
|
|
(blodwen-read-args (vector-ref desc 3)))))))
|
|
(define b+ (lambda (x y bits) (remainder (+ x y) (arithmetic-shift 1 bits))))
|
|
(define b- (lambda (x y bits) (remainder (- x y) (arithmetic-shift 1 bits))))
|
|
(define b* (lambda (x y bits) (remainder (* x y) (arithmetic-shift 1 bits))))
|
|
(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (arithmetic-shift 1 bits))))
|
|
|
|
(define integer->bits8 (lambda (x) (modulo x (expt 2 8))))
|
|
(define integer->bits16 (lambda (x) (modulo x (expt 2 16))))
|
|
(define integer->bits32 (lambda (x) (modulo x (expt 2 32))))
|
|
(define integer->bits64 (lambda (x) (modulo x (expt 2 64))))
|
|
|
|
(define blodwen-bits-shl (lambda (x y bits) (remainder (arithmetic-shift x y) (arithmetic-shift 1 bits))))
|
|
(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-ior x y)))
|
|
(define blodwen-xor (lambda (x y) (bitwise-xor x y)))
|
|
|
|
(define cast-num
|
|
(lambda (x)
|
|
(if (number? x) x 0)))
|
|
(define destroy-prefix
|
|
(lambda (x)
|
|
(cond
|
|
((equal? x "") "")
|
|
((equal? (string-ref x 0) #\#) "")
|
|
(else x))))
|
|
(define cast-string-int
|
|
(lambda (x)
|
|
(floor (cast-num (string->number (destroy-prefix x))))))
|
|
(define cast-int-char
|
|
(lambda (x)
|
|
(if (and (>= x 0)
|
|
(<= x #x10ffff))
|
|
(integer->char x)
|
|
0)))
|
|
(define cast-string-double
|
|
(lambda (x)
|
|
(cast-num (string->number (destroy-prefix x)))))
|
|
(define string-cons (lambda (x y) (string-append (string x) y)))
|
|
(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)
|
|
(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
|
|
(lambda (x)
|
|
(vector 0 x)))
|
|
|
|
(define either-right
|
|
(lambda (x)
|
|
(vector 1 x)))
|
|
|
|
(define blodwen-error-quit
|
|
(lambda (msg)
|
|
(display msg)
|
|
(newline)
|
|
(exit 1)))
|
|
|
|
(define (blodwen-get-line p)
|
|
(if (port? p)
|
|
(let ((str (read-line p)))
|
|
(if (eof-object? str)
|
|
""
|
|
str))
|
|
void))
|
|
|
|
(define (blodwen-get-char p)
|
|
(if (port? p)
|
|
(let ((chr (read-char p)))
|
|
(if (eof-object? chr)
|
|
#\nul
|
|
chr))
|
|
void))
|
|
|
|
;; Buffers
|
|
|
|
(define (blodwen-new-buffer size)
|
|
(make-bytevector size 0))
|
|
|
|
(define (blodwen-buffer-size buf)
|
|
(bytevector-length buf))
|
|
|
|
(define (blodwen-buffer-setbyte buf loc val)
|
|
(bytevector-u8-set! buf loc val))
|
|
|
|
(define (blodwen-buffer-getbyte buf loc)
|
|
(bytevector-u8-ref buf loc))
|
|
|
|
(define (blodwen-buffer-setbits16 buf loc val)
|
|
(bytevector-u16-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getbits16 buf loc)
|
|
(bytevector-u16-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-buffer-setbits32 buf loc val)
|
|
(bytevector-u32-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getbits32 buf loc)
|
|
(bytevector-u32-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-buffer-setbits64 buf loc val)
|
|
(bytevector-u64-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getbits64 buf loc)
|
|
(bytevector-u64-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-buffer-setint32 buf loc val)
|
|
(bytevector-s32-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getint32 buf loc)
|
|
(bytevector-s32-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-buffer-setint buf loc val)
|
|
(bytevector-s64-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getint buf loc)
|
|
(bytevector-s64-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-buffer-setdouble buf loc val)
|
|
(bytevector-ieee-double-set! buf loc val (native-endianness)))
|
|
|
|
(define (blodwen-buffer-getdouble buf loc)
|
|
(bytevector-ieee-double-ref buf loc (native-endianness)))
|
|
|
|
(define (blodwen-stringbytelen str)
|
|
(bytevector-length (string->utf8 str)))
|
|
|
|
(define (blodwen-buffer-setstring buf loc val)
|
|
(let* [(strvec (string->utf8 val))
|
|
(len (bytevector-length strvec))]
|
|
(bytevector-copy! strvec 0 buf loc len)))
|
|
|
|
(define (blodwen-buffer-getstring buf loc len)
|
|
(let [(newvec (make-bytevector len))]
|
|
(bytevector-copy! buf loc newvec 0 len)
|
|
(utf8->string newvec)))
|
|
|
|
(define (blodwen-buffer-copydata buf start len dest loc)
|
|
(bytevector-copy! buf start dest loc len))
|
|
|
|
;; Threads
|
|
|
|
(define blodwen-thread-data (make-thread-cell #f))
|
|
|
|
(define (blodwen-thread p)
|
|
(thread (lambda () (p (vector 0)))))
|
|
|
|
(define (blodwen-get-thread-data ty)
|
|
(thread-cell-ref blodwen-thread-data))
|
|
|
|
(define (blodwen-set-thread-data a)
|
|
(thread-cell-set! blodwen-thread-data a))
|
|
|
|
(define (blodwen-mutex) (make-semaphore 1))
|
|
(define (blodwen-lock m) (semaphore-post m))
|
|
(define (blodwen-unlock m) (semaphore-wait m))
|
|
(define (blodwen-thisthread) (current-thread))
|
|
|
|
(define (blodwen-condition) (make-channel))
|
|
(define (blodwen-condition-wait c m)
|
|
(blodwen-unlock m) ;; consistency with interface for posix condition variables
|
|
(sync c)
|
|
(blodwen-lock m))
|
|
(define (blodwen-condition-wait-timeout c m t)
|
|
(blodwen-unlock m) ;; consistency with interface for posix condition variables
|
|
(sync/timeout t c)
|
|
(blodwen-lock m))
|
|
(define (blodwen-condition-signal c)
|
|
(channel-put c 'ready))
|
|
|
|
(define (blodwen-sleep s) (sleep s))
|
|
|
|
(define (blodwen-time) (current-seconds))
|
|
|
|
(define (blodwen-clock-time-utc) (current-time 'time-utc))
|
|
(define (blodwen-clock-time-monotonic) (current-time 'time-monotonic))
|
|
(define (blodwen-clock-time-duration) (current-time 'time-duration))
|
|
(define (blodwen-clock-time-process) (current-time 'time-process))
|
|
(define (blodwen-clock-time-thread) (current-time 'time-thread))
|
|
(define (blodwen-clock-time-gccpu) 0) ;; unsupported
|
|
(define (blodwen-clock-time-gcreal) 0) ;; unsupported
|
|
(define (blodwen-is-time? clk) (if (time? clk) 1 0))
|
|
(define (blodwen-clock-second time) (time-second time))
|
|
(define (blodwen-clock-nanosecond time) (time-nanosecond time))
|
|
|
|
(define (blodwen-args)
|
|
(define (blodwen-build-args args)
|
|
(if (null? args)
|
|
(vector 0) ; Prelude.List
|
|
(vector 1 (car args) (blodwen-build-args (cdr args)))))
|
|
(blodwen-build-args
|
|
(cons (path->string (find-system-path 'run-file))
|
|
(vector->list (current-command-line-arguments)))))
|
|
|
|
(define (blodwen-system cmd)
|
|
(if (system cmd)
|
|
0
|
|
1))
|
|
|
|
;; Randoms
|
|
(random-seed (date*-nanosecond (current-date))) ; initialize random seed
|
|
|
|
(define (blodwen-random-seed s) (random-seed s))
|
|
(define blodwen-random
|
|
(case-lambda
|
|
;; no argument, pick a real value from [0, 1.0)
|
|
[() (random)]
|
|
;; single argument k, pick an integral value from [0, k)
|
|
[(k) (if (> k 0)
|
|
(random k)
|
|
(raise 'blodwen-random-invalid-range-argument))]))
|
|
|
|
;; For finalisers
|
|
|
|
(define (blodwen-register-object obj proc)
|
|
(register-finalizer obj (lambda (ptr) ((proc ptr) 'erased)))
|
|
obj)
|