f7c414bda3
commonizatio pass and support for specifying default record
equal and hash procedures:
- more staid and consistent Mf-cross main target
Mf-cross
- cpletrec now replaces the incoming prelexes with new ones so
that it doesn't have to alter the flags on the incoming ones, since
the same expander output is passed through the compiler twice while
compiling a file with macro definitions or libraries. we were
getting away without this just by luck.
cpletrec.ss
- pure? and ivory? now return #t for a primref only if the prim is
declared to be a proc, since some non-proc prims are mutable, e.g.,
$active-threads and $collect-request-pending.
cp0.ss
- $error-handling-mode? and $eol-style? are now properly declared to
be procs rather than system state variables.
primdata.ss
- the new pass $check-prelex-flags verifies that prelex referenced,
multiply-referenced, and assigned flags are set when they
should be. (it doesn't, however, complain if a flag is set
when it need not be.) when the new system parameter
$enable-check-prelex-flags is set, $check-prelex-flags is
called after each major pass that produces Lsrc forms to verify
that the flags are set correctly in the output of the pass.
this parameter is unset by default but set when running the
mats.
cprep.ss, back.ss, compile.ss, primdata.ss,
mats/Mf-base
- removed the unnecessary set of prelex referenced flag from the
build-ref routines when we've just established that it is set.
syntax.ss, compile.ss
- equivalent-expansion? now prints differences to the current output
port to aid in debugging.
mat.ss
- the nanopass that patches calls to library globals into calls to
their local counterparts during whole-program optimization now
creates new prelexes and sets the prelex referenced, multiply
referenced, and assigned flags on the new prelexes rather than
destructively setting flags on the incoming prelexes. The
only known problems this fixes are (1) the multiply referenced
flag was not previously being set for cross-library calls when
it should have been, resulting in overly aggressive inlining
of library exports during whole-program optimization, and (2)
the referenced flag could sometimes be set for library exports
that aren't actually used in the final program, which could
prevent some unreachable code from being eliminated.
compile.ss
- added support for specifying default record-equal and
record-hash procedures.
primdata.ss, cmacros.ss, cpnanopass.ss, prims.ss, newhash.ss,
gc.c,
record.ms
- added missing call to relocate for subset-mode tc field, which
wasn't burning us because the only valid non-false value, the
symbol system, is in the static generation after the initial heap
compaction.
gc.c
- added a lambda-commonization pass that runs after the other
source optimizations, particularly inlining, and a new parameter
that controls how hard it works. the value of commonization-level
ranges from 0 through 9, with 0 disabling commonization and 9
maximizing it. The default value is 0 (disabled). At present,
for non-zero level n, the commonizer attempts to commonize
lambda expressions consisting of 2^(10-n) or more nodes.
commonization of one or more lambda expressions requires that
they have identical structure down to the leaf nodes for quote
expressions, references to unassigned variables, and primitives.
So that various downstream optimizations aren't disabled, there
are some additional restrictions, the most important of which
being that call-position expressions must be identical. The
commonizer works by abstracting the code into a helper that
takes the values of the differing leaf nodes as arguments.
the name of the helper is formed by concatenating the names of
the original procedures, separated by '&', and this is the name
that will show up in a stack trace. The source location will
be that of one of the original procedures. Profiling inhibits
commonization, because commonization requires profile source
locations to be identical.
cpcommonize.ss (new), compile.ss, interpret.ss, cprep.ss,
primdata.ss, s/Mf-base,
mats/Mf-base
- cpletrec now always produces a letrec rather than a let for
single immutable lambda bindings, even when not recursive, for
consistent expand/optimize output whether the commonizer is
run or not.
cpletrec.ss,
record.ms
- trans-make-ftype-pointer no longer generates a call to
$verify-ftype-address if the address expression is a call to
ftype-pointer-address.
ftype.ss
original commit: b6a3dcc814b64faacc9310fec4a4531fb3f18dcd
2241 lines
76 KiB
Scheme
2241 lines
76 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-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 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)
|
|
(unless (and (pair? tconc) (pair? (car tconc)) (pair? (cdr tconc))) ($oops who "~s is not a tconc" tconc))
|
|
(#3%$install-guardian obj rep tconc)))
|
|
|
|
(define make-guardian (lambda () (#2%make-guardian)))
|
|
|
|
(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-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"
|
|
(string)
|
|
scheme-object)])
|
|
(lambda (s)
|
|
(unless (string? s) ($oops 'get-registry "~s is not a string" s))
|
|
(let ([x (fp s)])
|
|
(and x (utf8->string x))))))
|
|
|
|
(define put-registry!
|
|
(let ([fp (foreign-procedure "(windows)PutRegistry"
|
|
(string string)
|
|
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"
|
|
(string)
|
|
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<= #xc2 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) #\x8ffd (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))))))
|
|
)
|