mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-21 02:31:50 +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.
257 lines
7.7 KiB
Scheme
257 lines
7.7 KiB
Scheme
(define (blodwen-os)
|
|
(case (machine-type)
|
|
[(i3le ti3le a6le ta6le) "unix"]
|
|
[(i3osx ti3osx a6osx ta6osx) "darwin"]
|
|
[(i3nt ti3nt a6nt ta6nt) "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) (ash 1 bits))))
|
|
(define b- (lambda (x y bits) (remainder (- x y) (ash 1 bits))))
|
|
(define b* (lambda (x y bits) (remainder (* x y) (ash 1 bits))))
|
|
(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (ash 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 (ash x y) (ash 1 bits))))
|
|
(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)
|
|
(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 exact-floor
|
|
(lambda (x)
|
|
(inexact->exact (floor x))))
|
|
(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))))
|
|
(if (> b l)
|
|
""
|
|
(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 (get-line p)))
|
|
(if (eof-object? str)
|
|
""
|
|
str))
|
|
void))
|
|
|
|
(define (blodwen-get-char p)
|
|
(if (port? p)
|
|
(let ((chr (get-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-parameter #f))
|
|
|
|
(define (blodwen-thread p)
|
|
(fork-thread (lambda () (p (vector 0)))))
|
|
|
|
(define (blodwen-get-thread-data ty)
|
|
(blodwen-thread-data))
|
|
|
|
(define (blodwen-set-thread-data a)
|
|
(blodwen-thread-data a))
|
|
|
|
(define (blodwen-mutex) (make-mutex))
|
|
(define (blodwen-lock m) (mutex-acquire m))
|
|
(define (blodwen-unlock m) (mutex-release m))
|
|
(define (blodwen-thisthread) (get-thread-id))
|
|
|
|
(define (blodwen-condition) (make-condition))
|
|
(define (blodwen-condition-wait c m) (condition-wait c m))
|
|
(define (blodwen-condition-wait-timeout c m t) (condition-wait c m t))
|
|
(define (blodwen-condition-signal c) (condition-signal c))
|
|
(define (blodwen-condition-broadcast c) (condition-broadcast c))
|
|
|
|
(define (blodwen-sleep s) (sleep (make-time 'time-duration 0 s)))
|
|
(define (blodwen-usleep s)
|
|
(let ((sec (div s 1000000))
|
|
(micro (mod s 1000000)))
|
|
(sleep (make-time 'time-duration (* 1000 micro) sec))))
|
|
|
|
(define (blodwen-time) (time-second (current-time)))
|
|
(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) (current-time 'time-collector-cpu))
|
|
(define (blodwen-clock-time-gcreal) (current-time 'time-collector-real))
|
|
(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 (command-line)))
|
|
|
|
(define (blodwen-hasenv var)
|
|
(if (eq? (getenv var) #f) 0 1))
|
|
|
|
(define (blodwen-system cmd)
|
|
(system cmd))
|
|
|
|
;; Randoms
|
|
(define random-seed-register 0)
|
|
(define (initialize-random-seed-once)
|
|
(if (= (virtual-register random-seed-register) 0)
|
|
(let ([seed (time-nanosecond (current-time))])
|
|
(set-virtual-register! random-seed-register seed)
|
|
(random-seed seed))))
|
|
|
|
(define (blodwen-random-seed seed)
|
|
(set-virtual-register! random-seed-register seed)
|
|
(random-seed seed))
|
|
(define blodwen-random
|
|
(case-lambda
|
|
;; no argument, pick a real value from [0, 1.0)
|
|
[() (begin
|
|
(initialize-random-seed-once)
|
|
(random 1.0))]
|
|
;; single argument k, pick an integral value from [0, k)
|
|
[(k)
|
|
(begin
|
|
(initialize-random-seed-once)
|
|
(if (> k 0)
|
|
(random k)
|
|
(assertion-violationf 'blodwen-random "invalid range argument ~a" k)))]))
|
|
|
|
;; For finalisers
|
|
|
|
(define blodwen-finaliser (make-guardian))
|
|
(define (blodwen-register-object obj proc)
|
|
(let [(x (cons obj proc))]
|
|
(blodwen-finaliser x)
|
|
x))
|
|
(define blodwen-run-finalisers
|
|
(lambda ()
|
|
(let run ()
|
|
(let ([x (blodwen-finaliser)])
|
|
(when x
|
|
(((cdr x) (car x)) 'erased)
|
|
(run))))))
|