2110 lines
72 KiB
Scheme
2110 lines
72 KiB
Scheme
"prims.ss"
|
|
;;; prims.ss
|
|
;;; Copyright 1984-2016 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 $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))))
|
|
|
|
(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 (bytevector? bv) ($oops who "~s is not a 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 (string? st) ($oops who "~s is not a 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)
|
|
; if this fails, we have to change the test and message below
|
|
(meta-assert (= (constant maximum-string-length) (constant most-positive-fixnum)))
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops who "~s is not a nonnegative fixnum" n))
|
|
(unless (char? c)
|
|
($oops who "~s is not a character" c))
|
|
(make-string n c)]
|
|
[(n)
|
|
; if this fails, we have to change the test and message below
|
|
(meta-assert (= (constant maximum-string-length) (constant most-positive-fixnum)))
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops who "~s is not a nonnegative fixnum" n))
|
|
(make-string n)]))
|
|
|
|
(define make-vector
|
|
(case-lambda
|
|
[(n x)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops 'make-vector "~s is not a nonnegative fixnum" n))
|
|
(make-vector n x)]
|
|
[(n)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops 'make-vector "~s is not a nonnegative fixnum" n))
|
|
(make-vector n)]))
|
|
|
|
(define $make-eqhash-vector
|
|
(case-lambda
|
|
[(n)
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops '$make-eqhash-vector "~s is not a nonnegative fixnum" n))
|
|
($make-eqhash-vector n)]))
|
|
|
|
(define-who make-fxvector
|
|
(case-lambda
|
|
[(n x)
|
|
; if this fails, we have to change the test and message below
|
|
(meta-assert (= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops who "~s is not a nonnegative fixnum" n))
|
|
(unless (fixnum? x)
|
|
($oops who "~s is not a fixnum" x))
|
|
(make-fxvector n x)]
|
|
[(n)
|
|
; if this fails, we have to change the test and message below
|
|
(meta-assert (= (constant maximum-fxvector-length) (constant most-positive-fixnum)))
|
|
(unless (and (fixnum? n) (fx>= n 0))
|
|
($oops who "~s is not a nonnegative fixnum" n))
|
|
(make-fxvector n)]))
|
|
|
|
(define string-fill!
|
|
(lambda (s c)
|
|
(unless (string? s)
|
|
($oops 'string-fill! "~s is not a 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 (fxvector? v)
|
|
($oops 'fxvector-fill! "~s is not an 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 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-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 $vector-ref-check? (lambda (v i) ($vector-ref-check? v i)))
|
|
|
|
(define $fxvector-ref-check? (lambda (v i) ($fxvector-ref-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 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 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 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 unbox
|
|
(lambda (b)
|
|
(if (box? b)
|
|
(unbox b)
|
|
($oops 'unbox "~s is not a box" b))))
|
|
|
|
(define set-box!
|
|
(lambda (b v)
|
|
(if (box? b)
|
|
(set-box! b v)
|
|
($oops 'set-box! "~s is not a 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 $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 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 cw (foreign-procedure "(cs)condition_wait" (scheme-object scheme-object) void))
|
|
(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 (immutable addr $condition-addr))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(define-record-type (mutex $make-mutex $mutex?)
|
|
(fields (immutable addr $mutex-addr))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
|
|
(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 ()
|
|
($make-mutex (mm))))
|
|
|
|
(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))
|
|
((if block? ma ma-nb) ($mutex-addr m))]))
|
|
|
|
(set! mutex-release
|
|
(lambda (m)
|
|
(unless (mutex? m)
|
|
($oops 'mutex-release "~s is not a mutex" m))
|
|
(mr ($mutex-addr m))))
|
|
|
|
(set! make-condition
|
|
(lambda ()
|
|
($make-condition (mc))))
|
|
|
|
(set! thread-condition?
|
|
(lambda (x)
|
|
($condition? x)))
|
|
|
|
(set! condition-wait
|
|
(lambda (c m)
|
|
(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))
|
|
(cw ($condition-addr c) ($mutex-addr m))))
|
|
|
|
(set! condition-broadcast
|
|
(lambda (c)
|
|
(unless (thread-condition? c)
|
|
($oops 'condition-broadcast "~s is not a condition" c))
|
|
(cb ($condition-addr c))))
|
|
|
|
(set! condition-signal
|
|
(lambda (c)
|
|
(unless (thread-condition? c)
|
|
($oops 'condition-signal "~s is not a condition" c))
|
|
(cs ($condition-addr c))))
|
|
|
|
(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 $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-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)))
|
|
|
|
(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))))))
|
|
)
|