mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-21 02:31:50 +03:00
270 lines
8.3 KiB
Scheme
270 lines
8.3 KiB
Scheme
(define (blodwen-os)
|
|
(case (machine-type)
|
|
[(i3le ti3le a6le ta6le) "unix"] ; GNU/Linux
|
|
[(i3ob ti3ob a6ob ta6ob) "unix"] ; OpenBSD
|
|
[(i3fb ti3fb a6fb ta6fb) "unix"] ; FreeBSD
|
|
[(i3nb ti3nb a6nb ta6nb) "unix"] ; NetBSD
|
|
[(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 bits16->bits8 (lambda (x) (modulo x (expt 2 8))))
|
|
(define bits32->bits8 (lambda (x) (modulo x (expt 2 8))))
|
|
(define bits32->bits16 (lambda (x) (modulo x (expt 2 16))))
|
|
(define bits64->bits8 (lambda (x) (modulo x (expt 2 8))))
|
|
(define bits64->bits16 (lambda (x) (modulo x (expt 2 16))))
|
|
(define bits64->bits32 (lambda (x) (modulo x (expt 2 32))))
|
|
|
|
(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)
|
|
(let ((sec (div t 1000000))
|
|
(micro (mod t 1000000)))
|
|
(condition-wait c m (make-time 'time-duration (* 1000 micro) sec))))
|
|
(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))))))
|