2daf225cab
controversial, unless I damaged something in the process of integrating
them with other recent changes. the user's guide and release notes
have been updated as well to reflect the changes of interest to end
users.
- the body of load-library is now wrapped in a $pass-time with
to show the time spent loading libraries separately from the time
spent in expand.
syntax.ss
- interpret now plays the pass-time game
interpret.ss
- added compile-time-value? predicate and
compile-time-value-value accessor
syntax.ss, primdata.ss,
8.ms, primvars.ms, root-experr*
- $pass-stats now returns accurrate stats for the currently timed
pass.
7.ss
- compile-whole-program and compile-whole-library now propagate
recompile info from the named wpo file to the object file
to support maybe-compile-program and maybe-compile-library in
the case where compile-whole-{program,library} overwrites the
original object file.
compile.ss,
7.ms, mat.ss, primvars.ms
- replaced the ancient and unusable bintar with one that creates
a useful tarball for binary installs
bintar
- generated Mf-install InstallBin (InstallLib, InstallMan) now
correctly indirects through InstallPrefix if the --installbin
(--installlib, --installman) configure flag is not present.
src/configure
- removed definition of generate-procedure-source-information
patch.ss
- guardian tconc cells are now allocated in generation 0 in the hope
that they can be released more quickly.
gc.c
- added ftype-guardian syntax: (ftype-guardian A) creates a new
guardian for ftype pointers of type A, the first base field (or
one of the first base fields in the case of unions) of which must
be a word-sized integer with native endianness representing a
reference count. ftype pointers are registered with and retrieved
from the guardian just like objects are registered with and
retrieved from any guardian. the difference is that the garbage
collector decrements the reference count before resurrecting an
ftype pointer and resurrects only those whose reference counts
become zero, i.e., are ready for deallocation.
ftype.ss, cp0.ss, cmacros.ss, cpnanopass.ss, prims.ss, primdata.ss,
gc.c,
4.ms, root-experr*
- fixed a bug in automatic recompilation handling of missing include
files specified with absolute pathnames or pathnames starting with
"./" or "..": was erroring out in file-modification-time with a
file-not-found or other exception rather than recompiling.
syntax.ss,
7.ms, root-experr*, patch*
- changed inline vector-for-each and string-for-each code to
put the last call to the procedure in tail position, as was
already done for the library definitions and for the inline
code for for-each.
cp0.ss,
5_4.ms, 5_6.ms
- the compiler now generates better inline code for the bytevector
procedure. instead of one byte memory write for each argument,
it writes up to 4 (32-bit machines) or 8 (64-bit machines) bytes
at a time, which almost always results in fewer instructions and
fewer writes.
cpnanopass.ss,
bytevector.ms
- packaged unchanging implicit reader arguments into a single record
to reduce the number of arguments.
read.ss
- recoded run-vector to handle zero-length vectors. it appears
we're not presently generating empty vectors (representing empty
groups), but the fasl format permits them.
7.ss
original commit: 7be1d190de7171f74a1ee71e348d3e6310392686
2263 lines
77 KiB
Scheme
2263 lines
77 KiB
Scheme
"prims.ss"
|
|
;;; prims.ss
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
|
;;;
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
|
;;; you may not use this file except in compliance with the License.
|
|
;;; You may obtain a copy of the License at
|
|
;;;
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
|
;;;
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
|
;;; See the License for the specific language governing permissions and
|
|
;;; limitations under the License.
|
|
|
|
(eval-when (compile)
|
|
(optimize-level 3)
|
|
(run-cp0 (default-run-cp0))
|
|
(generate-interrupt-trap #f))
|
|
|
|
;;; hand-coded primitives
|
|
|
|
(define-who $hand-coded
|
|
(lambda (name)
|
|
($oops who
|
|
"must invoke with quoted name and compile at optimize level 2 or 3")))
|
|
|
|
(define list ($hand-coded 'list-procedure))
|
|
(define $record ($hand-coded '$record-procedure))
|
|
(define vector ($hand-coded 'vector-procedure))
|
|
(define cons* ($hand-coded 'cons*-procedure))
|
|
(define list* ($hand-coded 'list*-procedure))
|
|
(define $apply ($hand-coded '$apply-procedure))
|
|
|
|
;;; basic C-coded primitives
|
|
|
|
(define $oops ; boot-time error procedure
|
|
(foreign-procedure "(cs)boot-error"
|
|
(scheme-object scheme-object scheme-object)
|
|
void))
|
|
(define errorf $oops)
|
|
(define assertion-violationf $oops)
|
|
|
|
(define $lookup-library-entry
|
|
(foreign-procedure "(cs)lookup_library_entry"
|
|
(fixnum boolean)
|
|
scheme-object))
|
|
|
|
(define $flonum->fixnum
|
|
(foreign-procedure "(cs)s_fltofx"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
; must be compiled w/generate-interrupt-trap #f for library eq-hashtable operations
|
|
(define weak-cons
|
|
(foreign-procedure "(cs)s_weak_cons"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define weak-pair?
|
|
(foreign-procedure "(cs)s_weak_pairp"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define ephemeron-cons
|
|
(foreign-procedure "(cs)s_ephemeron_cons"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define ephemeron-pair?
|
|
(foreign-procedure "(cs)s_ephemeron_pairp"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define $split-continuation
|
|
(foreign-procedure "(cs)single_continuation"
|
|
(scheme-object iptr)
|
|
scheme-object))
|
|
|
|
(define $set-collect-trip-bytes
|
|
(foreign-procedure "(cs)s_set_collect_trip_bytes"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define oblist
|
|
(foreign-procedure "(cs)s_oblist"
|
|
()
|
|
scheme-object))
|
|
|
|
(define-who $show-allocation
|
|
(let ([fp (foreign-procedure "(cs)s_showalloc" (boolean string) void)])
|
|
(case-lambda
|
|
[() (fp #f #f)]
|
|
[(x) (fp x #f)]
|
|
[(x s)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(fp x s)])))
|
|
|
|
(define-who $enable-check-heap
|
|
(let ([get (foreign-procedure "(cs)check_heap_enabledp" () boolean)]
|
|
[set (foreign-procedure "(cs)enable_check_heap" (boolean) void)])
|
|
(case-lambda
|
|
[() (get)]
|
|
[(x) (set x)])))
|
|
|
|
(define-who $check-heap-errors
|
|
(foreign-procedure "(cs)check_heap_errors"
|
|
()
|
|
uptr))
|
|
|
|
(define-who system
|
|
(let ([p (foreign-procedure "(cs)s_system" (string) scheme-object)])
|
|
(lambda (x)
|
|
(unless (string? x) ($oops who "~s is not a string" x))
|
|
(p x))))
|
|
|
|
(define $set-code-byte!
|
|
(foreign-procedure "(cs)s_set_code_byte"
|
|
(scheme-object scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $set-code-word!
|
|
(foreign-procedure "(cs)s_set_code_word"
|
|
(scheme-object scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $set-code-long!
|
|
(foreign-procedure "(cs)s_set_code_long"
|
|
(scheme-object scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $set-code-quad!
|
|
(foreign-procedure "(cs)s_set_code_quad"
|
|
(scheme-object scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $flush-instruction-cache
|
|
(foreign-procedure "(cs)s_flush_instruction_cache"
|
|
()
|
|
scheme-object))
|
|
|
|
(define $make-closure
|
|
(foreign-procedure "(cs)s_make_closure"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define string->symbol
|
|
(foreign-procedure "(cs)s_intern"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define $intern2
|
|
(foreign-procedure "(cs)s_intern2"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $intern3
|
|
(foreign-procedure "(cs)s_intern3"
|
|
(scheme-object scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $intern-gensym
|
|
(foreign-procedure "(cs)s_intern_gensym"
|
|
(scheme-object)
|
|
void))
|
|
|
|
(define cpu-time
|
|
(foreign-procedure "(cs)cputime"
|
|
()
|
|
scheme-object))
|
|
|
|
(define real-time
|
|
(foreign-procedure "(cs)realtime"
|
|
()
|
|
scheme-object))
|
|
|
|
(define $fixed-path?
|
|
(foreign-procedure "(cs)fixedpathp"
|
|
(string)
|
|
boolean))
|
|
|
|
(define getenv
|
|
(let ([getenv (foreign-procedure "(cs)getenv" (string) scheme-object)])
|
|
(lambda (s)
|
|
(unless (string? s) ($oops 'getenv "~s is not a string" s))
|
|
(getenv s))))
|
|
|
|
(define putenv
|
|
(let ([putenv (foreign-procedure "(cs)putenv" (string string) void)])
|
|
(lambda (s1 s2)
|
|
(unless (string? s1) ($oops 'putenv "~s is not a string" s1))
|
|
(unless (string? s2) ($oops 'putenv "~s is not a string" s2))
|
|
(putenv s1 s2))))
|
|
|
|
(define decode-float
|
|
(foreign-procedure "(cs)s_decode_float"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define $fx*
|
|
(foreign-procedure "(cs)fxmul" (fixnum fixnum)
|
|
fixnum))
|
|
|
|
(define $fx/
|
|
(foreign-procedure "(cs)fxdiv" (fixnum fixnum)
|
|
fixnum))
|
|
|
|
(define $procedure-name
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops '$procedure-name "~s is not a procedure" x))
|
|
($code-name ($closure-code x))))
|
|
|
|
(define-who procedure-arity-mask
|
|
(lambda (x)
|
|
(unless (procedure? x) ($oops who "~s is not a procedure" x))
|
|
($code-arity-mask ($closure-code x))))
|
|
|
|
(let ()
|
|
(define-syntax frob-proc
|
|
(syntax-rules ()
|
|
[(_ frob make-frob frob-set! elt? elt-msg)
|
|
(let ([elt-error
|
|
(lambda args
|
|
(do ([args args (cdr args)])
|
|
((null? args))
|
|
(unless (elt? (car args))
|
|
($oops 'frob elt-msg (car args)))))])
|
|
(define-syntax frob-clause
|
|
(syntax-rules ()
|
|
((_ c (... ...))
|
|
(if (and (elt? c) (... ...))
|
|
(frob c (... ...))
|
|
(elt-error c (... ...))))))
|
|
(case-lambda
|
|
[() (frob-clause)]
|
|
[(c1) (frob-clause c1)]
|
|
[(c1 c2)
|
|
(frob-clause c1 c2)]
|
|
[(c1 c2 c3)
|
|
(frob-clause c1 c2 c3)]
|
|
[(c1 c2 c3 c4)
|
|
(frob-clause c1 c2 c3 c4)]
|
|
[(c1 c2 c3 c4 c5)
|
|
(frob-clause c1 c2 c3 c4 c5)]
|
|
[(c1 c2 c3 c4 c5 c6)
|
|
(frob-clause c1 c2 c3 c4 c5 c6)]
|
|
[l (let ([s (make-frob (length l))])
|
|
(do ([ls l (cdr ls)] [i 0 (fx+ i 1)])
|
|
((null? ls) s)
|
|
(let ([c (car ls)])
|
|
(unless (elt? c) (elt-error c))
|
|
(frob-set! s i c))))]))]))
|
|
|
|
|
|
(set! string (frob-proc string make-string string-set! char?
|
|
"~s is not a character"))
|
|
(set! fxvector (frob-proc fxvector make-fxvector fxvector-set! fixnum?
|
|
"~s is not a fixnum"))
|
|
(set! bytevector
|
|
(let ([fill? (lambda (k) (and (fixnum? k) (fx<= -128 k 255)))])
|
|
(frob-proc bytevector make-bytevector $bytevector-set! fill?
|
|
"invalid value ~s")))
|
|
)
|
|
|
|
(define-who (bytevector-truncate! bv n)
|
|
(unless (mutable-bytevector? bv) ($oops who "~s is not a mutable bytevector" bv))
|
|
(unless (and (fixnum? n) (not ($fxu< (bytevector-length bv) n)))
|
|
($oops who "invalid new length ~s for ~s" n bv))
|
|
(bytevector-truncate! bv n))
|
|
|
|
(define-who (string-truncate! st n)
|
|
(unless (mutable-string? st) ($oops who "~s is not a mutable string" st))
|
|
(unless (and (fixnum? n) (not ($fxu< (string-length st) n)))
|
|
($oops who "invalid new length ~s for ~s" n st))
|
|
(string-truncate! st n))
|
|
|
|
(define-who make-string
|
|
(case-lambda
|
|
[(n c)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
|
|
($oops who "~s is not a valid string length" n))
|
|
(unless (char? c)
|
|
($oops who "~s is not a character" c))
|
|
(make-string n c)]
|
|
[(n)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-string-length) n)))
|
|
($oops who "~s is not a valid string length" n))
|
|
(make-string n)]))
|
|
|
|
(define-who make-vector
|
|
(case-lambda
|
|
[(n x)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
|
($oops who "~s is not a valid vector length" n))
|
|
(make-vector n x)]
|
|
[(n)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
|
($oops who "~s is not a valid vector length" n))
|
|
(make-vector n)]))
|
|
|
|
(define $make-eqhash-vector
|
|
(case-lambda
|
|
[(n)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-vector-length) n)))
|
|
($oops '$make-eqhash-vector "~s is not a nonnegative fixnum" n))
|
|
($make-eqhash-vector n)]))
|
|
|
|
(define-who make-fxvector
|
|
(case-lambda
|
|
[(n x)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
|
|
($oops who "~s is not a valid fxvector length" n))
|
|
(unless (fixnum? x)
|
|
($oops who "~s is not a fixnum" x))
|
|
(make-fxvector n x)]
|
|
[(n)
|
|
(unless (and (fixnum? n) (not ($fxu< (constant maximum-fxvector-length) n)))
|
|
($oops who "~s is not a valid fxvector length" n))
|
|
(make-fxvector n)]))
|
|
|
|
(define string-fill!
|
|
(lambda (s c)
|
|
(unless (mutable-string? s)
|
|
($oops 'string-fill! "~s is not a mutable string" s))
|
|
(unless (char? c)
|
|
($oops 'string-fill! "~s is not a character" c))
|
|
(string-fill! s c)))
|
|
|
|
(define fxvector-fill!
|
|
(lambda (v n)
|
|
(unless (mutable-fxvector? v)
|
|
($oops 'fxvector-fill! "~s is not a mutable fxvector" v))
|
|
(unless (fixnum? n)
|
|
($oops 'fxvector-fill! "~s is not a fixnum" n))
|
|
(fxvector-fill! v n)))
|
|
|
|
;;; multiple return values stuff
|
|
|
|
(define values ($hand-coded 'values-procedure))
|
|
|
|
(define call-with-values
|
|
(lambda (producer consumer)
|
|
(unless (procedure? producer)
|
|
($oops 'call-with-values "~s is not a procedure" producer))
|
|
(unless (procedure? consumer)
|
|
($oops 'call-with-values "~s is not a procedure" consumer))
|
|
(call-with-values producer consumer)))
|
|
|
|
(define call/1cc
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops 'call/1cc "~s is not a procedure" p))
|
|
(#3%call/1cc p)))
|
|
|
|
(define call/cc
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops 'call/cc "~s is not a procedure" p))
|
|
(#3%call/cc p)))
|
|
|
|
(define-who call-with-current-continuation
|
|
(lambda (p)
|
|
(unless (procedure? p)
|
|
($oops who "~s is not a procedure" p))
|
|
(#3%call/cc p)))
|
|
|
|
(define $code? (lambda (x) ($code? x)))
|
|
|
|
(define $system-code? (lambda (x) ($system-code? x)))
|
|
|
|
(define $system-procedure?
|
|
(lambda (x)
|
|
(and (procedure? x) ($system-code? ($closure-code x)))))
|
|
|
|
(define-who $make-code-object
|
|
(foreign-procedure "(cs)s_make_code"
|
|
(iptr iptr ptr ptr iptr ptr ptr)
|
|
ptr))
|
|
|
|
(define-who $code-name
|
|
(lambda (x)
|
|
(unless ($code? x) ($oops who "~s is not code" x))
|
|
($code-name x)))
|
|
|
|
(define-who $code-arity-mask
|
|
(lambda (x)
|
|
(unless ($code? x) ($oops who "~s is not code" x))
|
|
($code-arity-mask x)))
|
|
|
|
(define-who $code-free-count
|
|
(lambda (x)
|
|
(unless ($code? x) ($oops who "~s is not code" x))
|
|
($code-free-count x)))
|
|
|
|
(define-who $code-info
|
|
(lambda (x)
|
|
(unless ($code? x) ($oops who "~s is not code" x))
|
|
($code-info x)))
|
|
|
|
(define-who $code-pinfo*
|
|
(lambda (x)
|
|
(unless ($code? x) ($oops who "~s is not code" x))
|
|
($code-pinfo* x)))
|
|
|
|
(define $object-address ; not safe and can't be
|
|
(lambda (x offset)
|
|
($object-address x offset)))
|
|
|
|
(define $address->object ; also not safe and can't be
|
|
(lambda (x offset)
|
|
;; could do address-in-heap? checking here if we passed a who.
|
|
($address->object x offset)))
|
|
|
|
(define foreign-callable-entry-point
|
|
(lambda (x)
|
|
(unless ($code? x)
|
|
($oops 'foreign-callable-entry-point "~s is not a code object" x))
|
|
($object-address x (constant code-data-disp))))
|
|
|
|
(define-who foreign-callable-code-object
|
|
(lambda (x)
|
|
(unless (and (integer? x) (exact? x) ($address-in-heap? x))
|
|
($oops who "~s is not an entry point" x))
|
|
($address->object x (constant code-data-disp))))
|
|
|
|
(define $closure-code
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops '$closure-code "~s is not a closure" x))
|
|
($closure-code x)))
|
|
|
|
(define $closure-length
|
|
(lambda (x)
|
|
(unless (procedure? x)
|
|
($oops '$closure-length "~s is not a closure" x))
|
|
($code-free-count ($closure-code x))))
|
|
|
|
(define $closure-ref
|
|
(lambda (x i)
|
|
(unless (procedure? x)
|
|
($oops '$closure-ref "~s is not a closure" x))
|
|
(unless (and (fixnum? i) (fx< -1 i ($closure-length x)))
|
|
($oops '$closure-ref "invalid index ~s" i))
|
|
($closure-ref x i)))
|
|
|
|
(define $continuation? (lambda (x) ($continuation? x)))
|
|
|
|
(define $continuation-stack-length
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-stack-length "~s is not a continuation" x))
|
|
($continuation-stack-length x)))
|
|
|
|
(define $continuation-stack-clength
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-stack-clength "~s is not a continuation" x))
|
|
($continuation-stack-clength x)))
|
|
|
|
(define $continuation-stack-ref
|
|
(lambda (x i)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-stack-ref "~s is not a continuation" x))
|
|
(unless (and (fixnum? i) (fx< 0 i ($continuation-stack-clength x)))
|
|
($oops '$continuation-stack-ref "invalid index ~s" i))
|
|
($continuation-stack-ref x i)))
|
|
|
|
(define $continuation-link
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-link "~s is not a continuation" x))
|
|
($continuation-link x)))
|
|
|
|
(define $continuation-winders
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-winders "~s is not a continuation" x))
|
|
($continuation-winders x)))
|
|
|
|
(define $continuation-return-code
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-return-code "~s is not a continuation" x))
|
|
($continuation-return-code x)))
|
|
|
|
(define $continuation-return-livemask
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-return-livemask "~s is not a continuation" x))
|
|
($continuation-return-livemask x)))
|
|
|
|
(define $continuation-return-offset
|
|
(lambda (x)
|
|
(unless ($continuation? x)
|
|
($oops '$continuation-return-offset "~s is not a continuation" x))
|
|
($continuation-return-offset x)))
|
|
|
|
(define void
|
|
(lambda ()
|
|
(void)))
|
|
|
|
(define eof-object (lambda () (eof-object)))
|
|
|
|
(define $unbound-object
|
|
(lambda ()
|
|
($unbound-object)))
|
|
|
|
(define $unbound-object?
|
|
(lambda (x)
|
|
($unbound-object? x)))
|
|
|
|
(define $set-timer
|
|
(lambda (ticks)
|
|
(unless (and (fixnum? ticks) (fx> ticks 0))
|
|
($oops '$set-timer "~s is not a positive fixnum" ticks))
|
|
($set-timer ticks)))
|
|
|
|
(define $fx+?
|
|
(lambda (x y)
|
|
($fx+? x y)))
|
|
|
|
(define $fx-?
|
|
(lambda (x y)
|
|
($fx-? x y)))
|
|
|
|
(define $bigpositive?
|
|
(lambda (x)
|
|
(unless (bignum? x)
|
|
($oops '$bigpositive "~s is not a bignum" x))
|
|
($bigpositive? x)))
|
|
|
|
(define $string-ref-check? (lambda (s i) ($string-ref-check? s i)))
|
|
(define $string-set!-check? (lambda (s i) ($string-set!-check? s i)))
|
|
|
|
(define $vector-ref-check? (lambda (v i) ($vector-ref-check? v i)))
|
|
(define $vector-set!-check? (lambda (v i) ($vector-set!-check? v i)))
|
|
|
|
(define $fxvector-ref-check? (lambda (v i) ($fxvector-ref-check? v i)))
|
|
(define $fxvector-set!-check? (lambda (v i) ($fxvector-set!-check? v i)))
|
|
|
|
(define $ratio-numerator
|
|
(lambda (q)
|
|
(if (ratnum? q)
|
|
($ratio-numerator q)
|
|
($oops '$ratio-numerator "~s is not a ratnum" q))))
|
|
|
|
(define $ratio-denominator
|
|
(lambda (q)
|
|
(if (ratnum? q)
|
|
($ratio-denominator q)
|
|
($oops '$ratio-denominator "~s is not a ratnum" q))))
|
|
|
|
(let ()
|
|
(include "io-types.ss")
|
|
(set-who! $make-binary-output-port
|
|
(rec $make-binary-output-port
|
|
(case-lambda
|
|
[(name handler buffer) ($make-binary-output-port name handler buffer #f)]
|
|
[(name handler buffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (bytevector? buffer) ($oops who "invalid buffer ~s" buffer))
|
|
(#3%$make-binary-output-port name handler buffer info)])))
|
|
|
|
(set-who! $make-binary-input-port
|
|
(rec $make-binary-input-port
|
|
(case-lambda
|
|
[(name handler buffer) ($make-binary-input-port name handler buffer #f)]
|
|
[(name handler buffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (bytevector? buffer) ($oops who "invalid buffer ~s" buffer))
|
|
(#3%$make-binary-input-port name handler buffer info)])))
|
|
|
|
(set-who! $make-binary-input/output-port
|
|
(rec $make-binary-input/output-port
|
|
(case-lambda
|
|
[(name handler ibuffer obuffer) ($make-binary-input/output-port name handler ibuffer obuffer #f)]
|
|
[(name handler ibuffer obuffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (bytevector? ibuffer) ($oops who "invalid input buffer ~s" ibuffer))
|
|
(unless (bytevector? obuffer) ($oops who "invalid output buffer ~s" obuffer))
|
|
(#3%$make-binary-input/output-port name handler ibuffer obuffer info)])))
|
|
|
|
(set-who! $make-textual-output-port
|
|
(rec $make-textual-output-port
|
|
(case-lambda
|
|
[(name handler buffer) ($make-textual-output-port name handler buffer #f)]
|
|
[(name handler buffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (string? buffer)
|
|
($oops who "invalid buffer ~s" buffer))
|
|
(#3%$make-textual-output-port name handler buffer info)])))
|
|
|
|
(set-who! $make-textual-input-port
|
|
(rec $make-textual-input-port
|
|
(case-lambda
|
|
[(name handler buffer) ($make-textual-input-port name handler buffer #f)]
|
|
[(name handler buffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (string? buffer) ($oops who "invalid buffer ~s" buffer))
|
|
(#3%$make-textual-input-port name handler buffer info)])))
|
|
|
|
(set-who! $make-textual-input/output-port
|
|
(rec $make-textual-input/output-port
|
|
(case-lambda
|
|
[(name handler ibuffer obuffer) ($make-textual-input/output-port name handler ibuffer obuffer #f)]
|
|
[(name handler ibuffer obuffer info)
|
|
(unless (string? name) ($oops who "invalid name ~s" name))
|
|
(unless (port-handler? handler) ($oops who "invalid handler ~s" handler))
|
|
(unless (string? ibuffer) ($oops who "invalid input buffer ~s" ibuffer))
|
|
(unless (string? obuffer) ($oops who "invalid output buffer ~s" obuffer))
|
|
(#3%$make-textual-input/output-port name handler ibuffer obuffer info)]))))
|
|
|
|
(define-who $port-flags-set?
|
|
(lambda (p mask)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
|
|
($port-flags-set? p mask)))
|
|
|
|
(define-who $set-port-flags!
|
|
(lambda (p mask)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
|
|
($set-port-flags! p mask)))
|
|
|
|
(define-who $reset-port-flags!
|
|
(lambda (p mask)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(unless (fixnum? mask) ($oops who "invalid mask ~s" mask))
|
|
($reset-port-flags! p mask)))
|
|
|
|
(define port-closed?
|
|
(lambda (p)
|
|
(if (port? p)
|
|
(port-closed? p)
|
|
($oops 'port-closed? "~s is not a port" p))))
|
|
|
|
(define mark-port-closed!
|
|
(lambda (p)
|
|
(if (port? p)
|
|
(mark-port-closed! p)
|
|
($oops 'mark-port-closed! "~s is not a port" p))))
|
|
|
|
(define-who $port-handler
|
|
(lambda (p)
|
|
(unless (port? p)
|
|
($oops who "~s is not a port" p))
|
|
($port-handler p)))
|
|
|
|
(define-who set-port-bol!
|
|
(lambda (p x)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(set-port-bol! p x)))
|
|
|
|
(define-who set-port-eof!
|
|
(lambda (p x)
|
|
(unless (input-port? p) ($oops who "~s is not an input port" p))
|
|
(set-port-eof! p x)))
|
|
|
|
(define-who $port-info
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
($port-info p)))
|
|
|
|
(define-who $set-port-info!
|
|
(lambda (p x)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
($set-port-info! p x)))
|
|
|
|
(define-who port-name
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(port-name p)))
|
|
|
|
(define-who set-port-name!
|
|
(lambda (p x)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(set-port-name! p x)))
|
|
|
|
(let ()
|
|
; defines port-input-index, port-output-index, port-input-size, port-output-size, port-input-buffer, and port-output-buffer
|
|
(define-syntax get/set
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ direction what bpred? tpred?)
|
|
(with-syntax ([port-dir-x (construct-name #'what "port-" #'direction "-" #'what)]
|
|
[set-port-dir-x! (construct-name #'what "set-port-" #'direction "-" #'what "!")]
|
|
[textual-port-dir-x (construct-name #'what "textual-port-" #'direction "-" #'what)]
|
|
[set-textual-port-dir-x! (construct-name #'what "set-textual-port-" #'direction "-" #'what "!")]
|
|
[binary-port-dir-x (construct-name #'what "binary-port-" #'direction "-" #'what)]
|
|
[set-binary-port-dir-x! (construct-name #'what "set-binary-port-" #'direction "-" #'what "!")]
|
|
[dir-port? (construct-name #'direction #'direction "-port?")])
|
|
#`(begin
|
|
(set-who! port-dir-x
|
|
(lambda (p)
|
|
(cond
|
|
[(and (dir-port? p) (textual-port? p)) (textual-port-dir-x p)]
|
|
[(and (dir-port? p) (binary-port? p)) (binary-port-dir-x p)]
|
|
[else ($oops who #,(format "~~s is not an ~a port" (datum direction)) p)])))
|
|
(set-who! set-port-dir-x!
|
|
(lambda (p x)
|
|
(cond
|
|
[(and (dir-port? p) (textual-port? p))
|
|
(unless (tpred? p x) ($oops who #,(format "invalid ~a ~~s" (datum what)) x))
|
|
(set-textual-port-dir-x! p x)]
|
|
[(and (dir-port? p) (binary-port? p))
|
|
(unless (bpred? p x) ($oops who #,(format "invalid ~a ~~s" (datum what)) x))
|
|
(set-binary-port-dir-x! p x)]
|
|
[else ($oops who #,(format "~~s is not an ~a port" (datum direction)) p)])))))])))
|
|
|
|
(get/set input buffer (lambda (p x) (bytevector? x)) (lambda (p x) (string? x)))
|
|
(get/set input index
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (binary-port-input-size p))))
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (textual-port-input-size p)))))
|
|
(get/set input size
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-input-buffer p)))))
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (string-length (textual-port-input-buffer p))))))
|
|
(get/set output buffer (lambda (p x) (bytevector? x)) (lambda (p x) (string? x)))
|
|
(get/set output index
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (binary-port-output-size p))))
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (textual-port-output-size p)))))
|
|
(get/set output size
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-output-buffer p)))))
|
|
(lambda (p n) (and (fixnum? n) (fx<= 0 n (string-length (textual-port-output-buffer p)))))))
|
|
|
|
(define-who port-input-count
|
|
(lambda (p)
|
|
(cond
|
|
[(and (input-port? p) (textual-port? p))
|
|
(textual-port-input-count p)]
|
|
[(and (input-port? p) (binary-port? p))
|
|
(binary-port-input-count p)]
|
|
[else ($oops who "~s is not an input port" p)])))
|
|
|
|
(define-who port-output-count
|
|
(lambda (p)
|
|
(cond
|
|
[(and (output-port? p) (textual-port? p))
|
|
(textual-port-output-count p)]
|
|
[(and (output-port? p) (binary-port? p))
|
|
(binary-port-output-count p)]
|
|
[else ($oops who "~s is not an output port" p)])))
|
|
|
|
(define-who textual-port-input-buffer
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(textual-port-input-buffer p)))
|
|
|
|
(define-who set-textual-port-input-buffer!
|
|
(lambda (p s)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(set-textual-port-input-buffer! p s)))
|
|
|
|
(define-who textual-port-input-index
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(textual-port-input-index p)))
|
|
|
|
(define-who set-textual-port-input-index!
|
|
(lambda (p n)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (textual-port-input-size p)))
|
|
($oops who "~s is not a valid index for ~s" n p))
|
|
(set-textual-port-input-index! p n)))
|
|
|
|
(define-who textual-port-input-size
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(textual-port-input-size p)))
|
|
|
|
(define-who set-textual-port-input-size!
|
|
(lambda (p n)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (string-length (textual-port-input-buffer p))))
|
|
($oops who "~s is not a valid size for ~s" n p))
|
|
(set-textual-port-input-size! p n)))
|
|
|
|
(define-who textual-port-output-buffer
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(textual-port-output-buffer p)))
|
|
|
|
(define-who set-textual-port-output-buffer!
|
|
(lambda (p s)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(set-textual-port-output-buffer! p s)))
|
|
|
|
(define-who textual-port-output-index
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(textual-port-output-index p)))
|
|
|
|
(define-who set-textual-port-output-index!
|
|
(lambda (p n)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (textual-port-output-size p)))
|
|
($oops who "~s is not a valid index for ~s" n p))
|
|
(set-textual-port-output-index! p n)))
|
|
|
|
(define-who textual-port-output-size
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(textual-port-output-size p)))
|
|
|
|
(define-who set-textual-port-output-size!
|
|
(lambda (p n)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (string-length (textual-port-output-buffer p))))
|
|
($oops who "~s is not a valid size for ~s" n p))
|
|
(set-textual-port-output-size! p n)))
|
|
|
|
(define-who binary-port-input-buffer
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(binary-port-input-buffer p)))
|
|
|
|
(define-who set-binary-port-input-buffer!
|
|
(lambda (p bv)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(set-binary-port-input-buffer! p bv)))
|
|
|
|
(define-who binary-port-input-index
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(binary-port-input-index p)))
|
|
|
|
(define-who set-binary-port-input-index!
|
|
(lambda (p n)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (binary-port-input-size p)))
|
|
($oops who "~s is not a valid index for ~s" n p))
|
|
(set-binary-port-input-index! p n)))
|
|
|
|
(define-who binary-port-input-size
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(binary-port-input-size p)))
|
|
|
|
(define-who set-binary-port-input-size!
|
|
(lambda (p n)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-input-buffer p))))
|
|
($oops who "~s is not a valid size for ~s" n p))
|
|
(set-binary-port-input-size! p n)))
|
|
|
|
(define-who binary-port-input-count
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary input port" p))
|
|
(binary-port-input-count p)))
|
|
|
|
(define-who binary-port-output-count
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(binary-port-output-count p)))
|
|
|
|
(define-who textual-port-input-count
|
|
(lambda (p)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual input port" p))
|
|
(textual-port-input-count p)))
|
|
|
|
(define-who textual-port-output-count
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops who "~s is not a textual output port" p))
|
|
(textual-port-output-count p)))
|
|
|
|
(define-who port-input-empty?
|
|
(lambda (p)
|
|
(unless (input-port? p) ($oops who "~s is not an input port" p))
|
|
(#3%port-input-empty? p)))
|
|
|
|
(define-who port-output-full?
|
|
(lambda (p)
|
|
(unless (output-port? p) ($oops who "~s is not an output port" p))
|
|
(#3%port-output-full? p)))
|
|
|
|
(define-who binary-port-output-buffer
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(binary-port-output-buffer p)))
|
|
|
|
(define-who set-binary-port-output-buffer!
|
|
(lambda (p bv)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(set-binary-port-output-buffer! p bv)))
|
|
|
|
(define-who binary-port-output-index
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(binary-port-output-index p)))
|
|
|
|
(define-who set-binary-port-output-index!
|
|
(lambda (p n)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (binary-port-output-size p)))
|
|
($oops who "~s is not a valid index for ~s" n p))
|
|
(set-binary-port-output-index! p n)))
|
|
|
|
(define-who binary-port-output-size
|
|
(lambda (p)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(binary-port-output-size p)))
|
|
|
|
(define-who set-binary-port-output-size!
|
|
(lambda (p n)
|
|
(unless (and (output-port? p) (binary-port? p))
|
|
($oops who "~s is not a binary output port" p))
|
|
(unless (and (fixnum? n) (fx<= 0 n (bytevector-length (binary-port-output-buffer p))))
|
|
($oops who "~s is not a valid size for ~s" n p))
|
|
(set-binary-port-output-size! p n)))
|
|
|
|
(define $symbol-name
|
|
(lambda (s)
|
|
(if (symbol? s)
|
|
($symbol-name s)
|
|
($oops '$symbol-name "~s is not a symbol" s))))
|
|
|
|
(define $set-symbol-name!
|
|
(lambda (s l)
|
|
(if (symbol? s)
|
|
($set-symbol-name! s l)
|
|
($oops '$set-symbol-name! "~s is not a symbol" s))))
|
|
|
|
(define $symbol-property-list
|
|
(lambda (s)
|
|
(if (symbol? s)
|
|
($symbol-property-list s)
|
|
($oops '$symbol-property-list "~s is not a symbol" s))))
|
|
|
|
(define $set-symbol-property-list!
|
|
(lambda (s l)
|
|
(if (symbol? s)
|
|
($set-symbol-property-list! s l)
|
|
($oops '$set-symbol-property-list! "~s is not a symbol" s))))
|
|
|
|
(define $system-property-list
|
|
(lambda (s)
|
|
(if (symbol? s)
|
|
($system-property-list s)
|
|
($oops '$system-property-list "~s is not a symbol" s))))
|
|
|
|
(define $set-system-property-list!
|
|
(lambda (s l)
|
|
(if (symbol? s)
|
|
($set-system-property-list! s l)
|
|
($oops '$set-system-property-list! "~s is not a symbol" s))))
|
|
|
|
(define-who $symbol-hash
|
|
(lambda (x)
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(#3%$symbol-hash x)))
|
|
|
|
(define-who $set-symbol-hash!
|
|
(lambda (x y)
|
|
(unless (symbol? x) ($oops who "~s is not a symbol" x))
|
|
(#3%$set-symbol-hash! x y)))
|
|
|
|
(define symbol->string
|
|
(lambda (s)
|
|
(unless (symbol? s)
|
|
($oops 'symbol->string "~s is not a symbol" s))
|
|
(#3%symbol->string s)))
|
|
|
|
(define $top-level-value
|
|
(lambda (s)
|
|
(#2%$top-level-value s)))
|
|
|
|
(define $set-top-level-value!
|
|
(lambda (s v)
|
|
(if (symbol? s)
|
|
($set-top-level-value! s v)
|
|
($oops '$set-top-level-value! "~s is not a symbol" s))))
|
|
|
|
(define $top-level-bound?
|
|
(lambda (s)
|
|
(if (symbol? s)
|
|
($top-level-bound? s)
|
|
($oops '$top-level-bound? "~s is not a symbol" s))))
|
|
|
|
(define-who $bignum-length
|
|
(lambda (n)
|
|
(unless (bignum? n) ($oops who "~s is not a bignum" n))
|
|
(#3%$bignum-length n)))
|
|
|
|
(define string-length
|
|
(lambda (s)
|
|
(#2%string-length s)))
|
|
|
|
(define string-ref
|
|
(lambda (s i)
|
|
(#2%string-ref s i)))
|
|
|
|
(define string-set!
|
|
; could use #2%string-set!
|
|
(lambda (v i x)
|
|
(#2%string-set! v i x)))
|
|
|
|
(define-who $string-set-immutable!
|
|
(lambda (s)
|
|
(unless (string? s)
|
|
($oops who "~s is not a string" s))
|
|
(#3%$string-set-immutable! s)))
|
|
|
|
(define-who mutable-string?
|
|
(lambda (v)
|
|
(#3%mutable-string? v)))
|
|
|
|
(define-who immutable-string?
|
|
(lambda (v)
|
|
(#3%immutable-string? v)))
|
|
|
|
(define char->integer
|
|
(lambda (x)
|
|
(#2%char->integer x)))
|
|
|
|
(define-who integer->char
|
|
(lambda (n)
|
|
(if (and (fixnum? n)
|
|
(or ($fxu< n #xD800)
|
|
(fx<= #xE000 n #x10FFFF)))
|
|
(#3%integer->char n)
|
|
($oops 'integer->char "~s is not a valid unicode scalar value" n))))
|
|
|
|
(define vector-length
|
|
(lambda (v)
|
|
(#2%vector-length v)))
|
|
|
|
(define vector-ref
|
|
(lambda (v i)
|
|
(#2%vector-ref v i)))
|
|
|
|
(define vector-set!
|
|
(lambda (v i x)
|
|
(#2%vector-set! v i x)))
|
|
|
|
(define vector-cas!
|
|
(lambda (v i old-x new-x)
|
|
(#2%vector-cas! v i old-x new-x)))
|
|
|
|
(define vector-set-fixnum!
|
|
(lambda (v i x)
|
|
(#2%vector-set-fixnum! v i x)))
|
|
|
|
(define-who $vector-set-immutable!
|
|
(lambda (v)
|
|
(unless (vector? v)
|
|
($oops who "~s is not a vector" v))
|
|
(#3%$vector-set-immutable! v)))
|
|
|
|
(define mutable-vector?
|
|
(lambda (v)
|
|
(#3%mutable-vector? v)))
|
|
|
|
(define immutable-vector?
|
|
(lambda (v)
|
|
(#3%immutable-vector? v)))
|
|
|
|
(define fxvector-length
|
|
(lambda (v)
|
|
(#2%fxvector-length v)))
|
|
|
|
(define fxvector-ref
|
|
(lambda (v i)
|
|
(#2%fxvector-ref v i)))
|
|
|
|
(define fxvector-set!
|
|
(lambda (v i x)
|
|
(#2%fxvector-set! v i x)))
|
|
|
|
(define-who $fxvector-set-immutable!
|
|
(lambda (s)
|
|
(unless (fxvector? s)
|
|
($oops who "~s is not a fxvector" s))
|
|
(#3%$fxvector-set-immutable! s)))
|
|
|
|
(define mutable-fxvector?
|
|
(lambda (s)
|
|
(#3%mutable-fxvector? s)))
|
|
|
|
(define immutable-fxvector?
|
|
(lambda (s)
|
|
(#3%immutable-fxvector? s)))
|
|
|
|
(define cons (lambda (x y) (cons x y)))
|
|
|
|
(define car
|
|
(lambda (p)
|
|
(#2%car p)))
|
|
|
|
(define cdr
|
|
(lambda (p)
|
|
(#2%cdr p)))
|
|
|
|
(define set-car!
|
|
(lambda (p v)
|
|
(#2%set-car! p v)))
|
|
|
|
(define set-cdr!
|
|
(lambda (p v)
|
|
(#2%set-cdr! p v)))
|
|
|
|
(define box (lambda (x) (box x)))
|
|
|
|
(define box-immutable (lambda (x) (box-immutable x)))
|
|
|
|
(define unbox
|
|
(lambda (b)
|
|
(if (box? b)
|
|
(unbox b)
|
|
($oops 'unbox "~s is not a box" b))))
|
|
|
|
(define set-box!
|
|
(lambda (b v)
|
|
(if (mutable-box? b)
|
|
(set-box! b v)
|
|
($oops 'set-box! "~s is not a mutable box" b))))
|
|
|
|
(define-who box-cas!
|
|
(lambda (b old-v new-v)
|
|
(if (mutable-box? b)
|
|
(box-cas! b old-v new-v)
|
|
($oops who "~s is not a mutable box" b))))
|
|
|
|
(define mutable-box?
|
|
(lambda (b)
|
|
(#3%mutable-box? b)))
|
|
|
|
(define immutable-box?
|
|
(lambda (b)
|
|
(#3%immutable-box? b)))
|
|
|
|
(define pair? (lambda (x) (pair? x)))
|
|
|
|
(define box? (lambda (x) (box? x)))
|
|
|
|
(define symbol? (lambda (x) (symbol? x)))
|
|
|
|
(define gensym? (lambda (x) (gensym? x)))
|
|
|
|
(define fixnum? (lambda (x) (fixnum? x)))
|
|
|
|
(define bignum? (lambda (x) (bignum? x)))
|
|
|
|
(define ratnum? (lambda (x) (ratnum? x)))
|
|
|
|
(define string? (lambda (x) (string? x)))
|
|
|
|
(define vector? (lambda (x) (vector? x)))
|
|
|
|
(define fxvector? (lambda (x) (fxvector? x)))
|
|
|
|
(define procedure? (lambda (x) (procedure? x)))
|
|
|
|
(define flonum? (lambda (x) (flonum? x)))
|
|
|
|
(define char? (lambda (x) (char? x)))
|
|
|
|
(define eof-object? (lambda (x) (eof-object? x)))
|
|
|
|
(define bwp-object? (lambda (x) (bwp-object? x)))
|
|
|
|
(define port? (lambda (p) (port? p)))
|
|
|
|
(define input-port? (lambda (p) (input-port? p)))
|
|
|
|
(define output-port? (lambda (p) (output-port? p)))
|
|
|
|
(define-who port-eof?
|
|
(lambda (input-port)
|
|
(unless (input-port? input-port)
|
|
($oops who "~s is not an input port" input-port))
|
|
(port-eof? input-port)))
|
|
|
|
(define-who binary-port?
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(#3%binary-port? p)))
|
|
|
|
(define-who textual-port?
|
|
(lambda (p)
|
|
(unless (port? p) ($oops who "~s is not a port" p))
|
|
(#3%textual-port? p)))
|
|
|
|
(define eq?
|
|
(lambda (x y)
|
|
(eq? x y)))
|
|
|
|
(define char-
|
|
(lambda (x y)
|
|
(unless (char? x)
|
|
($oops 'char- "~s is not a character" x))
|
|
(unless (char? y)
|
|
($oops 'char- "~s is not a character" y))
|
|
(char- x y)))
|
|
|
|
(define most-positive-fixnum (lambda () (#2%most-positive-fixnum)))
|
|
(define most-negative-fixnum (lambda () (#2%most-negative-fixnum)))
|
|
(define greatest-fixnum (lambda () (#2%greatest-fixnum)))
|
|
(define least-fixnum (lambda () (#2%least-fixnum)))
|
|
(define fixnum-width (lambda () (#2%fixnum-width)))
|
|
|
|
(define-who (get-u8 p)
|
|
(#2%get-u8 p))
|
|
|
|
(define-who (get-char p)
|
|
(#2%get-char p))
|
|
|
|
(define-who (lookahead-u8 p)
|
|
(#2%lookahead-u8 p))
|
|
|
|
(define-who (lookahead-char p)
|
|
(#2%lookahead-char p))
|
|
|
|
(define-who unget-u8
|
|
(lambda (binary-input-port octet)
|
|
(unless (and (input-port? binary-input-port) (binary-port? binary-input-port))
|
|
($oops who "~s is not a binary input port" binary-input-port))
|
|
(unless (or (and (fixnum? octet) (fx<= 0 octet 255)) (eof-object? octet))
|
|
($oops who "~s is not an octet or the eof object" octet))
|
|
(#3%unget-u8 binary-input-port octet)))
|
|
|
|
(define-who unget-char
|
|
(lambda (textual-input-port char)
|
|
(unless (and (input-port? textual-input-port) (textual-port? textual-input-port))
|
|
($oops who "~s is not a textual input port" textual-input-port))
|
|
(unless (or (char? char) (eof-object? char))
|
|
($oops who "~s is not a character or the eof object" char))
|
|
(#3%unget-char textual-input-port char)))
|
|
|
|
(define-who (put-u8 binary-output-port octet)
|
|
(unless (and (output-port? binary-output-port) (binary-port? binary-output-port))
|
|
($oops who "~s is not a binary output port" binary-output-port))
|
|
(unless (and (fixnum? octet) (fx<= 0 octet 255))
|
|
($oops who "~s is not an octet" octet))
|
|
(#3%put-u8 binary-output-port octet))
|
|
|
|
(define-who (put-char textual-output-port char)
|
|
(unless (and (output-port? textual-output-port) (textual-port? textual-output-port))
|
|
($oops who "~s is not a textual output port" textual-output-port))
|
|
(unless (char? char) ($oops who "~s is not a char" char))
|
|
(#3%put-char textual-output-port char))
|
|
|
|
(define peek-char
|
|
(case-lambda
|
|
[(p) (#2%peek-char p)]
|
|
[() (#3%peek-char)]))
|
|
|
|
(define read-char
|
|
(case-lambda
|
|
[(p) (#2%read-char p)]
|
|
[() (#3%read-char)]))
|
|
|
|
(define unread-char
|
|
(case-lambda
|
|
[(x p)
|
|
(unless (and (input-port? p) (textual-port? p))
|
|
($oops 'unread-char "~s is not a textual input port" p))
|
|
(unless (char? x)
|
|
($oops 'unread-char "~s is not a character" x))
|
|
(unread-char x p)]
|
|
[(x)
|
|
(unless (char? x)
|
|
($oops 'unread-char "~s is not a character" x))
|
|
(unread-char x)]))
|
|
|
|
(define write-char
|
|
(case-lambda
|
|
[(x p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops 'write-char "~s is not a textual output port" p))
|
|
(unless (char? x)
|
|
($oops 'write-char "~s is not a character" x))
|
|
(write-char x p)]
|
|
[(x)
|
|
(unless (char? x)
|
|
($oops 'write-char "~s is not a character" x))
|
|
(write-char x)]))
|
|
|
|
(define newline
|
|
(case-lambda
|
|
[(p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops 'newline "~s is not a textual output port" p))
|
|
(newline p)]
|
|
[() (newline)]))
|
|
|
|
(define display-string
|
|
(case-lambda
|
|
[(s p)
|
|
(unless (and (output-port? p) (textual-port? p))
|
|
($oops 'display-string "~s is not a textual output port" p))
|
|
(unless (string? s)
|
|
($oops 'display-string "~s is not a character" s))
|
|
(display-string s p)]
|
|
[(s)
|
|
(unless (string? s)
|
|
($oops 'display-string "~s is not a character" s))
|
|
(display-string s)]))
|
|
|
|
(define $immediate? (lambda (x) ($immediate? x)))
|
|
(define $inexactnum? (lambda (x) ($inexactnum? x)))
|
|
|
|
(define $inexactnum-real-part
|
|
(lambda (x)
|
|
(unless ($inexactnum? x)
|
|
($oops '$inexactnum-real-part "~s is not an inexactnum" x))
|
|
($inexactnum-real-part x)))
|
|
|
|
(define $inexactnum-imag-part
|
|
(lambda (x)
|
|
(unless ($inexactnum? x)
|
|
($oops '$inexactnum-imag-part "~s is not an inexactnum" x))
|
|
($inexactnum-imag-part x)))
|
|
|
|
(define $exactnum? (lambda (x) ($exactnum? x)))
|
|
|
|
(define $exactnum-real-part
|
|
(lambda (x)
|
|
(unless ($exactnum? x)
|
|
($oops '$exactnum-real-part "~s is not an exactnum" x))
|
|
($exactnum-real-part x)))
|
|
|
|
(define $exactnum-imag-part
|
|
(lambda (x)
|
|
(unless ($exactnum? x)
|
|
($oops '$exactnum-imag-part "~s is not an exactnum" x))
|
|
($exactnum-imag-part x)))
|
|
|
|
(define $make-exactnum
|
|
(lambda (x y)
|
|
(unless (or (fixnum? x) (bignum? x) (ratnum? x))
|
|
($oops '$make-exactnum "~s is not an exact real number" x))
|
|
(unless (or (and (fixnum? y) (not (fx= y 0))) (bignum? y) (ratnum? y))
|
|
($oops '$make-exactnum "~s is not an nonzero exact real number" y))
|
|
($make-exactnum x y)))
|
|
|
|
(define $rtd-counts? (lambda (x) ($rtd-counts? x)))
|
|
|
|
(define getprop
|
|
(case-lambda
|
|
[(s p)
|
|
(if (symbol? s)
|
|
(getprop s p)
|
|
($oops 'getprop "~s is not a symbol" s))]
|
|
[(s p d)
|
|
(if (symbol? s)
|
|
(getprop s p d)
|
|
($oops 'getprop "~s is not a symbol" s))]))
|
|
|
|
(define $current-stack-link
|
|
(case-lambda
|
|
[() ($current-stack-link)]
|
|
[(k)
|
|
(unless (or ($continuation? k) (zero? k))
|
|
($oops '$current-stack-link "invalid argument ~s" k))
|
|
($current-stack-link k)]))
|
|
|
|
(define $current-winders
|
|
(case-lambda
|
|
[() ($current-winders)]
|
|
[(w)
|
|
(unless (and (list? w) (andmap (lambda (x) (winder? x)) w))
|
|
($oops '$current-winders "malformed winders ~s" w))
|
|
($current-winders w)]))
|
|
|
|
(define lock-object
|
|
(foreign-procedure "(cs)lock_object" (scheme-object) void))
|
|
(define unlock-object
|
|
(foreign-procedure "(cs)unlock_object" (scheme-object) void))
|
|
(define locked-object?
|
|
(foreign-procedure "(cs)locked_objectp" (scheme-object) boolean))
|
|
|
|
(define-who $install-guardian
|
|
(lambda (obj rep tconc)
|
|
; tconc is assumed to be valid at all call sites
|
|
(#3%$install-guardian obj rep tconc)))
|
|
|
|
(define-who $install-ftype-guardian
|
|
(lambda (obj tconc)
|
|
; tconc is assumed to be valid at all call sites
|
|
(#3%$install-ftype-guardian obj tconc)))
|
|
|
|
(define-who $ftype-guardian-oops
|
|
(lambda (ftd obj)
|
|
($oops 'ftype-guardian "~s is not an ftype pointer of the expected type ~s" obj ftd)))
|
|
|
|
(define make-guardian (lambda () (#2%make-guardian)))
|
|
|
|
(define $make-ftype-guardian (lambda (ftd) (#2%$make-ftype-guardian ftd)))
|
|
|
|
(define $address-in-heap?
|
|
(foreign-procedure "(cs)s_addr_in_heap" (uptr) boolean))
|
|
|
|
(define $object-in-heap?
|
|
(foreign-procedure "(cs)s_ptr_in_heap" (ptr) boolean))
|
|
|
|
(define $event (lambda () ($event)))
|
|
|
|
(define $tc (lambda () ($tc)))
|
|
(define $thread-list (lambda () ($thread-list)))
|
|
|
|
(define $tc-field
|
|
(let ()
|
|
(define bogus
|
|
(lambda (fld)
|
|
($oops '$tc-field "invalid tc field ~s" fld)))
|
|
(define-syntax alpha
|
|
(with-syntax ([(param ...)
|
|
(fold-left
|
|
(lambda (ls field)
|
|
(apply
|
|
(lambda (name type disp len)
|
|
(if (eq? type 'ptr)
|
|
(cons (datum->syntax #'* name) ls)
|
|
ls))
|
|
field))
|
|
'() (getprop 'tc '*fields* '()))])
|
|
(lambda (x)
|
|
#'(case-lambda
|
|
[(fld tc)
|
|
(case fld
|
|
[(param) ($tc-field 'param tc)]
|
|
...
|
|
[else (bogus fld)])]
|
|
[(fld tc v)
|
|
(case fld
|
|
[(param) ($tc-field 'param tc v)]
|
|
...
|
|
[else (bogus fld)])]))))
|
|
alpha))
|
|
|
|
(define virtual-register-count (lambda () (#2%virtual-register-count)))
|
|
(define virtual-register (lambda (idx) (#2%virtual-register idx)))
|
|
(define set-virtual-register! (lambda (idx val) (#2%set-virtual-register! idx val)))
|
|
|
|
(define thread? (lambda (x) (thread? x)))
|
|
(define $thread-tc
|
|
(lambda (thread)
|
|
(unless (thread? thread)
|
|
($oops '$thread-tc "~s is not a thread" thread))
|
|
($thread-tc thread)))
|
|
|
|
(when-feature pthreads
|
|
|
|
(define $raw-collect-cond (lambda () ($raw-collect-cond)))
|
|
(define $raw-tc-mutex (lambda () ($raw-tc-mutex)))
|
|
(define fork-thread)
|
|
(define make-mutex)
|
|
(define mutex?)
|
|
(define mutex-acquire)
|
|
(define mutex-release)
|
|
(define make-condition)
|
|
(define thread-condition?)
|
|
(define condition-wait)
|
|
(define condition-signal)
|
|
(define condition-broadcast)
|
|
(define $close-resurrected-mutexes&conditions)
|
|
(define $tc-mutex)
|
|
(define $collect-cond)
|
|
(let ()
|
|
; scheme-object's below are mutex and condition addresses, which are
|
|
; assumed to be at least ptr aligned and therefore look like fixnums
|
|
(define ft (foreign-procedure "(cs)fork_thread" (scheme-object)
|
|
scheme-object))
|
|
(define mm (foreign-procedure "(cs)make_mutex" () scheme-object))
|
|
(define mf (foreign-procedure "(cs)mutex_free" (scheme-object) void))
|
|
(define ma (foreign-procedure "(cs)mutex_acquire" (scheme-object) void))
|
|
(define ma-nb (foreign-procedure "(cs)mutex_acquire_noblock" (scheme-object)
|
|
scheme-object))
|
|
(define mr (foreign-procedure "(cs)mutex_release" (scheme-object) void))
|
|
(define mc (foreign-procedure "(cs)make_condition" () scheme-object))
|
|
(define cf (foreign-procedure "(cs)condition_free" (scheme-object) void))
|
|
(define cw (foreign-procedure "(cs)condition_wait" (scheme-object scheme-object scheme-object) boolean))
|
|
(define cb (foreign-procedure "(cs)condition_broadcast" (scheme-object) void))
|
|
(define cs (foreign-procedure "(cs)condition_signal" (scheme-object) void))
|
|
|
|
(define-record-type (condition $make-condition $condition?)
|
|
(fields (mutable addr $condition-addr $condition-addr-set!))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(define-record-type (mutex $make-mutex $mutex?)
|
|
(fields (mutable addr $mutex-addr $mutex-addr-set!))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(define mutex-guardian (make-guardian))
|
|
(define condition-guardian (make-guardian))
|
|
|
|
(set! fork-thread
|
|
(lambda (t)
|
|
(unless (procedure? t)
|
|
($oops 'fork-thread "~s is not a procedure" t))
|
|
(ft (lambda ()
|
|
(call/cc
|
|
(lambda (k)
|
|
(parameterize ([abort-handler
|
|
(case-lambda [() (k -1)] [(x) (k x)])]
|
|
[exit-handler
|
|
(case-lambda [() (k (void))] [(x . args) (k x)])]
|
|
[reset-handler (lambda () (k (void)))])
|
|
(t)
|
|
(void))))))))
|
|
|
|
(set! make-mutex
|
|
(lambda ()
|
|
(let ([m ($make-mutex (mm))])
|
|
(mutex-guardian m)
|
|
m)))
|
|
|
|
(set! mutex?
|
|
(lambda (x)
|
|
($mutex? x)))
|
|
|
|
(set! mutex-acquire
|
|
(case-lambda
|
|
[(m) (mutex-acquire m #t)]
|
|
[(m block?)
|
|
(unless (mutex? m)
|
|
($oops 'mutex-acquire "~s is not a mutex" m))
|
|
(let ([addr ($mutex-addr m)])
|
|
(when (eq? addr 0)
|
|
($oops 'mutex-acquire "mutex is defunct"))
|
|
(let ([r ((if block? ma ma-nb) addr)])
|
|
($keep-live m)
|
|
r))]))
|
|
|
|
(set! mutex-release
|
|
(lambda (m)
|
|
(unless (mutex? m)
|
|
($oops 'mutex-release "~s is not a mutex" m))
|
|
(let ([addr ($mutex-addr m)])
|
|
(when (eq? addr 0)
|
|
($oops 'mutex-release "mutex is defunct"))
|
|
(mr addr))))
|
|
|
|
(set! make-condition
|
|
(lambda ()
|
|
(let ([c ($make-condition (mc))])
|
|
(condition-guardian c)
|
|
c)))
|
|
|
|
(set! thread-condition?
|
|
(lambda (x)
|
|
($condition? x)))
|
|
|
|
(set! condition-wait
|
|
(case-lambda
|
|
[(c m) (condition-wait c m #f)]
|
|
[(c m t)
|
|
(unless (thread-condition? c)
|
|
($oops 'condition-wait "~s is not a condition" c))
|
|
(unless (mutex? m)
|
|
($oops 'condition-wait "~s is not a mutex" m))
|
|
(unless (or (not t)
|
|
(and (time? t) (memq (time-type t) '(time-duration time-utc))))
|
|
($oops 'condition-wait "~s is not a time record of type time-duration or time-utc" t))
|
|
(let ([caddr ($condition-addr c)] [maddr ($mutex-addr m)])
|
|
(when (eq? caddr 0)
|
|
($oops 'condition-wait "condition is defunct"))
|
|
(when (eq? maddr 0)
|
|
($oops 'condition-wait "mutex is defunct"))
|
|
(let ([r (cw caddr maddr t)])
|
|
($keep-live c)
|
|
($keep-live m)
|
|
r))]))
|
|
|
|
(set! condition-broadcast
|
|
(lambda (c)
|
|
(unless (thread-condition? c)
|
|
($oops 'condition-broadcast "~s is not a condition" c))
|
|
(let ([addr ($condition-addr c)])
|
|
(when (eq? addr 0)
|
|
($oops 'condition-broadcast "condition is defunct"))
|
|
(cb addr))))
|
|
|
|
(set! condition-signal
|
|
(lambda (c)
|
|
(unless (thread-condition? c)
|
|
($oops 'condition-signal "~s is not a condition" c))
|
|
(let ([addr ($condition-addr c)])
|
|
(when (eq? addr 0)
|
|
($oops 'condition-signal "condition is defunct"))
|
|
(cs addr))))
|
|
|
|
(set! $close-resurrected-mutexes&conditions
|
|
; called from single-threaded docollect
|
|
(lambda ()
|
|
(let f ()
|
|
(let mg ([m (mutex-guardian)])
|
|
(when m
|
|
(let ([addr ($mutex-addr m)])
|
|
(unless (eq? addr 0)
|
|
(mf addr)
|
|
($mutex-addr-set! m 0)))
|
|
(f))))
|
|
(let f ()
|
|
(let cg ([c (condition-guardian)])
|
|
(when c
|
|
(let ([addr ($condition-addr c)])
|
|
(unless (eq? addr 0)
|
|
(cf addr)
|
|
($condition-addr-set! c 0)))
|
|
(f))))))
|
|
|
|
(set! $tc-mutex ($make-mutex ($raw-tc-mutex)))
|
|
(set! $collect-cond ($make-condition ($raw-collect-cond)))
|
|
))
|
|
|
|
(let ()
|
|
(define-syntax define-tc-parameter
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name pred type init)
|
|
#'(begin (define-tc-parameter name pred type) (name init))]
|
|
[(_ name pred type)
|
|
(with-syntax ([msg (format "~~s is not ~a" (datum type))])
|
|
#'(set! name
|
|
(case-lambda
|
|
[() (name)]
|
|
[(x)
|
|
(unless (pred x) ($oops 'name msg x))
|
|
(name x)])))])))
|
|
(define-tc-parameter current-input-port (lambda (x) (and (input-port? x) (textual-port? x))) "a textual input port")
|
|
(define-tc-parameter current-output-port (lambda (x) (and (output-port? x) (textual-port? x))) "a textual output port")
|
|
(define-tc-parameter current-error-port (lambda (x) (and (output-port? x) (textual-port? x))) "a textual output port")
|
|
(define-tc-parameter $block-counter (lambda (x) (and (fixnum? x) (fx<= x 0))) "a nonpositive fixnum" 0)
|
|
(define-tc-parameter $sfd (lambda (x) (or (eq? x #f) (source-file-descriptor? x))) "a source-file descriptor or #f" #f)
|
|
(define-tc-parameter $current-mso (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
|
|
(define-tc-parameter $target-machine symbol? "a symbol")
|
|
(define-tc-parameter optimize-level (lambda (x) (and (fixnum? x) (fx<= 0 x 3))) "valid optimize level" 0)
|
|
(define-tc-parameter $compile-profile (lambda (x) (memq x '(#f source block))) "valid compile-profile flag" #f)
|
|
(define-tc-parameter subset-mode (lambda (mode) (memq mode '(#f system))) "valid subset mode" #f)
|
|
(define-tc-parameter default-record-equal-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
|
|
(define-tc-parameter default-record-hash-procedure (lambda (x) (or (eq? x #f) (procedure? x))) "a procedure or #f" #f)
|
|
)
|
|
|
|
(define-who compile-profile
|
|
; this wrapper is used to filter #t => source
|
|
(case-lambda
|
|
[() ($compile-profile)]
|
|
[(x)
|
|
($compile-profile
|
|
(case x
|
|
[(#f source block) x]
|
|
[(#t) 'source]
|
|
[else ($oops who "invalid mode ~s [must be #f, #t, source, or block]" x)]))]))
|
|
|
|
(let ()
|
|
(define-syntax define-boolean-tc-parameter
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(_ name init)
|
|
#'(begin
|
|
(set! name
|
|
(case-lambda
|
|
[() (name)]
|
|
[(x) (name (and x #t))]))
|
|
(name init))])))
|
|
(define-boolean-tc-parameter generate-inspector-information #t)
|
|
(define-boolean-tc-parameter generate-procedure-source-information #f)
|
|
(define-boolean-tc-parameter generate-profile-forms #t)
|
|
(define-boolean-tc-parameter $suppress-primitive-inlining #f)
|
|
)
|
|
|
|
(define $make-tlc
|
|
(lambda (ht keyval next)
|
|
(unless (eq-hashtable? ht)
|
|
($oops '$make-tlc "~s is not an eq hashtable" ht))
|
|
(unless (or ($tlc? next) (fixnum? next))
|
|
($oops '$make-tlc "invalid next argument ~s" next))
|
|
(unless (pair? keyval)
|
|
($oops '$make-tlc "invalid keyval argument ~s" keyval))
|
|
(#3%$make-tlc ht keyval next)))
|
|
|
|
(define $tlc? (lambda (x) (#3%$tlc? x)))
|
|
|
|
(let ()
|
|
(define-syntax define-tlc-parameter
|
|
(syntax-rules ()
|
|
[(_ name)
|
|
(set! name
|
|
(lambda (tlc)
|
|
(unless ($tlc? tlc) ($oops 'name "~s is not a tlc" tlc))
|
|
(#3%name tlc)))]
|
|
[(_ name name!)
|
|
(begin
|
|
(define-tlc-parameter name)
|
|
(set! name!
|
|
(lambda (tlc x)
|
|
(unless ($tlc? tlc) ($oops 'name "~s is not a tlc" tlc))
|
|
(#3%name! tlc x))))]))
|
|
(define-tlc-parameter $tlc-keyval)
|
|
(define-tlc-parameter $tlc-ht)
|
|
(define-tlc-parameter $tlc-next $set-tlc-next!)
|
|
)
|
|
|
|
(define ($fxaddress x) (#3%$fxaddress x))
|
|
|
|
(define $logand
|
|
(foreign-procedure "(cs)logand"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logor
|
|
(foreign-procedure "(cs)logor"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logxor
|
|
(foreign-procedure "(cs)logxor"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $lognot
|
|
(foreign-procedure "(cs)lognot"
|
|
(scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logbit?
|
|
(foreign-procedure "(cs)logbitp"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logbit0
|
|
(foreign-procedure "(cs)logbit0"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logbit1
|
|
(foreign-procedure "(cs)logbit1"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(define $logtest
|
|
(foreign-procedure "(cs)logtest"
|
|
(scheme-object scheme-object)
|
|
scheme-object))
|
|
|
|
(when-feature windows
|
|
(define get-registry
|
|
(let ([fp (foreign-procedure "(windows)GetRegistry"
|
|
(wstring)
|
|
scheme-object)])
|
|
(lambda (s)
|
|
(unless (string? s) ($oops 'get-registry "~s is not a string" s))
|
|
(let ([x (fp s)])
|
|
(and x (utf16->string x (constant native-endianness)))))))
|
|
|
|
(define put-registry!
|
|
(let ([fp (foreign-procedure "(windows)PutRegistry"
|
|
(wstring wstring)
|
|
void)])
|
|
(lambda (s1 s2)
|
|
(unless (string? s1) ($oops 'put-registry! "~s is not a string" s1))
|
|
(unless (string? s2) ($oops 'put-registry! "~s is not a string" s2))
|
|
(fp s1 s2))))
|
|
|
|
(define remove-registry!
|
|
(let ([fp (foreign-procedure "(windows)RemoveRegistry"
|
|
(wstring)
|
|
void)])
|
|
(lambda (s)
|
|
(unless (string? s) ($oops 'remove-registry! "~s is not a string" s))
|
|
(fp s))))
|
|
)
|
|
|
|
(define ($real->flonum x who)
|
|
(unless (or (not who) (symbol? who) (string? who))
|
|
($oops '$real->flonum "invalid who argument ~s" who))
|
|
(#3%$real->flonum x who))
|
|
|
|
(define (real->flonum x) (#2%real->flonum x))
|
|
|
|
(define $integer-8? (lambda (x) (#3%$integer-8? x)))
|
|
(define $integer-16? (lambda (x) (#3%$integer-16? x)))
|
|
(define $integer-24? (lambda (x) (#3%$integer-24? x)))
|
|
(define $integer-32? (lambda (x) (#3%$integer-32? x)))
|
|
(define $integer-40? (lambda (x) (#3%$integer-40? x)))
|
|
(define $integer-48? (lambda (x) (#3%$integer-48? x)))
|
|
(define $integer-56? (lambda (x) (#3%$integer-56? x)))
|
|
(define $integer-64? (lambda (x) (#3%$integer-64? x)))
|
|
(define $foreign-char? (lambda (x) (#3%$foreign-char? x)))
|
|
(define $foreign-wchar? (lambda (x) (#3%$foreign-wchar? x)))
|
|
|
|
(define $byte-copy!
|
|
(foreign-procedure "(cs)byte-copy"
|
|
(scheme-object fixnum scheme-object fixnum fixnum)
|
|
void))
|
|
|
|
(define $ptr-copy!
|
|
(foreign-procedure "(cs)ptr-copy"
|
|
(scheme-object fixnum scheme-object fixnum fixnum)
|
|
void))
|
|
|
|
(define-who ($sealed-record? x rtd)
|
|
(unless (record-type-descriptor? rtd)
|
|
($oops who "~s is not a record type descriptor" rtd))
|
|
(#3%$sealed-record? x rtd))
|
|
|
|
(define ($record? x) (#3%$record? x))
|
|
|
|
(define-who ($record-type-descriptor r)
|
|
(unless ($record? r) ($oops who "~s is not a record" r))
|
|
(#3%$record-type-descriptor r))
|
|
|
|
(define-who utf8->string
|
|
(let ()
|
|
(define slurp
|
|
(lambda (bv start)
|
|
(let ([n (bytevector-length bv)])
|
|
(let ([s (make-string (fx- n start))])
|
|
(define (fini j)
|
|
(if (fx= j (string-length s))
|
|
s
|
|
(string-truncate! s j)))
|
|
(let loop ([i start] [j 0])
|
|
(if (fx= i n)
|
|
(fini j)
|
|
(let ([b1 (bytevector-u8-ref bv i)])
|
|
(cond
|
|
[(fx<= b1 #x7f) ; one-byte encoding
|
|
(string-set! s j (integer->char b1))
|
|
(loop (fx+ i 1) (fx+ j 1))]
|
|
[(fx<= #xc0 b1 #xdf) ; two-byte encoding
|
|
(if (fx< i (fx- n 1)) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(begin
|
|
(string-set! s j
|
|
(let ([x (fxlogor (fxsll (fxlogand b1 #b11111) 6) (fxlogand b2 #b111111))])
|
|
(if (fx<= x #x7f) #\xfffd (integer->char x))))
|
|
(loop (fx+ i 2) (fx+ j 1)))
|
|
; second byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 1) (fx+ j 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))]
|
|
[(fx<= #xe0 b1 #xef) ; three-byte encoding
|
|
(if (fx< i (fx- n 1)) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(if (fx< i (fx- n 2)) ; have at least three bytes?
|
|
(let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
|
|
(if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
|
|
(begin
|
|
(string-set! s j
|
|
(let ([x (fxlogor
|
|
(fxsll (fxlogand b1 #b1111) 12)
|
|
(fxsll (fxlogand b2 #b111111) 6)
|
|
(fxlogand b3 #b111111))])
|
|
(if (and (fx>= x #x800) (not (fx<= #xd800 x #xdfff)))
|
|
(integer->char x)
|
|
#\xfffd)))
|
|
(loop (fx+ i 3) (fx+ j 1)))
|
|
; third byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 2) (fx+ j 1)))))
|
|
; have only two bytes
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))
|
|
; second byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 1) (fx+ j 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))]
|
|
[(fx<= #xf0 b1 #xf4) ; four-byte encoding
|
|
(if (fx< i (fx- n 1)) ; have at least two bytes?
|
|
(let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
|
|
(if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
|
|
(if (fx< i (fx- n 2)) ; have at least three bytes?
|
|
(let ([b3 (bytevector-u8-ref bv (fx+ i 2))])
|
|
(if (fx= (fxsrl b3 6) #b10) ; third byte a continuation byte?
|
|
(if (fx< i (fx- n 3)) ; have at least four bytes?
|
|
(let ([b4 (bytevector-u8-ref bv (fx+ i 3))])
|
|
(if (fx= (fxsrl b4 6) #b10) ; fourth byte a continuation byte?
|
|
(begin
|
|
(string-set! s j
|
|
(let ([x (fxlogor
|
|
(fxsll (fxlogand b1 #b111) 18)
|
|
(fxsll (fxlogand b2 #b111111) 12)
|
|
(fxsll (fxlogand b3 #b111111) 6)
|
|
(fxlogand b4 #b111111))])
|
|
(if (fx<= #x10000 x #x10ffff)
|
|
(integer->char x)
|
|
#\xfffd)))
|
|
(loop (fx+ i 4) (fx+ j 1)))
|
|
; fourth byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 3) (fx+ j 1)))))
|
|
; have only three bytes
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))
|
|
; third byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 2) (fx+ j 1)))))
|
|
; have only two bytes
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))
|
|
; second byte is not a continuation byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 1) (fx+ j 1)))))
|
|
; have only one byte
|
|
(begin
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))))]
|
|
[else
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 1) (fx+ j 1))]))))))))
|
|
(lambda (bv)
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(slurp bv
|
|
(if (and (fx>= (bytevector-length bv) 3)
|
|
(fx= (bytevector-u8-ref bv 0) #xef)
|
|
(fx= (bytevector-u8-ref bv 1) #xbb)
|
|
(fx= (bytevector-u8-ref bv 2) #xbf))
|
|
3 0)))))
|
|
|
|
(let ()
|
|
(define ($string->utf8 s nul?)
|
|
(let ([sn (string-length s)])
|
|
(let ([bv (do ([si 0 (fx+ si 1)]
|
|
[bvn 0 (+ bvn (let ([k (char->integer (string-ref s si))])
|
|
(if (fx<= k #x7ff)
|
|
(if (fx<= k #x7f) 1 2)
|
|
(if (fx<= k #xffff) 3 4))))])
|
|
((fx= si sn)
|
|
(if nul?
|
|
(let ([real-bvn (fx+ bvn 1)])
|
|
(unless (fixnum? real-bvn)
|
|
($oops 'string->utf8 "result would be too large"))
|
|
(let ([bv (make-bytevector real-bvn)])
|
|
(bytevector-u8-set! bv bvn 0)
|
|
bv))
|
|
(begin
|
|
(unless (fixnum? bvn)
|
|
($oops 'string->utf8 "result would be too large"))
|
|
(make-bytevector bvn)))))])
|
|
(let f ([si 0] [bvi 0])
|
|
(if (fx= si sn)
|
|
bv
|
|
(let ([k (char->integer (string-ref s si))])
|
|
(if (fx<= k #x7ff)
|
|
(if (fx<= k #x7f)
|
|
(begin
|
|
(bytevector-u8-set! bv bvi k)
|
|
(f (fx+ si 1) (fx+ bvi 1)))
|
|
(begin
|
|
(bytevector-u8-set! bv bvi (fxlogor #b11000000 (fxsrl k 6)))
|
|
(bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand k #b111111)))
|
|
(f (fx+ si 1) (fx+ bvi 2))))
|
|
(if (fx<= k #xffff)
|
|
(begin
|
|
(bytevector-u8-set! bv bvi (fxlogor #b11100000 (fxsrl k 12)))
|
|
(bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand (fxsrl k 6) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ bvi 2) (fxlogor #b10000000 (fxlogand k #b111111)))
|
|
(f (fx+ si 1) (fx+ bvi 3)))
|
|
(begin
|
|
(bytevector-u8-set! bv bvi (fxlogor #b11110000 (fxsrl k 18)))
|
|
(bytevector-u8-set! bv (fx+ bvi 1) (fxlogor #b10000000 (fxlogand (fxsrl k 12) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ bvi 2) (fxlogor #b10000000 (fxlogand (fxsrl k 6) #b111111)))
|
|
(bytevector-u8-set! bv (fx+ bvi 3) (fxlogor #b10000000 (fxlogand k #b111111)))
|
|
(f (fx+ si 1) (fx+ bvi 4)))))))))))
|
|
(set! $fp-string->utf8
|
|
(lambda (s)
|
|
($string->utf8 s #t)))
|
|
(set-who! string->utf8
|
|
(lambda (s)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
($string->utf8 s #f))))
|
|
|
|
(define-who utf16->string
|
|
(let ()
|
|
(define slurp
|
|
(lambda (bv eness start)
|
|
(let ([n (bytevector-length bv)])
|
|
(let ([s (make-string (fxsrl (fx+ (fx- n start) 1) 1))])
|
|
(define (fini j)
|
|
(if (fx= j (string-length s))
|
|
s
|
|
(string-truncate! s j)))
|
|
(define-syntax go
|
|
(syntax-rules ()
|
|
[(_ bv-u16-ref)
|
|
(let loop ([i start] [j 0])
|
|
(cond
|
|
[(fx= i n) (fini j)]
|
|
[(fx= i (fx- n 1))
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))]
|
|
[else
|
|
(let ([w1 (bv-u16-ref bv i)])
|
|
(cond
|
|
[(fx<= #xD800 w1 #xDBFF) ; two-word encoding
|
|
(cond
|
|
[(fx>= i (fx- n 3))
|
|
(string-set! s j #\xfffd)
|
|
(fini (fx+ j 1))]
|
|
[else
|
|
(let ([w2 (bv-u16-ref bv (fx+ i 2))])
|
|
(string-set! s j
|
|
(if (fx<= #xDC00 w2 #xDFFF)
|
|
(integer->char
|
|
(fx+ (fxlogor
|
|
(fxsll (fx- w1 #xD800) 10)
|
|
(fx- w2 #xDC00))
|
|
#x10000))
|
|
#\xfffd))
|
|
(loop (fx+ i 4) (fx+ j 1)))])]
|
|
[(fx<= #xDC00 w1 #xDFFF) ; misplaced continuation word
|
|
(string-set! s j #\xfffd)
|
|
(loop (fx+ i 2) (fx+ j 1))]
|
|
[else
|
|
(string-set! s j (integer->char w1))
|
|
(loop (fx+ i 2) (fx+ j 1))]))]))]))
|
|
(if (eq? eness (constant native-endianness))
|
|
(go bytevector-u16-native-ref)
|
|
(go (lambda (bv i) (bytevector-u16-ref bv i eness))))))))
|
|
(rec utf16->string
|
|
(case-lambda
|
|
[(bv eness) (utf16->string bv eness #f)]
|
|
[(bv eness mandatory?)
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
|
|
(if (or mandatory? (< (bytevector-length bv) 2))
|
|
(slurp bv eness 0)
|
|
(let ([BOM (bytevector-u16-native-ref bv 0)])
|
|
(if (fx= BOM #xfeff)
|
|
(slurp bv (constant native-endianness) 2)
|
|
(if (fx= BOM #xfffe)
|
|
(slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 2)
|
|
(slurp bv eness 0)))))]))))
|
|
|
|
(let ()
|
|
(define ($string->utf16 s eness nul?)
|
|
(let ([sn (string-length s)])
|
|
(let ([bv (do ([si 0 (fx+ si 1)]
|
|
[bvn 0 (+ bvn (if (char<=? (string-ref s si) #\xffff) 2 4))])
|
|
((fx= si sn)
|
|
(if nul?
|
|
(let ([real-bvn (+ bvn 2)])
|
|
(unless (fixnum? real-bvn)
|
|
($oops 'string->utf16 "result would be too large"))
|
|
(let ([bv (make-bytevector real-bvn)])
|
|
(bytevector-u16-native-set! bv bvn 0)
|
|
bv))
|
|
(begin
|
|
(unless (fixnum? bvn)
|
|
($oops 'string->utf16 "result would be too large"))
|
|
(make-bytevector bvn)))))])
|
|
(define-syntax go
|
|
(syntax-rules ()
|
|
[(_ bv-u16-set!)
|
|
(let f ([si 0] [bvi 0])
|
|
(unless (fx= si sn)
|
|
(let ([x (char->integer (string-ref s si))])
|
|
(if (fx<= x #xffff)
|
|
(begin
|
|
(bv-u16-set! bv bvi x)
|
|
(f (fx+ si 1) (fx+ bvi 2)))
|
|
(let ([x (fx- x #x10000)])
|
|
(bv-u16-set! bv bvi (fxior #xD800 (fxsrl x 10)))
|
|
(bv-u16-set! bv (fx+ bvi 2) (fxior #xDC00 (fxand x #x3ff)))
|
|
(f (fx+ si 1) (fx+ bvi 4)))))))]))
|
|
(if (eq? eness (constant native-endianness))
|
|
(go bytevector-u16-native-set!)
|
|
(go (lambda (bv i n) (bytevector-u16-set! bv i n eness))))
|
|
bv)))
|
|
(set! $fp-string->utf16
|
|
(lambda (s eness)
|
|
($string->utf16 s eness #t)))
|
|
(set-who! string->utf16
|
|
(rec string->utf16
|
|
(case-lambda
|
|
[(s)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
($string->utf16 s 'big #f)]
|
|
[(s eness)
|
|
(unless (string? s) ($oops who "~s is not a string" s))
|
|
(unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
|
|
($string->utf16 s eness #f)]))))
|
|
|
|
(define-who utf32->string
|
|
(let ()
|
|
(define slurp
|
|
(lambda (bv eness start)
|
|
(let ([n (bytevector-length bv)])
|
|
(let ([s (make-string (fxsrl (fx+ (fx- n start) 3) 2))])
|
|
(define-syntax go
|
|
(syntax-rules ()
|
|
[(_ bv-u32-ref)
|
|
(let loop ([i start] [j 0])
|
|
(cond
|
|
[(fx= i n) s]
|
|
[(fx>= i (fx- n 3))
|
|
(string-set! s j #\xfffd)
|
|
s]
|
|
[else
|
|
(let ([x (bv-u32-ref bv i)])
|
|
(string-set! s j
|
|
(if (and (fixnum? x) (fx<= x #x10ffff) (not (fx<= #xd800 x #xdfff)))
|
|
(integer->char x)
|
|
#\xfffd))
|
|
(loop (fx+ i 4) (fx+ j 1)))]))]))
|
|
(if (eq? eness (constant native-endianness))
|
|
(go bytevector-u32-native-ref)
|
|
(go (lambda (bv i) (bytevector-u32-ref bv i eness))))))))
|
|
(rec utf32->string
|
|
(case-lambda
|
|
[(bv eness) (utf32->string bv eness #f)]
|
|
[(bv eness mandatory?)
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
|
|
(if (or mandatory? (< (bytevector-length bv) 4))
|
|
(slurp bv eness 0)
|
|
(let ([BOM (bytevector-u32-native-ref bv 0)])
|
|
(if (and (fixnum? BOM) (fx= BOM #xfeff))
|
|
(slurp bv (constant native-endianness) 4)
|
|
(if (= BOM #xfffe0000)
|
|
(slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 4)
|
|
(slurp bv eness 0)))))]))))
|
|
|
|
(let ()
|
|
(define ($string->utf32 s eness nul?)
|
|
(let ([sn (string-length s)])
|
|
(unless (fx<= (if nul? sn (fx+ sn 1)) (fxsrl (greatest-fixnum) 2))
|
|
($oops 'string->utf32 "result would be too large"))
|
|
(let ([bv (if nul?
|
|
(let* ([bvn (fxsll sn 2)] [bv (make-bytevector (fx+ bvn 4))])
|
|
(bytevector-u32-native-set! bv bvn 0)
|
|
bv)
|
|
(make-bytevector (fxsll sn 2)))])
|
|
(define-syntax go
|
|
(syntax-rules ()
|
|
[(_ bv-u32-set!)
|
|
(do ([si 0 (fx+ si 1)])
|
|
((fx= si sn))
|
|
(bv-u32-set! bv (fxsll si 2) (char->integer (string-ref s si))))]))
|
|
(if (eq? eness (constant native-endianness))
|
|
(go bytevector-u32-native-set!)
|
|
(go (lambda (bv i n) (bytevector-u32-set! bv i n eness))))
|
|
bv)))
|
|
(set! $fp-string->utf32
|
|
(lambda (s eness)
|
|
($string->utf32 s eness #t)))
|
|
(set-who! string->utf32
|
|
(rec string->utf32
|
|
(case-lambda
|
|
[(s)
|
|
(type-check who string s)
|
|
($string->utf32 s 'big #f)]
|
|
[(s eness)
|
|
(type-check who string s)
|
|
(unless (memq eness '(big little)) ($oops who "invalid endianness ~s" eness))
|
|
($string->utf32 s eness #f)]))))
|
|
|
|
(define $breakhere (foreign-procedure "(cs)s_breakhere" (ptr) void))
|
|
|
|
(define $errno->string (foreign-procedure "(cs)s_strerror" (int) scheme-object))
|
|
|
|
(define $errno (foreign-procedure "(cs)s_errno" () int))
|
|
|
|
(define interactive? (foreign-procedure "(cs)s_interactivep" () boolean))
|
|
|
|
(define-who $read-performance-monitoring-counter
|
|
(lambda (x)
|
|
; might should check valid range (which is fixed by the hardware we are running on)
|
|
(type-check who fixnum x)
|
|
(#3%$read-performance-monitoring-counter x)))
|
|
|
|
(define $read-time-stamp-counter
|
|
(lambda ()
|
|
(#3%$read-time-stamp-counter)))
|
|
|
|
(define $keep-live
|
|
(lambda (x)
|
|
(#2%$keep-live x)))
|
|
|
|
(when-feature windows
|
|
(let ()
|
|
(define mbtwc
|
|
(foreign-procedure "(cs)s_multibytetowidechar"
|
|
(unsigned ptr)
|
|
ptr))
|
|
(define wctmb
|
|
(foreign-procedure "(cs)s_widechartomultibyte"
|
|
(unsigned ptr)
|
|
ptr))
|
|
(define (cp->unsigned who cp)
|
|
(case cp
|
|
[(cp-acp) 0]
|
|
[(cp-maccp) 2]
|
|
[(cp-oemcp) 1]
|
|
[(cp-symbol) 42]
|
|
[(cp-thread-acp) 3]
|
|
[(cp-utf7) 65000]
|
|
[(cp-utf8) 65001]
|
|
[else
|
|
(if (and (fixnum? cp) (fx>= cp 0))
|
|
cp
|
|
($oops who "invalid code page ~s" cp))]))
|
|
(set-who! multibyte->string
|
|
(lambda (cp bv)
|
|
(let ([cp (cp->unsigned who cp)])
|
|
(unless (bytevector? bv) ($oops who "~s is not a bytevector" bv))
|
|
(utf16->string (mbtwc cp bv) 'little #t))))
|
|
(set-who! string->multibyte
|
|
(lambda (cp str)
|
|
(let ([cp (cp->unsigned who cp)])
|
|
(unless (string? str) ($oops who "~s is not a string" str))
|
|
(wctmb cp (string->utf16 str 'little))))))
|
|
)
|