mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-19 09:12:34 +03:00
a9ccf4db4f
This is for compiled evaluation at compile-time, for full normalisation. You can try it by setting the evaluation mode to scheme (that is, :set eval scheme at the REPL). It's certainly an order of magnitude faster than the standard evaluator, based on my playing around with it, although still quite a bit slower than compilation for various reasons, including: * It has to evaluate under binders, and therefore deal with blocked symbols * It has to maintain enough information to be able to read back a Term from the evaluated scheme object, which means retaining things like types and other metadata * We can't do a lot of the optimisations we'd do for runtime evaluation particularly setting things up so we don't need to do arity checking Also added a new option evaltiming (set with :set evaltiming) to display how long evaluation itself takes, which is handy for checking performance. I also don't think we should aim to replace the standard evaluator, in general, at least not for a while, because that will involve rewriting a lot of things and working out how to make it work as Call By Name (which is clearly possible, but fiddly). Still, it's going to be interesting to experiment with it! I think it will be a good idea to use it for elaborator reflection and type providers when we eventually get around to implementing them. Original commit details: * Add ability to evaluate open terms via Scheme Still lots of polish and more formal testing to do here before we can use it in practice, but you can still use ':scheme <term>' at the REPL to evaluate an expression by compiling to scheme then reading back the result. Also added 'evaltiming' option at the REPL, which, when set, displays how long normalisaton takes (doesn't count resugaring, just the normalisation step). * Add scheme evaluation mode Different when evaluating everything, vs only evaluating visible things. We want the latter when type checking, the former at the REPL. * Bring support.rkt up to date A couple of missing things required for interfacing with scheme objects * More Scheme readback machinery We need these things in the next version so that the next-but-one version can have a scheme evaluator! * Add top level interface to scheme based normaliser Also check it's available - currently chez only - and revert to the default slow normaliser if it's not. * Bring Context up to date with changes in main * Now need Idris 0.5.0 to build * Add SNF type for scheme values This will allow us to incrementally evaluate under lambdas, which will be useful for elaborator reflection and type providers. * Add Quote for scheme evaluator So, we can now get a weak head normal form, and evaluate the scope of a binder when we have an argument to plug in, or just quote back the whole thing. * Add new 'scheme' evaluator mode at the REPL Replacing the temporary 'TmpScheme', this is a better way to try out the scheme based evaluator * Fix name generation for new UN format * Add scheme evaluator support to Racket * Add another scheme eval test With metavariables this time * evaltiming now times execution too This was handy for finding out the difference between the scheme based evaluator and compilation. Compilation was something like 20 times faster in my little test, so that'd be about 4-500 times faster than the standard evaluator. Ouch! * Fix whitespace errors * Error handling when trying to evaluate Scheme
568 lines
17 KiB
Racket
568 lines
17 KiB
Racket
(define (blodwen-os)
|
|
(case (system-type 'os)
|
|
[(unix) "unix"]
|
|
[(macosx) "darwin"]
|
|
[(windows) "windows"]
|
|
[else "unknown"]))
|
|
|
|
(define blodwen-lazy
|
|
(lambda (f)
|
|
(let ([evaluated #f] [res void])
|
|
(lambda ()
|
|
(if (not evaluated)
|
|
(begin (set! evaluated #t)
|
|
(set! res (f))
|
|
(set! f void))
|
|
(void))
|
|
res))))
|
|
|
|
(define blodwen-toSignedInt
|
|
(lambda (x bits)
|
|
(if (bitwise-bit-set? x bits)
|
|
(bitwise-ior x (arithmetic-shift (- 1) bits))
|
|
(bitwise-and x (- (arithmetic-shift 1 bits) 1)))))
|
|
|
|
(define blodwen-toUnsignedInt
|
|
(lambda (x bits)
|
|
(modulo x (arithmetic-shift 1 bits))))
|
|
|
|
(define bu+ (lambda (x y bits) (blodwen-toUnsignedInt (+ x y) bits)))
|
|
(define bu- (lambda (x y bits) (blodwen-toUnsignedInt (- x y) bits)))
|
|
(define bu* (lambda (x y bits) (blodwen-toUnsignedInt (* x y) bits)))
|
|
(define bu/ (lambda (x y bits) (blodwen-toUnsignedInt (quotient x y) bits)))
|
|
|
|
(define bs+ (lambda (x y bits) (blodwen-toSignedInt (+ x y) bits)))
|
|
(define bs- (lambda (x y bits) (blodwen-toSignedInt (- x y) bits)))
|
|
(define bs* (lambda (x y bits) (blodwen-toSignedInt (* x y) bits)))
|
|
(define bs/ (lambda (x y bits) (blodwen-toSignedInt (quotient x y) 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 (* 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 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 (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 exact-floor
|
|
(lambda (x)
|
|
(inexact->exact (floor x))))
|
|
|
|
(define blodwen-bits-shl-signed
|
|
(lambda (x y bits) (blodwen-toSignedInt (arithmetic-shift x y) bits)))
|
|
|
|
(define exact-truncate
|
|
(lambda (x)
|
|
(inexact->exact (truncate x))))
|
|
|
|
(define exact-truncate-boundedInt
|
|
(lambda (x y)
|
|
(blodwen-toSignedInt (exact-truncate x) y)))
|
|
|
|
(define exact-truncate-boundedUInt
|
|
(lambda (x y)
|
|
(blodwen-toUnsignedInt (exact-truncate x) y)))
|
|
|
|
(define cast-char-boundedInt
|
|
(lambda (x y)
|
|
(blodwen-toSignedInt (char->integer x) y)))
|
|
|
|
(define cast-char-boundedUInt
|
|
(lambda (x y)
|
|
(blodwen-toUnsignedInt (char->integer x) y)))
|
|
|
|
(define cast-string-int
|
|
(lambda (x)
|
|
(exact-truncate (cast-num (string->number (destroy-prefix x))))))
|
|
|
|
(define cast-string-boundedInt
|
|
(lambda (x y)
|
|
(blodwen-toSignedInt (cast-string-int x) y)))
|
|
|
|
(define cast-string-boundedUInt
|
|
(lambda (x y)
|
|
(blodwen-toUnsignedInt (cast-string-int 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-int-char
|
|
(lambda (x)
|
|
(if (or
|
|
(and (>= x 0) (<= x #xd7ff))
|
|
(and (>= x #xe000) (<= x #x10ffff)))
|
|
(integer->char x)
|
|
(integer->char 0))))
|
|
|
|
(define cast-string-double
|
|
(lambda (x)
|
|
(cast-num (string->number (destroy-prefix x)))))
|
|
(define (string-concat xs) (apply string-append xs))
|
|
(define (string-unpack s) (string->list s))
|
|
(define (string-pack xs) (list->string xs))
|
|
(define string-cons (lambda (x y) (string-append (string x) y)))
|
|
(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 (blodwen-string-iterator-new s)
|
|
0)
|
|
|
|
(define (blodwen-string-iterator-to-string _ s ofs f)
|
|
(f (substring s ofs (string-length s))))
|
|
|
|
(define (blodwen-string-iterator-next s ofs)
|
|
(if (>= ofs (string-length s))
|
|
'() ; EOF
|
|
(cons (string-ref s ofs) (+ ofs 1))))
|
|
|
|
(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
|
|
|
|
;; NB: Racket threads are green/virtual threads meaning extra caution is to be
|
|
;; taken when using FFI functions in combination with threads. The *entire*
|
|
;; Racket runtime blocks on a foreign call, meaning no threads will progress
|
|
;; until the foreign call returns.
|
|
|
|
(define (blodwen-thread proc)
|
|
(thread (lambda () (proc (vector 0)))))
|
|
|
|
(define (blodwen-thread-wait handle)
|
|
(thread-wait handle))
|
|
|
|
;; Thread mailboxes
|
|
|
|
(define blodwen-thread-data (make-thread-cell #f))
|
|
|
|
(define (blodwen-get-thread-data ty)
|
|
(thread-cell-ref blodwen-thread-data))
|
|
|
|
(define (blodwen-set-thread-data ty a)
|
|
(thread-cell-set! blodwen-thread-data a))
|
|
|
|
;; Semaphores
|
|
|
|
(define (blodwen-make-semaphore init)
|
|
(make-semaphore init))
|
|
|
|
(define (blodwen-semaphore-post sema)
|
|
(semaphore-post sema))
|
|
|
|
(define (blodwen-semaphore-wait sema)
|
|
(semaphore-wait sema))
|
|
|
|
;; Barriers
|
|
|
|
(struct barrier (count-box num-threads mutex semaphore))
|
|
|
|
(define (blodwen-make-barrier num-threads)
|
|
(barrier (box 0) num-threads (blodwen-make-mutex) (make-semaphore 0)))
|
|
|
|
(define (blodwen-barrier-wait barrier)
|
|
(blodwen-mutex-acquire (barrier-mutex barrier))
|
|
(let* [(count-box (barrier-count-box barrier))
|
|
(count-old (unbox count-box))
|
|
(count-new (+ count-old 1))
|
|
(sema (barrier-semaphore barrier))]
|
|
(set-box! count-box count-new)
|
|
(blodwen-mutex-release (barrier-mutex barrier))
|
|
(when (= count-new (barrier-num-threads barrier)) (semaphore-post sema))
|
|
(semaphore-wait sema)
|
|
(semaphore-post sema)
|
|
))
|
|
|
|
;; Channels
|
|
|
|
(define (blodwen-make-channel ty)
|
|
(make-channel))
|
|
|
|
(define (blodwen-channel-get ty chan)
|
|
(channel-get chan))
|
|
|
|
(define (blodwen-channel-put ty chan val)
|
|
(channel-put chan val))
|
|
|
|
;; Mutex
|
|
|
|
(define (blodwen-make-mutex)
|
|
(make-semaphore 1))
|
|
|
|
(define (blodwen-mutex-acquire sema)
|
|
(semaphore-wait sema))
|
|
|
|
(define (blodwen-mutex-release sema)
|
|
(if (semaphore-try-wait? sema)
|
|
(blodwen-error-quit "Exception in mutexRelease: thread does not own mutex")
|
|
(semaphore-post sema)))
|
|
|
|
;; Condition Variables
|
|
;; As per p.5 of the MS paper
|
|
;; https://www.microsoft.com/en-us/research/wp-content/uploads/2004/12/ImplementingCVs.pdf
|
|
|
|
; The MS paper has the mutex be part of the CV, but that seems to be contrary to
|
|
; most other implementations
|
|
(struct cv (countingSem waitersLock waiters handshakeSem) #:mutable)
|
|
|
|
; CONSTRUCTOR
|
|
(define (blodwen-make-cv)
|
|
(let ([s (make-semaphore 0)]
|
|
[x (make-semaphore 1)]
|
|
[h (make-semaphore 0)])
|
|
(cv s x 0 h)))
|
|
|
|
;; MS paper: sem.V() := sem-post /* "sem.V() increments sem.count, atomically" */
|
|
;; sem.P() := sem-wait
|
|
;; (turns out this is Dijkstra's fault: P and V match up with the Dutch
|
|
;; terminology)
|
|
|
|
; WAIT
|
|
(define (blodwen-cv-wait my-cv m)
|
|
; atomically increment waiters
|
|
(semaphore-wait (cv-waitersLock my-cv))
|
|
(set-cv-waiters! my-cv (+ (cv-waiters my-cv) 1))
|
|
(semaphore-post (cv-waitersLock my-cv))
|
|
; release the provided mutex
|
|
(blodwen-mutex-release m)
|
|
; wait for the counting semaphore to let us through
|
|
(semaphore-wait (cv-countingSem my-cv))
|
|
; signal to broadcast that we have proceeded past the critical point/have
|
|
; been woken up successfully
|
|
(semaphore-post (cv-handshakeSem my-cv))
|
|
; re-acquire the provided mutex
|
|
(blodwen-mutex-acquire m)
|
|
)
|
|
|
|
; SIGNAL
|
|
(define (blodwen-cv-signal my-cv)
|
|
; lock access to waiters
|
|
(semaphore-wait (cv-waitersLock my-cv))
|
|
(let ([waiters (cv-waiters my-cv)])
|
|
(if (> waiters 0)
|
|
|
|
; if we have waiting threads, signal one of them
|
|
(begin
|
|
(set-cv-waiters! my-cv (- waiters 1))
|
|
; increment the counting semaphore to wake up a thread
|
|
(semaphore-post (cv-countingSem my-cv))
|
|
; wait for the thread to tell us it's okay to proceed
|
|
(semaphore-wait (cv-handshakeSem my-cv))
|
|
)
|
|
|
|
; otherwise, do nothing
|
|
(void)
|
|
)
|
|
; unlock access to waiters
|
|
(semaphore-post (cv-waitersLock my-cv))
|
|
))
|
|
|
|
; BROADCAST HELPERS
|
|
|
|
; for (int i = 0; i < waiters; i++) s.V();
|
|
(define (broadcast-for-helper my-cv i)
|
|
(if (= i 0)
|
|
; if i is zero, we're done
|
|
(void)
|
|
; otherwise, we signal one waiting thread, decrement i, and keep going
|
|
(begin
|
|
(semaphore-post (cv-countingSem my-cv))
|
|
|
|
(broadcast-for-helper my-cv (- i 1))
|
|
)))
|
|
|
|
; while (waiters > 0) { waiters--; h.P(); }
|
|
(define (broadcast-while-helper my-cv waiters)
|
|
(if (= waiters 0)
|
|
; if waiters is 0, we're done
|
|
(void)
|
|
; otherwise, wait for "waiters" many threads to tell us they're awake
|
|
(begin
|
|
(semaphore-wait (cv-handshakeSem my-cv))
|
|
(broadcast-while-helper my-cv (- waiters 1))
|
|
)))
|
|
|
|
; BROADCAST
|
|
(define (blodwen-cv-broadcast my-cv)
|
|
; lock access to waiters
|
|
(semaphore-wait (cv-waitersLock my-cv))
|
|
(let ([waiters (cv-waiters my-cv)])
|
|
; signal "waiters" many threads; counting *until* 0 in the helper
|
|
; function, hence "waiters" and NOT "waiters - 1"
|
|
(broadcast-for-helper my-cv waiters)
|
|
; wait on "waiters" many threads to have been woken
|
|
(broadcast-while-helper my-cv waiters)
|
|
; unlock access to waiters
|
|
(semaphore-post (cv-waitersLock my-cv))
|
|
))
|
|
|
|
; FIXME: Maybe later. Possibly difficult because of the handshake thingy?
|
|
;(define (blodwen-cv-wait-timeout my-cv lockM timeout)
|
|
; ;; precondition: calling thread holds lockM
|
|
; (semaphore-wait (cv-waitersLock my-cv)) ; x.P()
|
|
; (set-cv-waiters! my-cv (+ (cv-waiters my-cv) 1)) ; waiters++
|
|
; (semaphore-post (cv-waitersLock my-cv)) ; x.V()
|
|
; (blodwen-mutex-release lockM) ; m.Release()
|
|
;
|
|
; (sync/timeout (/ timeout 1000000) (cv-countingSem my-cv))
|
|
;
|
|
; (semaphore-wait (cv-countingSem my-cv)) ; s.P()
|
|
; (semaphore-post (cv-handshakeSem my-cv)) ; h.V()
|
|
; (blodwen-mutex-acquire lockM) ; m.Acquire()
|
|
; )
|
|
|
|
|
|
(define (blodwen-make-future work) (future work))
|
|
(define (blodwen-await-future ty future) (touch future))
|
|
|
|
;; NB: These should *ALWAYS* be used in multi-threaded programs since Racket
|
|
;; threads are green/virtual threads and so using an external function will
|
|
;; block the *entire* runtime until the function returns. This is fine for most
|
|
;; things, but not for `sleep`.
|
|
(define (blodwen-sleep s) (sleep s))
|
|
(define (blodwen-usleep us) (sleep (* 0.000001 us)))
|
|
|
|
(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-arg-count)
|
|
(+ (vector-length (current-command-line-arguments)) 1))
|
|
|
|
(define (blodwen-arg n)
|
|
(cond
|
|
((= n 0) (path->string (find-system-path 'run-file)))
|
|
((< n (+ (vector-length (current-command-line-arguments)) 1))
|
|
(vector-ref (current-command-line-arguments) (- n 1)))
|
|
(else "")))
|
|
|
|
;; 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)
|
|
|
|
;; For creating and reading back scheme objects
|
|
|
|
(define ns (make-base-namespace))
|
|
|
|
; read a scheme string and evaluate it, returning 'Just result' on success
|
|
; TODO: catch exception!
|
|
(define (blodwen-eval-scheme str)
|
|
(with-handlers ([exn:fail? (lambda (x) '())]) ; Nothing on failure
|
|
(box (eval (read (open-input-string str)) ns))) ; box == Just
|
|
)
|
|
|
|
(define (blodwen-eval-okay obj)
|
|
(if (null? obj)
|
|
0
|
|
1))
|
|
|
|
(define (blodwen-get-eval-result obj)
|
|
(unbox obj))
|
|
|
|
(define (blodwen-debug-scheme obj)
|
|
(display obj) (newline))
|
|
|
|
(define (blodwen-is-number obj)
|
|
(if (number? obj) 1 0))
|
|
|
|
(define (blodwen-is-integer obj)
|
|
(if (and (number? obj) (exact? obj)) 1 0))
|
|
|
|
(define (blodwen-is-float obj)
|
|
(if (flonum? obj) 1 0))
|
|
|
|
(define (blodwen-is-char obj)
|
|
(if (char? obj) 1 0))
|
|
|
|
(define (blodwen-is-string obj)
|
|
(if (string? obj) 1 0))
|
|
|
|
(define (blodwen-is-procedure obj)
|
|
(if (procedure? obj) 1 0))
|
|
|
|
(define (blodwen-is-symbol obj)
|
|
(if (symbol? obj) 1 0))
|
|
|
|
(define (blodwen-is-vector obj)
|
|
(if (vector? obj) 1 0))
|
|
|
|
(define (blodwen-is-nil obj)
|
|
(if (null? obj) 1 0))
|
|
|
|
(define (blodwen-is-pair obj)
|
|
(if (pair? obj) 1 0))
|
|
|
|
(define (blodwen-is-box obj)
|
|
(if (box? obj) 1 0))
|
|
|
|
(define (blodwen-make-symbol str)
|
|
(string->symbol str))
|
|
|
|
; The below rely on checking that the objects are the right type first.
|
|
|
|
(define (blodwen-vector-ref obj i)
|
|
(vector-ref obj i))
|
|
|
|
(define (blodwen-vector-length obj)
|
|
(vector-length obj))
|
|
|
|
(define (blodwen-vector-list obj)
|
|
(vector->list obj))
|
|
|
|
(define (blodwen-unbox obj)
|
|
(unbox obj))
|
|
|
|
(define (blodwen-apply obj arg)
|
|
(obj arg))
|
|
|
|
(define (blodwen-force obj)
|
|
(obj))
|
|
|
|
(define (blodwen-read-symbol sym)
|
|
(symbol->string sym))
|
|
|
|
(define (blodwen-id x) x)
|