suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

unsafe ops (v4.2.1.8)

Browse Source 
svn: r15899
This commit is contained in:
Matthew Flatt 2009-09-06 18:24:46 +00:00
parent d2ecc840a9
commit 8ae0ea9d14
34 changed files with 1954 additions and 620 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/compiler/decompile.ss
View File

@ -13,6 +13,7 @@
(let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns])
(namespace-require ''#%kernel)
(namespace-require ''#%unsafe)
(for/list ([l (namespace-mapped-symbols)])
(cons l (with-handlers ([exn:fail? (lambda (x) #f)])
(compile l))))))]
@ -320,7 +321,7 @@
list list* vector vector-immutable box))]
[(3) (memq (car a) '(eq? = <= < >= >
bitwise-bit-set? char=?
+ - * / min max bitwise-and bitwise-ior
+ - * / quotient remainder min max bitwise-and bitwise-ior
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons
list list* vector vector-immutable))]

9
collects/compiler/zo-parse.ss
View File

@ -113,9 +113,12 @@
(make-compilation-top ld prefix code)]))
(define (read-resolve-prefix v)
(match v
[`(,i ,tv . ,sv)
(make-prefix i (vector->list tv) (vector->list sv))]))
(let-values ([(v unsafe?) (if (integer? (car v))
(values v #f)
(values (cdr v) #t))])
(match v
[`(,i ,tv . ,sv)
(make-prefix i (vector->list tv) (vector->list sv))])))
(define (read-unclosed-procedure v)
(define CLOS_HAS_REST 1)

172
collects/scheme/private/for.ss
View File

@ -4,6 +4,7 @@
"misc.ss"
"define.ss"
"letstx-scheme.ss"
'#%unsafe
(for-syntax '#%kernel
"stx.ss"
"qqstx.ss"
@ -410,7 +411,7 @@
(define (:vector-gen v start stop step)
(values
;; pos->element
(lambda (i) (vector-ref v i))
(lambda (i) (unsafe-vector-ref v i))
;; next-pos
;; Minor optimisation. I assume add1 is faster than \x.x+1
(if (= step 1) add1 (lambda (i) (+ i step)))
@ -953,32 +954,44 @@
(lambda (stx)
(let loop ([stx stx])
(syntax-case stx ()
[[(id) (_ a b step)] #`[(id)
(:do-in
;; outer bindings:
([(start) a] [(end) b] [(inc) step])
;; outer check:
(unless (and (real? start) (real? end) (real? inc))
;; let `in-range' report the error:
(in-range start end inc))
;; loop bindings:
([pos start])
;; pos check
#,(cond
[(not (number? (syntax-e #'step)))
#`(if (step . >= . 0) (< pos end) (> pos end))]
[((syntax-e #'step) . >= . 0)
#'(< pos end)]
[else
#'(> pos end)])
;; inner bindings
([(id) pos])
;; pre guard
#t
;; post guard
#t
;; loop args
((+ pos inc)))]]
[[(id) (_ a b step)] (let ([all-fx?
(and (fixnum? (syntax-e #'a))
(fixnum? (syntax-e #'b))
(memq (syntax-e #'step) '(1 -1)))])
#`[(id)
(:do-in
;; outer bindings:
([(start) a] [(end) b] [(inc) step])
;; outer check:
(unless (and (real? start) (real? end) (real? inc))
;; let `in-range' report the error:
(in-range start end inc))
;; loop bindings:
([pos start])
;; pos check
#,(if all-fx?
;; Special case, can use unsafe ops:
(cond
[((syntax-e #'step) . >= . 0)
#'(unsafe-fx< pos end)]
[else
#'(unsafe-fx> pos end)])
;; General case:
(cond
[(not (number? (syntax-e #'step)))
#`(if (step . >= . 0) (< pos end) (> pos end))]
[((syntax-e #'step) . >= . 0)
#'(< pos end)]
[else
#'(> pos end)]))
;; inner bindings
([(id) pos])
;; pre guard
#t
;; post guard
#t
;; loop args
((#,(if all-fx? #'unsafe-fx+ #'+) pos inc)))])]
[[(id) (_ a b)] (loop #'[(id) (_ a b 1)])]
[[(id) (_ b)] (loop #'[(id) (_ 0 b 1)])]
[_ #f]))))
@ -1035,19 +1048,19 @@
#t
;; post guard
#t
;; loop args
((cdr lst)))]]
;; loop args -- ok to use unsafe-cdr, since car passed
((unsafe-cdr lst)))]]
[_ #f])))
(define-for-syntax (vector-like-gen vector?-id
vector-length-id
unsafe-vector-length-id
in-vector-id
vector-ref-id)
unsafe-vector-ref-id)
(define (in-vector-like stx)
(with-syntax ([vector? vector?-id]
[in-vector in-vector-id]
[vector-length vector-length-id]
[vector-ref vector-ref-id])
[unsafe-vector-length unsafe-vector-length-id]
[unsafe-vector-ref unsafe-vector-ref-id])
(syntax-case stx ()
;; Fast case
[((id) (_ vec-expr))
@ -1057,75 +1070,80 @@
([(vec len) (let ([vec vec-expr])
(unless (vector? vec)
(in-vector vec))
(values vec (vector-length vec)))])
(values vec (unsafe-vector-length vec)))])
;; outer check
#f
;; loop bindings
([pos 0])
;; pos check
(pos . < . len)
(pos . unsafe-fx< . len)
;; inner bindings
([(id) (vector-ref vec pos)])
([(id) (unsafe-vector-ref vec pos)])
;; pre guard
#t
;; post guard
#t
;; loop args
((add1 pos)))]]
((unsafe-fx+ 1 pos)))]]
;; General case
[((id) (_ vec-expr start))
(in-vector-like (syntax ((id) (_ vec-expr start #f 1))))]
[((id) (_ vec-expr start stop))
(in-vector-like (syntax ((id) (_ vec-expr start stop 1))))]
[((id) (_ vec-expr start stop step))
#`[(id)
(:do-in
;; Outer bindings
;; Prevent multiple evaluation
([(v* stop*) (let ([vec vec-expr]
[stop* stop])
(if (and (not stop*) (vector? vec))
(values vec (vector-length vec))
(values vec stop*)))]
[(start*) start]
[(step*) step])
;; Outer check
(when (or (not (vector? v*))
(not (exact-integer? start*))
(not (exact-integer? stop*))
(not (exact-integer? step*))
(zero? step*)
(and (< start* stop*) (< step* 0))
(and (> start* stop*) (> step* 0)))
;; Let in-vector report the error
(in-vector v* start* stop* step*))
;; Loop bindings
([idx start*])
;; Pos guard
#,(cond
[(not (number? (syntax-e #'step)))
(let ([all-fx? (memq (syntax-e #'step) '(1 -1))])
#`[(id)
(:do-in
;; Outer bindings
;; Prevent multiple evaluation
([(v* stop*) (let ([vec vec-expr]
[stop* stop])
(if (and (not stop*) (vector? vec))
(values vec (unsafe-vector-length vec))
(values vec stop*)))]
[(start*) start]
[(step*) step])
;; Outer check
(when (or (not (vector? v*))
(not (exact-integer? start*))
(not (exact-integer? stop*))
(not (exact-integer? step*))
(zero? step*)
(and (< start* stop*) (< step* 0))
(and (> start* stop*) (> step* 0)))
;; Let in-vector report the error
(in-vector v* start* stop* step*))
;; Loop bindings
([idx start*])
;; Pos guard
#,(cond
[(not (number? (syntax-e #'step)))
#`(if (step* . >= . 0) (< idx stop*) (> idx stop*))]
[((syntax-e #'step) . >= . 0)
#'(< idx stop*)]
[else
#'(> idx stop*)])
;; Inner bindings
([(id) (vector-ref v* idx)])
;; Pre guard
#t
;; Post guard
#t
;; Loop args
((+ idx step)))]]
[((syntax-e #'step) . >= . 0)
(if all-fx?
#'(unsafe-fx< idx stop*)
#'(< idx stop*))]
[else
(if all-fx?
#'(unsafe-fx> idx stop*)
#'(> idx stop*))])
;; Inner bindings
([(id) (unsafe-vector-ref v* idx)])
;; Pre guard
#t
;; Post guard
#t
;; Loop args
((#,(if all-fx? #'unsafe-fx+ #'+) idx step)))])]
[_ #f])))
in-vector-like)
(define-sequence-syntax *in-vector
(lambda () #'in-vector)
(vector-like-gen #'vector?
#'vector-length
#'unsafe-vector-length
#'in-vector
#'vector-ref))
#'unsafe-vector-ref))
(define-sequence-syntax *in-string
(lambda () #'in-string)

5
collects/scheme/unsafe/ops.ss Normal file
View File

@ -0,0 +1,5 @@
#lang scheme/base
(require '#%unsafe)
(provide (all-from-out '#%unsafe))

4
collects/scribblings/mzc/decompile.scrbl
View File

@ -76,7 +76,9 @@ Many forms in the decompiled code, such as @scheme[module],
@schemeidfont{#%in}, which indicates that the JIT compiler will
inline the operation. (Inlining information is not part of the
bytecode, but is instead based on an enumeration of primitives that
the JIT is known to handle specially.)}
the JIT is known to handle specially.) Operations from
@schememodname[scheme/unsafe/ops] are always inlined, so
@schemeidfont{#%in} is not shown for them.}
@item{A form @scheme[(#%apply-values _proc _expr)] is equivalent to
@scheme[(call-with-values (lambda () _expr) _proc)], but the run-time

1
collects/scribblings/reference/reference.scrbl
View File

@ -70,6 +70,7 @@ languages.}
@include-section["security.scrbl"]
@include-section["os.scrbl"]
@include-section["memory.scrbl"]
@include-section["unsafe.scrbl"]
@include-section["running.scrbl"]
@;------------------------------------------------------------------------

144
collects/scribblings/reference/unsafe.scrbl Normal file
View File

@ -0,0 +1,144 @@
#lang scribble/doc
@(require "mz.ss"
(for-label scheme/unsafe/ops))
@title[#:tag "unsafe"]{Unsafe Operations}
@defmodule[scheme/unsafe/ops]
All fuctions and forms provided by @schememodname[scheme/base] and
@schememodname[scheme] check their arguments to ensure that the
arguments conform to contracts and other constraints. For example,
@scheme[vector-ref] checks its arguments to ensure that the first
argument is a vector, that the second argument is an exact integer,
and that the second argument is between @scheme[0] and one less than
the vector's length, inclusive.
Functions provided by @schememodname[scheme/unsafe/ops] are
@deftech{unsafe}. They have certain constraints, but the constraints
are not checked, which allows the system to generate and execute
faster code. If arguments violate an unsafe function's constraints,
the function's behavior and result is unpredictable, and the entire
system can crash or become corrupted.
All of the exported bindings of @schememodname[scheme] are protected
in the sense of @scheme[protect-out], so access to unsafe operations
can be prevented by adjusting the code inspector (see
@secref["modprotect"]).
@section{Unsafe Numeric Operations}
@deftogether[(
@defproc[(unsafe-fx+ [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fx- [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fx* [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxquotient [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxremainder [a fixnum?][b fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[+], @scheme[-], @scheme[*],
@scheme[quotient], and @scheme[remainder], but constrained to consume
@tech{fixnums} and produce a @tech{fixnum} result. The mathematical
operation on @scheme[a] and @scheme[b] must be representable as a
@tech{fixnum}. In the case of @scheme[unsafe-fxquotient] and
@scheme[unsafe-fxremainder], @scheme[b] must not be @scheme[0].}
@deftogether[(
@defproc[(unsafe-fxand [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxior [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxxor [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxnot [a fixnum?]) fixnum?]
@defproc[(unsafe-fxlshift [a fixnum?][b fixnum?]) fixnum?]
@defproc[(unsafe-fxrshift [a fixnum?][b fixnum?]) fixnum?]
)]{
For @tech{fixnums}: Like @scheme[bitwise-and], @scheme[bitwise-ior],
@scheme[bitwise-xor], @scheme[bitwise-not], and
@scheme[arithmetic-shift], but constrained to consume @tech{fixnums};
the result is always a @tech{fixnum}. The @scheme[unsafe-fxlshift] and
@scheme[unsafe-fxrshift] operations correspond to
@scheme[arithmetic-shift], but require non-negative arguments;
@scheme[unsafe-fxlshift] is a positive (i.e., left) shift, and
@scheme[unsafe-fxrshift] is a negative (i.e., right) shift, where the
number of bits to shift must be less than the number of bits used to
represent a @tech{fixnum}, and the result is effectively
@scheme[bitwise-and]ed with the most negative @tech{fixnum}.}
@deftogether[(
@defproc[(unsafe-fx= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx< [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx> [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx<= [a fixnum?][b fixnum?]) boolean?]
@defproc[(unsafe-fx>= [a fixnum?][b fixnum?]) boolean?]
)]{
For @tech{fixnums}: Like @scheme[=], @scheme[<], @scheme[>],
@scheme[<=], and @scheme[>=], but constrained to consume
@tech{fixnums}.}
@deftogether[(
@defproc[(unsafe-fl+ [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl- [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl* [a inexact-real?][b inexact-real?]) inexact-real?]
@defproc[(unsafe-fl/ [a inexact-real?][b inexact-real?]) inexact-real?]
)]{
For real @tech{inexact numbers}: Like @scheme[+], @scheme[-],
@scheme[*], and @scheme[/], but constrained to consume real @tech{inexact
numbers}. The result is always a real @tech{inexact number}.}
@deftogether[(
@defproc[(unsafe-fl= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl< [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl> [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl<= [a inexact-real?][b inexact-real?]) boolean?]
@defproc[(unsafe-fl>= [a inexact-real?][b inexact-real?]) boolean?]
)]{
For real @tech{inexact numbers}: Like @scheme[=], @scheme[<],
@scheme[>], @scheme[<=], and @scheme[>=], but constrained to consume
real @tech{inexact numbers}.}
@section{Unsafe Data Extraction}
@deftogether[(
@defproc[(unsafe-car [p pair?]) any/c]
@defproc[(unsafe-cdr [p pair?]) any/c]
@defproc[(unsafe-mcar [p mpair?]) any/c]
@defproc[(unsafe-mcdr [p mpair?]) any/c]
@defproc[(unsafe-set-mcar! [p mpair?] [v any/c]) void?]
@defproc[(unsafe-set-mcdr! [p mpair?] [v any/c]) void?]
)]{
Unsafe variants of @scheme[car], @scheme[cdr], @scheme[mcar],
@scheme[mcdr], @scheme[set-mcar!], and @scheme[set-mcdr!].}
@deftogether[(
@defproc[(unsafe-vector-length [v vector?]) fixnum?]
@defproc[(unsafe-vector-ref [v vector?][k fixnum?]) any/c]
@defproc[(unsafe-vector-set! [v vector?][k fixnum?][val any/c]) any/c]
)]{
Unsafe versions of @scheme[vector-length], @scheme[vector-ref], and
@scheme[vector-set!]. A vector's size can never be larger than a
@tech{fixnum} (so even @scheme[vector-length] always returns a
fixnum).}
@deftogether[(
@defproc[(unsafe-struct-ref [v any/c][k fixnum?]) any/c]
@defproc[(unsafe-struct-set! [v any/c][k fixnum?][val any/c]) any/c]
)]{
Unsafe field access and update for an instance of a structure
type. The index @scheme[k] must be between @scheme[0] (inclusive) and
the number of fields in the struture (exclusive). In the case of
@scheme[unsafe-struct-set!], the field must be mutable.}

1
collects/tests/mzscheme/mz-tests.ss
View File

@ -11,6 +11,7 @@
(load-relative "stx.ss")
(load-relative "module.ss")
(load-relative "number.ss")
(load-relative "unsafe.ss")
(load-relative "object.ss")
(load-relative "struct.ss")
(load-relative "unit.ss")

34
collects/tests/mzscheme/optimize.ss
View File

@ -63,17 +63,19 @@
(check-error-message op (eval `(lambda (x) (,op x ,arg2))))
(check-error-message op (eval `(lambda (x) (,op ,arg1 x))))
(bin0 v op arg1 arg2))]
[bin-int (lambda (v op arg1 arg2)
(bin-exact v op arg1 arg2)
(let* ([iv (if (number? v)
(exact->inexact v)
v)]
[iv0 (if (and (memq op '(* /)) (zero? iv))
0
iv)])
(bin0 iv op (exact->inexact arg1) arg2)
(bin0 iv0 op arg1 (exact->inexact arg2))
(bin0 iv op (exact->inexact arg1) (exact->inexact arg2))))]
[bin (lambda (v op arg1 arg2)
(bin-exact v op arg1 arg2)
(let* ([iv (if (number? v)
(exact->inexact v)
v)]
[iv0 (if (and (memq op '(* /)) (zero? iv))
0
iv)])
(bin0 iv op (exact->inexact arg1) arg2)
(bin0 iv0 op arg1 (exact->inexact arg2))
(bin0 iv op (exact->inexact arg1) (exact->inexact arg2)))
(bin-int v op arg1 arg2)
(let ([iv (if (number? v)
(if (eq? op '*)
(/ v (* 33333 33333))
@ -266,6 +268,18 @@
(bin -4 '/ 16 -4)
(bin 4 '/ -16 -4)
(bin-int 3 'quotient 10 3)
(bin-int -3 'quotient 10 -3)
(bin-int 3 'quotient -10 -3)
(bin-int -3 'quotient -10 3)
(bin-exact 7 'quotient (* 7 (expt 2 100)) (expt 2 100))
(bin-int 1 'remainder 10 3)
(bin-int 1 'remainder 10 -3)
(bin-int -1 'remainder -10 -3)
(bin-int -1 'remainder -10 3)
(bin-exact 7 'remainder (+ 7 (expt 2 100)) (expt 2 100))
(bin 3 'min 3 300)
(bin -300 'min 3 -300)
(bin -400 'min -400 -300)

156
collects/tests/mzscheme/unsafe.ss Normal file
View File

@ -0,0 +1,156 @@
(load-relative "loadtest.ss")
(Section 'unsafe)
(require '#%unsafe)
(let ()
(define (test-tri result proc x y z
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
(pre)
(test result (compose post (eval proc)) x y z)
(pre)
(test result (compose post (eval `(lambda (x y z) (,proc x y z)))) x y z)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y z) (,proc ,x y z)))) y z))
(pre)
(test result (compose post (eval `(lambda (x z) (,proc x ,y z)))) x z)
(pre)
(test result (compose post (eval `(lambda (x y) (,proc x y ,z)))) x y)
(pre)
(test result (compose post (eval `(lambda (x) (,proc x ,y ,z)))) x)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y) (,proc ,x y ,z)))) y)
(pre)
(test result (compose post (eval `(lambda (z) (,proc ,x ,y z)))) z)))
(define (test-bin result proc x y
#:pre [pre void]
#:post [post (lambda (x) x)]
#:literal-ok? [lit-ok? #t])
(pre)
(test result (compose post (eval proc)) x y)
(pre)
(test result (compose post (eval `(lambda (x y) (,proc x y)))) x y)
(when lit-ok?
(pre)
(test result (compose post (eval `(lambda (y) (,proc ,x y)))) y))
(pre)
(test result (compose post (eval `(lambda (x) (,proc x ,y)))) x))
(define (test-un result proc x)
(test result (eval proc) x)
(test result (eval `(lambda (x) (,proc x))) x))
(test-bin 3 'unsafe-fx+ 1 2)
(test-bin -1 'unsafe-fx+ 1 -2)
(test-bin 8 'unsafe-fx- 10 2)
(test-bin 3 'unsafe-fx- 1 -2)
(test-bin 20 'unsafe-fx* 10 2)
(test-bin -20 'unsafe-fx* 10 -2)
(test-bin 3 'unsafe-fxquotient 17 5)
(test-bin -3 'unsafe-fxquotient 17 -5)
(test-bin 2 'unsafe-fxremainder 17 5)
(test-bin 2 'unsafe-fxremainder 17 -5)
(test-bin 3.4 'unsafe-fl+ 1.4 2.0)
(test-bin -1.1 'unsafe-fl+ 1.0 -2.1)
(test-bin +inf.0 'unsafe-fl+ 1.0 +inf.0)
(test-bin -inf.0 'unsafe-fl+ 1.0 -inf.0)
(test-bin +nan.0 'unsafe-fl+ +nan.0 -inf.0)
(test-bin #f unsafe-fx= 1 2)
(test-bin #t unsafe-fx= 2 2)
(test-bin #f unsafe-fx= 2 1)
(test-bin #t unsafe-fx< 1 2)
(test-bin #f unsafe-fx< 2 2)
(test-bin #f unsafe-fx< 2 1)
(test-bin #f unsafe-fx> 1 2)
(test-bin #f unsafe-fx> 2 2)
(test-bin #t unsafe-fx> 2 1)
(test-bin #t unsafe-fx<= 1 2)
(test-bin #t unsafe-fx<= 2 2)
(test-bin #f unsafe-fx<= 2 1)
(test-bin #f unsafe-fx>= 1 2)
(test-bin #t unsafe-fx>= 2 2)
(test-bin #t unsafe-fx>= 2 1)
(test-bin 7.9 'unsafe-fl- 10.0 2.1)
(test-bin 3.7 'unsafe-fl- 1.0 -2.7)
(test-bin 20.02 'unsafe-fl* 10.01 2.0)
(test-bin -20.02 'unsafe-fl* 10.01 -2.0)
(test-bin (exact->inexact 17/5) 'unsafe-fl/ 17.0 5.0)
(test-bin +inf.0 'unsafe-fl/ 17.0 0.0)
(test-bin -inf.0 'unsafe-fl/ -17.0 0.0)
(test-bin 3 'unsafe-fxand 7 3)
(test-bin 2 'unsafe-fxand 6 3)
(test-bin 3 'unsafe-fxand -1 3)
(test-bin 7 'unsafe-fxior 7 3)
(test-bin 7 'unsafe-fxior 6 3)
(test-bin -1 'unsafe-fxior -1 3)
(test-bin 4 'unsafe-fxxor 7 3)
(test-bin 5 'unsafe-fxxor 6 3)
(test-bin -4 'unsafe-fxxor -1 3)
(test-un -1 'unsafe-fxnot 0)
(test-un -4 'unsafe-fxnot 3)
(test-bin 32 'unsafe-fxlshift 2 4)
(test-bin 32 'unsafe-fxlshift 8 2)
(test-bin 8 'unsafe-fxlshift 8 0)
(test-bin 2 'unsafe-fxrshift 32 4)
(test-bin 8 'unsafe-fxrshift 32 2)
(test-bin 8 'unsafe-fxrshift 8 0)
(test-un 5 'unsafe-car (cons 5 9))
(test-un 9 'unsafe-cdr (cons 5 9))
(test-un 15 'unsafe-mcar (mcons 15 19))
(test-un 19 'unsafe-mcdr (mcons 15 19))
(let ([v (mcons 3 7)])
(test-bin 8 'unsafe-set-mcar! v 8
#:pre (lambda () (set-mcar! v 0))
#:post (lambda (x) (mcar v))
#:literal-ok? #f)
(test-bin 9 'unsafe-set-mcdr! v 9
#:pre (lambda () (set-mcdr! v 0))
#:post (lambda (x) (mcdr v))
#:literal-ok? #f))
(test-bin 5 'unsafe-vector-ref #(1 5 7) 1)
(test-un 3 'unsafe-vector-length #(1 5 7))
(let ([v (vector 0 3 7)])
(test-tri 5 'unsafe-vector-set! v 2 5
#:pre (lambda () (vector-set! v 2 0))
#:post (lambda (x) (vector-ref v 2))
#:literal-ok? #f))
(let ()
(define-struct posn (x [y #:mutable] z))
(test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)
(test-bin 'b unsafe-struct-ref (make-posn 'a 'b 'c) 1 #:literal-ok? #f)
(let ([p (make-posn 100 200 300)])
(test-tri 500 'unsafe-struct-set! p 1 500
#:pre (lambda () (set-posn-y! p 0))
#:post (lambda (x) (posn-y p))
#:literal-ok? #f)))
(void))
(report-errs)

2
collects/typed-scheme/typed-scheme.ss
View File

@ -69,7 +69,7 @@
[type-name-references null])]
[begin (do-time "Initialized Envs")]
;; local-expand the module
;; pmb = #%plain-module-begin
;; pmb = #%plain-module-begin
[with-syntax ([new-mod
(local-expand (syntax/loc stx
(#%plain-module-begin

19
collects/typed-scheme/utils/syntax-traversal.ss
View File

@ -14,7 +14,7 @@
stx
(loop (list-ref (syntax->list stx) (car locs)) (cdr locs)))))
(define (syntax-loc stx) (list (syntax-position stx) (syntax-span stx)))
(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx)))
;; -------------------- the real stuff
@ -35,16 +35,23 @@
(and (pair? stx)
(or (loop (car stx)) (loop (cdr stx)))))))))
(define (unwind p)
(if (syntax? p)
(vector (vector (syntax-source p) (syntax-line p)) (unwind (syntax-e p)))
(if (pair? p)
(cons (unwind (car p)) (unwind (cdr p)))
p)))
;; Look for (the outermost) syntax in `orig' that has the same
;; location as `lookfor' which is coming from the expanded `orig',
;; given in `expanded'.
(define (look-for-in-orig orig expanded lookfor)
(define (look-for-in-orig orig expanded lookfor) lookfor)
#|
(define src (syntax-source orig))
;(printf "orig : ~a~n" orig)
;(printf "orig : ~a~n" (unwind orig))
;(printf "expanded : ~a~n" expanded)
;(printf "lookfor : ~a~n" lookfor)
;(printf "lookfor : ~a~n" (unwind lookfor))
;(printf "src : ~a~n" src)
(let ([enclosing (enclosing-syntaxes-with-source expanded lookfor src)]
[syntax-locs (make-hash)])
@ -67,4 +74,6 @@
#;(printf "chose branch two ~a~n" enclosing))))))
;(trace look-for-in-orig)
|#

3
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,6 @@
Version 4.2.1.8
Added scheme/unsafe/ops
Version 4.2.1.7
Inside: embedding applications should call scheme_seal_parameters
after initializing parameter values (currently used by Planet)

76
src/mzscheme/src/cstartup.inc
View File

@ -1,42 +1,42 @@
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,50,0,0,0,1,0,0,3,0,12,0,
19,0,32,0,36,0,41,0,44,0,49,0,56,0,63,0,67,0,72,0,78,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,50,0,0,0,1,0,0,3,0,12,0,
19,0,23,0,28,0,31,0,36,0,49,0,56,0,63,0,67,0,72,0,78,
0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0,
177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,122,1,155,
1,214,1,24,2,102,2,168,2,173,2,193,2,84,3,104,3,155,3,221,3,
106,4,248,4,44,5,67,5,146,5,0,0,93,7,0,0,29,11,11,68,104,
101,114,101,45,115,116,120,66,100,101,102,105,110,101,72,112,97,114,97,109,101,
116,101,114,105,122,101,63,97,110,100,64,108,101,116,42,62,111,114,64,99,111,
110,100,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64,
101,114,101,45,115,116,120,66,100,101,102,105,110,101,63,97,110,100,64,108,101,
116,42,62,111,114,64,99,111,110,100,72,112,97,114,97,109,101,116,101,114,105,
122,101,66,108,101,116,114,101,99,66,117,110,108,101,115,115,63,108,101,116,64,
119,104,101,110,65,113,117,111,116,101,29,94,2,13,68,35,37,107,101,114,110,
101,108,11,29,94,2,13,68,35,37,112,97,114,97,109,122,11,62,105,102,65,
98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101,
115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109,
98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,
45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97,
35,11,8,170,244,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35,
16,20,2,3,2,1,2,4,2,1,2,7,2,1,2,5,2,1,2,6,2,
1,2,9,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2,12,2,1,
97,36,11,8,170,244,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,
2,2,1,2,2,96,11,11,8,170,244,16,0,96,37,11,8,170,244,16,0,
35,11,8,162,246,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35,
16,20,2,3,2,1,2,6,2,1,2,4,2,1,2,5,2,1,2,9,2,
1,2,7,2,1,2,8,2,1,2,10,2,1,2,11,2,1,2,12,2,1,
97,36,11,8,162,246,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,
2,2,1,2,2,96,11,11,8,162,246,16,0,96,37,11,8,162,246,16,0,
13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,
8,30,8,29,8,28,8,27,93,8,224,49,61,0,0,95,9,8,224,49,61,
8,30,8,29,8,28,8,27,93,8,224,169,61,0,0,95,9,8,224,169,61,
0,0,2,1,27,248,22,137,4,195,249,22,130,4,80,158,38,35,251,22,77,
2,16,248,22,92,199,12,249,22,67,2,17,248,22,94,201,27,248,22,137,4,
195,249,22,130,4,80,158,38,35,251,22,77,2,16,248,22,92,199,249,22,67,
2,17,248,22,94,201,12,27,248,22,69,248,22,137,4,196,28,248,22,75,193,
20,15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130,
4,80,158,38,35,251,22,77,2,16,248,22,68,199,249,22,67,2,5,248,22,
4,80,158,38,35,251,22,77,2,16,248,22,68,199,249,22,67,2,4,248,22,
69,201,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,8,101,110,118,49,48,51,50,48,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,51,50,49,93,8,224,50,61,0,0,95,9,8,224,
50,61,0,0,2,1,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,
11,2,18,3,1,8,101,110,118,49,48,52,49,54,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,52,49,55,93,8,224,170,61,0,0,95,9,8,224,
170,61,0,0,2,1,27,248,22,69,248,22,137,4,196,28,248,22,75,193,20,
15,159,36,35,36,28,248,22,75,248,22,69,194,248,22,68,193,249,22,130,4,
80,158,38,35,250,22,77,2,20,248,22,77,249,22,77,248,22,77,2,21,248,
22,68,201,251,22,77,2,16,2,21,2,21,249,22,67,2,7,248,22,69,204,
22,68,201,251,22,77,2,16,2,21,2,21,249,22,67,2,6,248,22,69,204,
18,16,2,101,11,8,31,8,30,8,29,8,28,8,27,16,4,11,11,2,18,
3,1,8,101,110,118,49,48,51,50,51,16,4,11,11,2,19,3,1,8,101,
110,118,49,48,51,50,52,93,8,224,51,61,0,0,95,9,8,224,51,61,0,
3,1,8,101,110,118,49,48,52,49,57,16,4,11,11,2,19,3,1,8,101,
110,118,49,48,52,50,48,93,8,224,171,61,0,0,95,9,8,224,171,61,0,
0,2,1,248,22,137,4,193,27,248,22,137,4,194,249,22,67,248,22,77,248,
22,68,196,248,22,69,195,27,248,22,69,248,22,137,4,23,197,1,249,22,130,
4,80,158,38,35,28,248,22,53,248,22,131,4,248,22,68,23,198,2,27,249,
@ -51,7 +51,7 @@
222,33,42,248,22,137,4,248,22,68,201,248,22,69,198,27,248,22,69,248,22,
137,4,196,27,248,22,137,4,248,22,68,195,249,22,130,4,80,158,39,35,28,
248,22,75,195,250,22,78,2,20,9,248,22,69,199,250,22,77,2,11,248,22,
77,248,22,68,199,250,22,78,2,6,248,22,69,201,248,22,69,202,27,248,22,
77,248,22,68,199,250,22,78,2,5,248,22,69,201,248,22,69,202,27,248,22,
69,248,22,137,4,23,197,1,27,249,22,1,22,81,249,22,2,22,137,4,248,
22,137,4,248,22,68,199,249,22,130,4,80,158,39,35,251,22,77,1,22,119,
105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,
@ -62,13 +62,13 @@
28,248,22,75,193,20,15,159,36,35,36,249,22,130,4,80,158,38,35,27,248,
22,137,4,248,22,68,197,28,249,22,167,8,62,61,62,248,22,131,4,248,22,
92,196,250,22,77,2,20,248,22,77,249,22,77,21,93,2,25,248,22,68,199,
250,22,78,2,8,249,22,77,2,25,249,22,77,248,22,101,203,2,25,248,22,
250,22,78,2,7,249,22,77,2,25,249,22,77,248,22,101,203,2,25,248,22,
69,202,251,22,77,2,16,28,249,22,167,8,248,22,131,4,248,22,68,200,64,
101,108,115,101,10,248,22,68,197,250,22,78,2,20,9,248,22,69,200,249,22,
67,2,8,248,22,69,202,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,8,101,110,118,49,48,51,52,54,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,51,52,55,93,8,224,52,61,0,0,18,16,2,158,
94,10,64,118,111,105,100,8,47,95,9,8,224,52,61,0,0,2,1,27,248,
67,2,7,248,22,69,202,100,8,31,8,30,8,29,8,28,8,27,16,4,11,
11,2,18,3,1,8,101,110,118,49,48,52,52,50,16,4,11,11,2,19,3,
1,8,101,110,118,49,48,52,52,51,93,8,224,172,61,0,0,18,16,2,158,
94,10,64,118,111,105,100,8,47,95,9,8,224,172,61,0,0,2,1,27,248,
22,69,248,22,137,4,196,249,22,130,4,80,158,38,35,28,248,22,53,248,22,
131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68,199,248,22,92,
198,27,248,22,131,4,248,22,68,197,250,22,77,2,26,248,22,77,248,22,68,
@ -83,22 +83,22 @@
159,35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,10,89,
162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,
11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,
16,1,2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33,
35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,7,89,162,
16,1,2,2,16,0,11,16,5,2,4,89,162,8,44,36,52,9,223,0,33,
35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,6,89,162,
8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,
38,11,16,5,2,11,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,
35,16,1,2,2,16,0,11,16,5,2,9,89,162,8,44,36,52,9,223,0,
33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6,89,162,8,
33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,5,89,162,8,
44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,
5,2,4,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,
2,2,16,0,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,46,35,
5,2,8,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,
2,2,16,0,11,16,5,2,7,89,162,8,44,36,57,9,223,0,33,46,35,
20,103,159,35,16,1,2,2,16,1,33,48,11,16,5,2,3,89,162,8,44,
36,53,9,223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,
94,2,14,2,15,93,2,14,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 2006);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,59,0,0,0,1,0,0,13,0,18,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,59,0,0,0,1,0,0,13,0,18,0,
35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226,
0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1,
199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100,
@ -340,25 +340,25 @@
EVAL_ONE_SIZED_STR((char *)expr, 5006);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,8,0,0,0,1,0,0,6,0,19,0,
34,0,48,0,62,0,76,0,115,0,0,0,20,1,0,0,65,113,117,111,116,
101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37,
110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122,
11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35,
37,107,101,114,110,101,108,11,97,35,11,8,176,246,98,159,2,2,35,35,159,
37,107,101,114,110,101,108,11,97,35,11,8,168,248,98,159,2,2,35,35,159,
2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2,
6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100,
144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42,
42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,16,0,35,16,0,35,
16,0,35,11,11,38,35,11,11,11,16,0,16,0,16,0,35,35,36,11,11,
11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35,
16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,
103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,
11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 299);
16,0,16,0,100,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,
103,110,11,29,94,2,1,68,35,37,117,110,115,97,102,101,11,2,4,2,3,
2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35,0};
EVAL_ONE_SIZED_STR((char *)expr, 313);
}
{
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,55,56,0,0,0,1,0,0,11,0,38,0,
static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,50,46,49,46,56,56,0,0,0,1,0,0,11,0,38,0,
44,0,57,0,66,0,73,0,95,0,117,0,143,0,155,0,173,0,193,0,205,
0,221,0,244,0,0,1,31,1,38,1,43,1,48,1,53,1,58,1,67,1,
72,1,76,1,84,1,93,1,101,1,204,1,249,1,13,2,42,2,73,2,129,

157
src/mzscheme/src/env.c
View File

@ -52,6 +52,7 @@ static int env_uid_counter = 0;
/* globals READ-ONLY SHARED */
static Scheme_Object *kernel_symbol;
static Scheme_Env *kernel_env;
static Scheme_Env *unsafe_env;
#define MAX_CONST_LOCAL_POS 64
#define MAX_CONST_LOCAL_TYPES 2
@ -393,6 +394,39 @@ static void place_instance_init_pre_kernel(void *stack_base) {
#endif
}
static void init_unsafe(Scheme_Env *env)
{
scheme_defining_primitives = 1;
REGISTER_SO(unsafe_env);
unsafe_env = scheme_primitive_module(scheme_intern_symbol("#%unsafe"), env);
scheme_init_unsafe_number(unsafe_env);
scheme_init_unsafe_numarith(unsafe_env);
scheme_init_unsafe_numcomp(unsafe_env);
scheme_init_unsafe_list(unsafe_env);
scheme_init_unsafe_vector(unsafe_env);
scheme_finish_primitive_module(unsafe_env);
scheme_protect_primitive_provide(unsafe_env, NULL);
scheme_defining_primitives = 0;
#if USE_COMPILED_STARTUP
if (builtin_ref_counter != (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT)) {
printf("Unsafe count %d doesn't match expected count %d\n",
builtin_ref_counter - EXPECTED_PRIM_COUNT, EXPECTED_UNSAFE_COUNT);
abort();
}
#endif
}
Scheme_Env *scheme_get_unsafe_env() {
return unsafe_env;
}
static Scheme_Env *place_instance_init_post_kernel() {
Scheme_Env *env;
/* error handling and buffers */
@ -432,6 +466,8 @@ static Scheme_Env *place_instance_init_post_kernel() {
init_dummy_foreign(env);
#endif
init_unsafe(env);
scheme_add_embedded_builtins(env);
boot_module_resolver();
@ -608,7 +644,7 @@ static void make_kernel_env(void)
printf("Primitive count %d doesn't match expected count %d\n"
"Turn off USE_COMPILED_STARTUP in src/schminc.h\n",
builtin_ref_counter, EXPECTED_PRIM_COUNT);
exit(1);
abort();
}
#endif
@ -1248,22 +1284,28 @@ Scheme_Object **scheme_make_builtin_references_table(void)
Scheme_Bucket **bs;
Scheme_Env *kenv;
long i;
int j;
t = MALLOC_N(Scheme_Object *, (builtin_ref_counter + 1));
#ifdef MEMORY_COUNTING_ON
scheme_misc_count += sizeof(Scheme_Object *) * (builtin_ref_counter + 1);
#endif
kenv = scheme_get_kernel_env();
ht = kenv->toplevel;
bs = ht->buckets;
for (i = ht->size; i--; ) {
Scheme_Bucket *b = bs[i];
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID))
t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val;
for (j = 0; j < 2; j++) {
if (!j)
kenv = scheme_get_kernel_env();
else
kenv = unsafe_env;
ht = kenv->toplevel;
bs = ht->buckets;
for (i = ht->size; i--; ) {
Scheme_Bucket *b = bs[i];
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_HAS_REF_ID))
t[((Scheme_Bucket_With_Ref_Id *)b)->id] = (Scheme_Object *)b->val;
}
}
return t;
@ -1276,18 +1318,24 @@ Scheme_Hash_Table *scheme_map_constants_to_globals(void)
Scheme_Bucket **bs;
Scheme_Env *kenv;
long i;
kenv = scheme_get_kernel_env();
ht = kenv->toplevel;
bs = ht->buckets;
int j;
result = scheme_make_hash_table(SCHEME_hash_ptr);
for (i = ht->size; i--; ) {
Scheme_Bucket *b = bs[i];
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) {
scheme_hash_set(result, b->val, (Scheme_Object *)b);
for (j = 0; j < 2; j++) {
if (!j)
kenv = scheme_get_kernel_env();
else
kenv = unsafe_env;
ht = kenv->toplevel;
bs = ht->buckets;
for (i = ht->size; i--; ) {
Scheme_Bucket *b = bs[i];
if (b && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)) {
scheme_hash_set(result, b->val, (Scheme_Object *)b);
}
}
}
@ -1713,6 +1761,38 @@ Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env
return o;
}
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv)
{
Scheme_Object *v, *insp;
if (rec && rec[drec].dont_mark_local_use) {
return;
}
insp = menv->module->insp;
v = env->prefix->uses_unsafe;
if (!v)
v = insp;
else if (!SAME_OBJ(v, insp)) {
Scheme_Hash_Tree *ht;
if (SCHEME_HASHTRP(v)) {
ht = (Scheme_Hash_Tree *)v;
} else {
ht = scheme_make_hash_tree(0);
ht = scheme_hash_tree_set(ht, v, scheme_true);
}
if (!scheme_hash_tree_get(ht, insp)) {
ht = scheme_hash_tree_set(ht, insp, scheme_true);
env->prefix->uses_unsafe = (Scheme_Object *)ht;
}
}
}
/*========================================================================*/
/* compile-time env, lookup bindings */
/*========================================================================*/
@ -2864,7 +2944,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
/* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad
idea, because it causes module instances to be preserved. */
if (modname && !(flags & SCHEME_RESOLVE_MODIDS)
&& (!scheme_is_kernel_modname(modname) || (flags & SCHEME_REFERENCING))) {
&& (!(scheme_is_kernel_modname(modname) || scheme_is_unsafe_modname(modname))
|| (flags & SCHEME_REFERENCING))) {
/* Create a module variable reference, so that idx is preserved: */
return scheme_hash_module_variable(env->genv, modidx, find_id,
genv->module->insp,
@ -2882,7 +2963,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
if ((flags & SCHEME_ELIM_CONST) && b && b->val
&& (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST)
&& !(flags & SCHEME_GLOB_ALWAYS_REFERENCE))
&& !(flags & SCHEME_GLOB_ALWAYS_REFERENCE)
&& (!modname || scheme_is_kernel_modname(modname)))
return (Scheme_Object *)b->val;
ASSERT_IS_VARIABLE_BUCKET(b);
@ -2892,6 +2974,15 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
return (Scheme_Object *)b;
}
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o)
{
Scheme_Env *home = ((Scheme_Bucket_With_Home *)o)->home;
if (home && home->module && scheme_is_unsafe_modname(home->module->modname))
return (Scheme_Object *)((Scheme_Bucket *)o)->val;
else
return NULL;
}
int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count)
{
int *v, i;
@ -3447,6 +3538,7 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify)
rp->so.type = scheme_resolve_prefix_type;
rp->num_toplevels = cp->num_toplevels;
rp->num_stxes = cp->num_stxes;
rp->uses_unsafe = cp->uses_unsafe;
if (rp->num_toplevels)
tls = MALLOC_N(Scheme_Object*, rp->num_toplevels);
@ -5407,14 +5499,27 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
SCHEME_VEC_ELS(sv)[i] = ds;
}
return scheme_make_pair(scheme_make_integer(rp->num_lifts), scheme_make_pair(tv, sv));
tv = scheme_make_pair(scheme_make_integer(rp->num_lifts),
scheme_make_pair(tv, sv));
if (rp->uses_unsafe)
tv = scheme_make_pair(scheme_true, tv);
return tv;
}
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
{
Resolve_Prefix *rp;
Scheme_Object *tv, *sv, **a, *stx;
int i;
int i, uses_unsafe = 0;
if (!SCHEME_PAIRP(obj)) return NULL;
if (!SCHEME_INTP(SCHEME_CAR(obj))) {
uses_unsafe = 1;
obj = SCHEME_CDR(obj);
}
if (!SCHEME_PAIRP(obj)) return NULL;
@ -5435,6 +5540,8 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
rp->num_toplevels = SCHEME_VEC_SIZE(tv);
rp->num_stxes = SCHEME_VEC_SIZE(sv);
rp->num_lifts = i;
if (uses_unsafe)
rp->uses_unsafe = scheme_true; /* reset in read_marshalled */
i = rp->num_toplevels;
a = MALLOC_N(Scheme_Object *, i);

12
src/mzscheme/src/eval.c
View File

@ -5547,8 +5547,12 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
if (rec[drec].comp) {
scheme_compile_rec_done_local(rec, drec);
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
&& scheme_extract_unsafe(var)) {
scheme_register_unsafe_in_prefix(env, rec, drec, menv);
return scheme_extract_unsafe(var);
} else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)
|| SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type))
return scheme_register_toplevel_in_prefix(var, env, rec, drec);
else
return var;
@ -10205,6 +10209,10 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
rs_save = rs = MZ_RUNSTACK;
if (rp->uses_unsafe) {
scheme_check_unsafe_accessible(rp->uses_unsafe, genv);
}
if (rp->num_toplevels || rp->num_stxes || rp->num_lifts) {
i = rp->num_toplevels;
if (rp->num_stxes) {

1148
src/mzscheme/src/jit.c
View File

File diff suppressed because it is too large Load Diff

3
src/mzscheme/src/lightning/i386/asm.h
View File

@ -471,6 +471,7 @@ typedef _uc jit_insn;
#define DIVLr(RS) _O_Mrm (0xf7 ,_b11,_b110 ,_r4(RS) )
#define DIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b110 ,MD,MB,MI,MS )
#define DIVQr(RS) _qO_Mrm (0xf7 ,_b11,_b110 ,_r8(RS) )
#define ENTERii(W, B) _O_W_B (0xc8 ,_su16(W),_su8(B))
#define HLT_() _O (0xf4 )
@ -485,6 +486,8 @@ typedef _uc jit_insn;
#define IDIVLr(RS) _O_Mrm (0xf7 ,_b11,_b111 ,_r4(RS) )
#define IDIVLm(MD,MB,MI,MS) _O_r_X (0xf7 ,_b111 ,MD,MB,MI,MS )
#define IDIVQr(RS) _qO_Mrm (0xf7 ,_b11,_b111 ,_r8(RS) )
#define IMULBr(RS) _O_Mrm (0xf6 ,_b11,_b101 ,_r1(RS) )
#define IMULBm(MD,MB,MI,MS) _O_r_X (0xf6 ,_b101 ,MD,MB,MI,MS )

91
src/mzscheme/src/lightning/i386/core.h
View File

@ -171,64 +171,83 @@ struct jit_local_state {
(MOVLir(is, rs == _EAX ? _EDX : _EAX), \
IMULLr(rs == _EAX ? _EDX : rs))
#define jit_divi_i_(result, d, rs, is) \
#define jit_divi_i_X(result, d, rs, is, MOVr, MOVi, SARi, nbits, IDIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \
jit_might (rs, _EDX, MOVLrr(rs, _EDX)), \
MOVLir(is, _ECX), \
SARLir(31, _EDX), \
IDIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might (rs, _EAX, MOVr(rs, _EAX)), \
jit_might (rs, _EDX, MOVr(rs, _EDX)), \
MOVr(is, _ECX), \
SARi(nbits, _EDX), \
IDIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_i_(result, d, s1, s2) \
#define jit_divi_i_(result, d, rs, is) \
jit_divi_i_X(result, d, rs, is, MOVLrr, MOVLir, SARLir, 31, IDIVLr)
#define jit_divi_l_(result, d, rs, is) \
jit_divi_i_X(result, d, rs, is, MOVQrr, MOVQir, SARQir, 31, IDIVQr)
#define jit_divr_i_X(result, d, s1, s2, MOVr, MOVi, SARi, nbits, IDIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \
jit_might (s2, _ECX, MOVr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EDX) : \
jit_might (s1, _EDX, MOVLrr(s1, _EDX))), \
MOVLrr(_EDX, _EAX), \
SARLir(31, _EDX), \
IDIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might (s1, _EDX, MOVr(s1, _EDX))), \
MOVr(_EDX, _EAX), \
SARi(nbits, _EDX), \
IDIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_i_(result, d, s1, s2) \
jit_divr_i_X(result, d, s1, s2, MOVLrr, MOVLir, SARLir, 31, IDIVLr)
#define jit_divr_l_(result, d, s1, s2) \
jit_divr_i_X(result, d, s1, s2, MOVQrr, MOVQir, SARQir, 63, IDIVQr)
#define jit_divi_ui_X(result, d, rs, is, MOVr, MOVi, XORr, DIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVr(rs, _EAX)), \
MOVi(is, _ECX), \
XORr(_EDX, _EDX), \
DIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divi_ui_(result, d, rs, is) \
jit_divi_ui_X(result, d, rs, is, MOVLrr, MOVLir, XORLrr, DIVLr)
#define jit_divi_ul_(result, d, rs, is) \
jit_divi_ui_X(result, d, rs, is, MOVQrr, MOVQir, XORQrr, DIVQr)
#define jit_divr_ui_X(result, d, s1, s2, MOVr, XORr, DIVr) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
jit_might (rs, _EAX, MOVLrr(rs, _EAX)), \
MOVLir(is, _ECX), \
XORLrr(_EDX, _EDX), \
DIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EAX) : \
jit_might (s1, _EAX, MOVr(s1, _EAX))), \
XORr(_EDX, _EDX), \
DIVr(_ECX), \
jit_might(d, result, MOVr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
#define jit_divr_ui_(result, d, s1, s2) \
(jit_might (d, _EAX, PUSHLr(_EAX)), \
jit_might (d, _ECX, PUSHLr(_ECX)), \
jit_might (d, _EDX, PUSHLr(_EDX)), \
((s1 == _ECX) ? PUSHLr(_ECX) : 0), \
jit_might (s2, _ECX, MOVLrr(s2, _ECX)), \
((s1 == _ECX) ? POPLr(_EAX) : \
jit_might (s1, _EAX, MOVLrr(s1, _EAX))), \
XORLrr(_EDX, _EDX), \
DIVLr(_ECX), \
jit_might(d, result, MOVLrr(result, d)), \
jit_might(d, _EDX, POPLr(_EDX)), \
jit_might(d, _ECX, POPLr(_ECX)), \
jit_might(d, _EAX, POPLr(_EAX)))
jit_divr_ui_X(result, d, s1, s2, MOVLrr, XORLrr, DIVLr)
#define jit_divr_ul_(result, d, s1, s2) \
jit_divr_ui_X(result, d, s1, s2, MOVQrr, XORQrr, DIVQr)
/* ALU */
#define jit_addi_i(d, rs, is) jit_opi_((d), (rs), ADDLir((is), (d)), LEALmr((is), (rs), 0, 0, (d)) )
@ -254,6 +273,8 @@ struct jit_local_state {
#define jit_subr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), (SUBQrr((s1), (d)), NEGQr(d)), SUBQrr((s2), (d)) )
#define jit_xorr_l(d, s1, s2) jit_qopr_((d), (s1), (s2), XORQrr((s1), (d)), XORQrr((s2), (d)) )
#define jit_mulr_l(d, s1, s2) jit_opo_((d), (s1), (s2), IMULQrr((s2), (d)), IMULQrr((s1), (d)), LEAQmr(0, (s1), (s2), 1, (d)) )
/* These can sometimes use byte or word versions! */
#define jit_ori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(OR, (is), (d)) )
#define jit_xori_i(d, rs, is) jit_op_ ((d), (rs), jit_reduce(XOR, (is), (d)) )
@ -294,8 +315,12 @@ struct jit_local_state {
#define jit_modi_ui(d, rs, is) jit_divi_ui_(_EDX, (d), (rs), (is))
#define jit_divr_i(d, s1, s2) jit_divr_i_(_EAX, (d), (s1), (s2))
#define jit_divr_ui(d, s1, s2) jit_divr_ui_(_EAX, (d), (s1), (s2))
#define jit_divr_l(d, s1, s2) jit_divr_l_(_EAX, (d), (s1), (s2))
#define jit_divr_ul(d, s1, s2) jit_divr_ul_(_EAX, (d), (s1), (s2))
#define jit_modr_i(d, s1, s2) jit_divr_i_(_EDX, (d), (s1), (s2))
#define jit_modr_ui(d, s1, s2) jit_divr_ui_(_EDX, (d), (s1), (s2))
#define jit_modr_l(d, s1, s2) jit_divr_l_(_EDX, (d), (s1), (s2))
#define jit_modr_ul(d, s1, s2) jit_divr_ul_(_EDX, (d), (s1), (s2))
/* Shifts */

96
src/mzscheme/src/list.c
View File

@ -135,6 +135,15 @@ static Scheme_Object *make_hasheq_placeholder(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_hasheqv_placeholder(int argc, Scheme_Object *argv[]);
static Scheme_Object *table_placeholder_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_car (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_cdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_mcar (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_mcdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_mcar (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_mcdr (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_unbox (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[]);
#define BOX "box"
#define BOXP "box?"
#define UNBOX "unbox"
@ -684,6 +693,46 @@ scheme_init_list (Scheme_Env *env)
equal_symbol = scheme_intern_symbol("equal");
}
void
scheme_init_unsafe_list (Scheme_Env *env)
{
Scheme_Object *p;
scheme_null->type = scheme_null_type;
p = scheme_make_folding_prim(unsafe_car, "unsafe-car", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-car", p, env);
p = scheme_make_folding_prim(unsafe_cdr, "unsafe-cdr", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-cdr", p, env);
p = scheme_make_immed_prim(unsafe_mcar, "unsafe-mcar", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-mcar", p, env);
p = scheme_make_immed_prim(unsafe_mcdr, "unsafe-mcdr", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("unsafe-mcdr", p, env);
p = scheme_make_immed_prim(unsafe_set_mcar, "unsafe-set-mcar!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("unsafe-set-mcar!", p, env);
p = scheme_make_immed_prim(unsafe_set_mcdr, "unsafe-set-mcdr!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("unsafe-set-mcdr!", p, env);
p = scheme_make_immed_prim(unsafe_unbox, "unsafe-unbox", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-unbox", p, env);
p = scheme_make_immed_prim(unsafe_set_box, "unsafe-set-box!", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-set-box!", p, env);
}
Scheme_Object *scheme_make_pair(Scheme_Object *car, Scheme_Object *cdr)
{
#ifdef MZ_PRECISE_GC
@ -2534,3 +2583,50 @@ void scheme_init_ephemerons(void)
}
#endif
/************************************************************/
/* unsafe */
/************************************************************/
static Scheme_Object *unsafe_car (int argc, Scheme_Object *argv[])
{
return SCHEME_CAR(argv[0]);
}
static Scheme_Object *unsafe_cdr (int argc, Scheme_Object *argv[])
{
return SCHEME_CDR(argv[0]);
}
static Scheme_Object *unsafe_mcar (int argc, Scheme_Object *argv[])
{
return SCHEME_CAR(argv[0]);
}
static Scheme_Object *unsafe_mcdr (int argc, Scheme_Object *argv[])
{
return SCHEME_CDR(argv[0]);
}
static Scheme_Object *unsafe_set_mcar (int argc, Scheme_Object *argv[])
{
SCHEME_CAR(argv[0]) = argv[1];
return scheme_void;
}
static Scheme_Object *unsafe_set_mcdr (int argc, Scheme_Object *argv[])
{
SCHEME_CDR(argv[0]) = argv[1];
return scheme_void;
}
static Scheme_Object *unsafe_unbox (int argc, Scheme_Object *argv[])
{
return SCHEME_BOX_VAL(argv[0]);
}
static Scheme_Object *unsafe_set_box (int argc, Scheme_Object *argv[])
{
SCHEME_BOX_VAL(argv[0]) = argv[1];
return scheme_void;
}

38
src/mzscheme/src/module.c
View File

@ -132,6 +132,7 @@ static Scheme_Object *kernel_modname;
static Scheme_Object *kernel_symbol;
static Scheme_Object *kernel_modidx;
static Scheme_Module *kernel;
static Scheme_Object *unsafe_modname;
/* global read-only symbols */
static Scheme_Object *module_symbol;
@ -328,12 +329,14 @@ void scheme_init_module(Scheme_Env *env)
REGISTER_SO(kernel_symbol);
REGISTER_SO(kernel_modname);
REGISTER_SO(kernel_modidx);
REGISTER_SO(unsafe_modname);
kernel_symbol = scheme_intern_symbol("#%kernel");
kernel_modname = scheme_intern_resolved_module_path(kernel_symbol);
kernel_modidx = scheme_make_modidx(scheme_make_pair(quote_symbol,
scheme_make_pair(kernel_symbol,
scheme_null)),
scheme_false, kernel_modname);
unsafe_modname = scheme_intern_resolved_module_path(scheme_intern_symbol("#%unsafe"));
REGISTER_SO(module_symbol);
REGISTER_SO(module_begin_symbol);
@ -580,6 +583,11 @@ int scheme_is_kernel_modname(Scheme_Object *modname)
return SAME_OBJ(modname, kernel_modname);
}
int scheme_is_unsafe_modname(Scheme_Object *modname)
{
return SAME_OBJ(modname, unsafe_modname);
}
Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env)
{
long phase;
@ -3480,6 +3488,36 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
return NULL;
}
void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env)
{
Scheme_Env *unsafe_env;
unsafe_env = scheme_get_unsafe_env();
if (SCHEME_HASHTRP(insp)) {
Scheme_Hash_Tree *t = (Scheme_Hash_Tree *)insp;
int i;
Scheme_Object *k, *v;
for (i = t->count; i--; ) {
scheme_hash_tree_index(t, i, &k, &v);
insp = k;
if (scheme_module_protected_wrt(unsafe_env->insp, insp)) {
break;
}
}
if (i < 0)
return;
}
if (scheme_module_protected_wrt(unsafe_env->insp, insp)) {
scheme_wrong_syntax("link",
NULL, NULL,
"attempt to access unsafe bindings from an untrusted context");
}
}
int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname)
{
Scheme_Module *m;

4
src/mzscheme/src/mzmark.c
View File

@ -2218,6 +2218,7 @@ static int resolve_prefix_val_MARK(void *p) {
gcMARK(rp->toplevels);
gcMARK(rp->stxes);
gcMARK(rp->delay_info_rpair);
gcMARK(rp->uses_unsafe);
return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2228,6 +2229,7 @@ static int resolve_prefix_val_FIXUP(void *p) {
gcFIXUP(rp->toplevels);
gcFIXUP(rp->stxes);
gcFIXUP(rp->delay_info_rpair);
gcFIXUP(rp->uses_unsafe);
return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2246,6 +2248,7 @@ static int comp_prefix_val_MARK(void *p) {
Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK(cp->toplevels);
gcMARK(cp->stxes);
gcMARK(cp->uses_unsafe);
return
gcBYTES_TO_WORDS(sizeof(Comp_Prefix));
@ -2255,6 +2258,7 @@ static int comp_prefix_val_FIXUP(void *p) {
Comp_Prefix *cp = (Comp_Prefix *)p;
gcFIXUP(cp->toplevels);
gcFIXUP(cp->stxes);
gcFIXUP(cp->uses_unsafe);
return
gcBYTES_TO_WORDS(sizeof(Comp_Prefix));

2
src/mzscheme/src/mzmarksrc.c
View File

@ -884,6 +884,7 @@ resolve_prefix_val {
gcMARK(rp->toplevels);
gcMARK(rp->stxes);
gcMARK(rp->delay_info_rpair);
gcMARK(rp->uses_unsafe);
size:
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -894,6 +895,7 @@ comp_prefix_val {
Comp_Prefix *cp = (Comp_Prefix *)p;
gcMARK(cp->toplevels);
gcMARK(cp->stxes);
gcMARK(cp->uses_unsafe);
size:
gcBYTES_TO_WORDS(sizeof(Comp_Prefix));

109
src/mzscheme/src/numarith.c
View File

@ -35,6 +35,17 @@ static Scheme_Object *quotient (int argc, Scheme_Object *argv[]);
static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]);
static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_div (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_rem (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_plus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_minus (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_mult (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_div (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
void scheme_init_numarith(Scheme_Env *env)
@ -69,17 +80,15 @@ void scheme_init_numarith(Scheme_Env *env)
p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("abs", p, env);
p = scheme_make_folding_prim(quotient, "quotient", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("quotient", p, env);
p = scheme_make_folding_prim(rem_prim, "remainder", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("remainder", p, env);
scheme_add_global_constant("quotient",
scheme_make_folding_prim(quotient,
"quotient",
2, 2, 1),
env);
scheme_add_global_constant("remainder",
scheme_make_folding_prim(rem_prim,
"remainder",
2, 2, 1),
env);
scheme_add_global_constant("quotient/remainder",
scheme_make_prim_w_arity2(quotient_remainder,
"quotient/remainder",
@ -93,6 +102,53 @@ void scheme_init_numarith(Scheme_Env *env)
env);
}
void scheme_init_unsafe_numarith(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_plus, "unsafe-fx+", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx+", p, env);
p = scheme_make_folding_prim(fx_minus, "unsafe-fx-", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNARY_INLINED);
scheme_add_global_constant("unsafe-fx-", p, env);
p = scheme_make_folding_prim(fx_mult, "unsafe-fx*", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx*", p, env);
p = scheme_make_folding_prim(fx_div, "unsafe-fxquotient", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxquotient", p, env);
p = scheme_make_folding_prim(fx_rem, "unsafe-fxremainder", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxremainder", p, env);
p = scheme_make_folding_prim(fl_plus, "unsafe-fl+", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl+", p, env);
p = scheme_make_folding_prim(fl_minus, "unsafe-fl-", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl-", p, env);
p = scheme_make_folding_prim(fl_mult, "unsafe-fl*", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl*", p, env);
p = scheme_make_folding_prim(fl_div, "unsafe-fl/", 2, 2, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl/", p, env);
}
Scheme_Object *
scheme_add1 (int argc, Scheme_Object *argv[])
{
@ -707,3 +763,36 @@ quotient_remainder(int argc, Scheme_Object *argv[])
a[1] = rem;
return scheme_values(2, a);
}
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
return scheme_make_integer(v); \
}
UNSAFE_FX(fx_plus, +, plus)
UNSAFE_FX(fx_minus, -, minus)
UNSAFE_FX(fx_mult, *, mult)
UNSAFE_FX(fx_div, /, quotient)
UNSAFE_FX(fx_rem, %, rem_prim)
#define UNSAFE_FL(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
double v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1]); \
return scheme_make_double(v); \
}
UNSAFE_FL(fl_plus, +, plus)
UNSAFE_FL(fl_minus, -, minus)
UNSAFE_FL(fl_mult, *, mult)
UNSAFE_FL(fl_div, /, div_prim)

75
src/mzscheme/src/number.c
View File

@ -98,6 +98,13 @@ static Scheme_Object *angle (int argc, Scheme_Object *argv[]);
static Scheme_Object *int_sqrt (int argc, Scheme_Object *argv[]);
static Scheme_Object *int_sqrt_rem (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_and (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_or (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_xor (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lshift (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_rshift (int argc, Scheme_Object *argv[]);
static double not_a_number_val;
Scheme_Object *scheme_inf_object, *scheme_minus_inf_object, *scheme_nan_object;
@ -482,6 +489,36 @@ scheme_init_number (Scheme_Env *env)
env);
}
void scheme_init_unsafe_number(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_and, "unsafe-fxand", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxand", p, env);
p = scheme_make_folding_prim(fx_or, "unsafe-fxior", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxior", p, env);
p = scheme_make_folding_prim(fx_xor, "unsafe-fxxor", 0, -1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxxor", p, env);
p = scheme_make_folding_prim(fx_not, "unsafe-fxnot", 1, 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-fxnot", p, env);
p = scheme_make_folding_prim(fx_lshift, "unsafe-fxlshift", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxlshift", p, env);
p = scheme_make_folding_prim(fx_rshift, "unsafe-fxrshift", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fxrshift", p, env);
}
Scheme_Object *
scheme_make_integer_value(long i)
@ -2723,3 +2760,41 @@ long scheme_integer_length(Scheme_Object *n)
r = integer_length(1, a);
return SCHEME_INT_VAL(r);
}
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
long v; \
if (scheme_current_thread->constant_folding) return fold(argc, argv); \
v = SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1]); \
return scheme_make_integer(v); \
}
UNSAFE_FX(fx_and, &, scheme_bitwise_and)
UNSAFE_FX(fx_or, |, bitwise_or)
UNSAFE_FX(fx_xor, ^, bitwise_xor)
UNSAFE_FX(fx_lshift, <<, scheme_bitwise_shift)
static Scheme_Object *neg_bitwise_shift(int argc, Scheme_Object *argv[])
{
Scheme_Object *a[2];
a[0] = argv[0];
a[1] = scheme_bin_minus(scheme_make_integer(0), argv[1]);
return scheme_bitwise_shift(argc, a);
}
UNSAFE_FX(fx_rshift, >>, neg_bitwise_shift)
static Scheme_Object *fx_not (int argc, Scheme_Object *argv[])
{
long v;
if (scheme_current_thread->constant_folding) return bitwise_not(argc, argv);
v = SCHEME_INT_VAL(argv[0]);
v = ~v;
return scheme_make_integer(v);
}

98
src/mzscheme/src/numcomp.c
View File

@ -38,6 +38,18 @@ static Scheme_Object *negative_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *sch_max (int argc, Scheme_Object *argv[]);
static Scheme_Object *sch_min (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fx_gt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_lt_eq (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_gt_eq (int argc, Scheme_Object *argv[]);
#define zeroi scheme_exact_zero
void scheme_init_numcomp(Scheme_Env *env)
@ -85,6 +97,56 @@ void scheme_init_numcomp(Scheme_Env *env)
scheme_add_global_constant("min", p, env);
}
void scheme_init_unsafe_numcomp(Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_folding_prim(fx_eq, "unsafe-fx=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx=", p, env);
p = scheme_make_folding_prim(fx_lt, "unsafe-fx<", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx<", p, env);
p = scheme_make_folding_prim(fx_gt, "unsafe-fx>", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx>", p, env);
p = scheme_make_folding_prim(fx_lt_eq, "unsafe-fx<=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx<=", p, env);
p = scheme_make_folding_prim(fx_gt_eq, "unsafe-fx>=", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fx>=", p, env);
p = scheme_make_folding_prim(fl_eq, "unsafe-fl=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl=", p, env);
p = scheme_make_folding_prim(fl_lt, "unsafe-fl<", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl<", p, env);
p = scheme_make_folding_prim(fl_gt, "unsafe-fl>", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl>", p, env);
p = scheme_make_folding_prim(fl_lt_eq, "unsafe-fl<=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl<=", p, env);
p = scheme_make_folding_prim(fl_gt_eq, "unsafe-fl>=", 2, 2, 1);
if (scheme_can_inline_fp_comp())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-fl>=", p, env);
}
/* Prototype needed for 3m conversion: */
static MZ_INLINE Scheme_Object *force_rat(Scheme_Object *n, Small_Rational *sr);
@ -294,3 +356,39 @@ static GEN_BIN_OP(bin_min, "min", MIN, F_MIN, FS_MIN, scheme_bignum_min, scheme_
GEN_TWOARY_OP(static, sch_max, "max", bin_max, SCHEME_REALP, REAL_NUMBER_STR)
GEN_TWOARY_OP(static, sch_min, "min", bin_min, SCHEME_REALP, REAL_NUMBER_STR)
/************************************************************************/
/* Unsafe */
/************************************************************************/
#define UNSAFE_FX(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_INT_VAL(argv[0]) op SCHEME_INT_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
}
UNSAFE_FX(fx_eq, ==, scheme_bin_eq)
UNSAFE_FX(fx_lt, <, scheme_bin_lt)
UNSAFE_FX(fx_gt, >, scheme_bin_gt)
UNSAFE_FX(fx_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FX(fx_gt_eq, >=, scheme_bin_gt_eq)
#define UNSAFE_FL(name, op, fold) \
static Scheme_Object *name(int argc, Scheme_Object *argv[]) \
{ \
if (scheme_current_thread->constant_folding) return (fold(argv[0], argv[1]) ? scheme_true : scheme_false); \
if (SCHEME_DBL_VAL(argv[0]) op SCHEME_DBL_VAL(argv[1])) \
return scheme_true; \
else \
return scheme_false; \
}
UNSAFE_FL(fl_eq, ==, scheme_bin_eq)
UNSAFE_FL(fl_lt, <, scheme_bin_lt)
UNSAFE_FL(fl_gt, >, scheme_bin_gt)
UNSAFE_FL(fl_lt_eq, <=, scheme_bin_lt_eq)
UNSAFE_FL(fl_gt_eq, >=, scheme_bin_gt_eq)

1
src/mzscheme/src/print.c
View File

@ -808,6 +808,7 @@ print_to_string(Scheme_Object *obj,
params.case_sens = 1;
params.honu_mode = 0;
params.inspector = scheme_false;
params.print_syntax = -1;
} else {
config = scheme_current_config();

8
src/mzscheme/src/read.c
View File

@ -4681,7 +4681,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
break;
case CPT_REFERENCE:
l = read_compact_number(port);
RANGE_CHECK(l, < EXPECTED_PRIM_COUNT);
RANGE_CHECK(l, < (EXPECTED_PRIM_COUNT + EXPECTED_UNSAFE_COUNT));
return variable_references[l];
break;
case CPT_LOCAL:
@ -5081,6 +5081,12 @@ static Scheme_Object *read_marshalled(int type, CPort *port)
if (!l)
scheme_ill_formed_code(port);
if (type == scheme_resolve_prefix_type) {
/* If unsafe_insp is set, need to use the one in port: */
if (((Resolve_Prefix *)l)->uses_unsafe)
((Resolve_Prefix *)l)->uses_unsafe = port->insp;
}
return l;
}

1
src/mzscheme/src/schminc.h
View File

@ -14,6 +14,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 959
#define EXPECTED_UNSAFE_COUNT 38
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

19
src/mzscheme/src/schpriv.h
View File

@ -171,6 +171,7 @@ void scheme_init_symbol_table(void);
void scheme_init_symbol_type(Scheme_Env *env);
void scheme_init_type();
void scheme_init_list(Scheme_Env *env);
void scheme_init_unsafe_list(Scheme_Env *env);
void scheme_init_stx(Scheme_Env *env);
void scheme_init_module(Scheme_Env *env);
void scheme_init_module_path_table(void);
@ -180,10 +181,14 @@ void scheme_init_network(Scheme_Env *env);
void scheme_init_file(Scheme_Env *env);
void scheme_init_proc(Scheme_Env *env);
void scheme_init_vector(Scheme_Env *env);
void scheme_init_unsafe_vector(Scheme_Env *env);
void scheme_init_string(Scheme_Env *env);
void scheme_init_number(Scheme_Env *env);
void scheme_init_numarith(Scheme_Env *env);
void scheme_init_unsafe_numarith(Scheme_Env *env);
void scheme_init_unsafe_number(Scheme_Env *env);
void scheme_init_numcomp(Scheme_Env *env);
void scheme_init_unsafe_numcomp(Scheme_Env *env);
void scheme_init_numstr(Scheme_Env *env);
void scheme_init_eval(Scheme_Env *env);
void scheme_init_promise(Scheme_Env *env);
@ -1828,6 +1833,7 @@ typedef struct Comp_Prefix
int num_toplevels, num_stxes;
Scheme_Hash_Table *toplevels; /* buckets for toplevel/module variables */
Scheme_Hash_Table *stxes; /* syntax objects */
Scheme_Object *uses_unsafe; /* NULL, inspector, or hashtree of inspectors */
} Comp_Prefix;
typedef struct Scheme_Comp_Env
@ -1900,6 +1906,7 @@ typedef struct Resolve_Prefix
Scheme_Object **toplevels;
Scheme_Object **stxes; /* simplified */
Scheme_Object *delay_info_rpair; /* (rcons refcount Scheme_Load_Delay*) */
Scheme_Object *uses_unsafe; /* non-NULL => inspector or hashtree of inspectors for accessing #%unsafe bindings */
} Resolve_Prefix;
typedef struct Resolve_Info
@ -2086,6 +2093,8 @@ Scheme_Object *scheme_lookup_binding(Scheme_Object *symbol, Scheme_Comp_Env *env
Scheme_Env **_menv, int *_protected,
Scheme_Object **_lexical_binding_id);
Scheme_Object *scheme_extract_unsafe(Scheme_Object *o);
Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
Scheme_Comp_Env *upto);
@ -2137,6 +2146,9 @@ Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Com
Scheme_Compile_Info *rec, int drec);
Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec);
void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec,
Scheme_Env *menv);
void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a,
Scheme_Env *exp_env, Scheme_Object *insp,
@ -2753,6 +2765,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object
int position, int want_pos,
int *_protected, int *_unexported,
Scheme_Env *from_env, int *_would_complain);
void scheme_check_unsafe_accessible(Scheme_Object *insp, Scheme_Env *from_env);
Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name);
Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx,
@ -2769,7 +2782,7 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid
Scheme_Env *scheme_get_kernel_env();
int scheme_is_kernel_env();
Scheme_Env *scheme_get_unsafe_env();
void scheme_install_initial_module_set(Scheme_Env *env);
Scheme_Bucket_Table *scheme_clone_toplevel(Scheme_Bucket_Table *ht, Scheme_Env *home);
@ -2781,6 +2794,7 @@ void scheme_clean_dead_env(Scheme_Env *env);
Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o);
int scheme_is_kernel_modname(Scheme_Object *modname);
int scheme_is_unsafe_modname(Scheme_Object *modname);
void scheme_clear_modidx_cache(void);
void scheme_clear_shift_cache(void);
@ -3185,6 +3199,9 @@ unsigned short * scheme_ucs4_to_utf16(const mzchar *text, int start, int end,
Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]);
int scheme_can_inline_fp_op();
int scheme_can_inline_fp_comp();
/*========================================================================*/
/* places */
/*========================================================================*/

4
src/mzscheme/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.2.1.7"
#define MZSCHEME_VERSION "4.2.1.8"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 2
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_W 8
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

1
src/mzscheme/src/startup.inc
View File

@ -391,6 +391,7 @@
"(module #%builtin '#%kernel"
"(#%require '#%expobs"
"(only '#%foreign) "
"(only '#%unsafe) "
" '#%paramz"
" '#%network"
" '#%utils"

1
src/mzscheme/src/startup.ss
View File

@ -465,6 +465,7 @@
(module #%builtin '#%kernel
(#%require '#%expobs
(only '#%foreign) ; so it's attached, but doesn't depend on any exports
(only '#%unsafe) ; ditto
'#%paramz
'#%network
'#%utils

77
src/mzscheme/src/vector.c
View File

@ -42,6 +42,12 @@ static Scheme_Object *vector_copy_bang(int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_immutable (int argc, Scheme_Object *argv[]);
static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[]);
void
scheme_init_vector (Scheme_Env *env)
{
@ -122,6 +128,45 @@ scheme_init_vector (Scheme_Env *env)
env);
}
void
scheme_init_unsafe_vector (Scheme_Env *env)
{
Scheme_Object *p;
p = scheme_make_immed_prim(unsafe_vector_len,
"unsafe-vector-length",
1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("unsafe-vector-length", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-vector-ref", p, env);
p = scheme_make_immed_prim(unsafe_vector_set,
"unsafe-vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-vector-set!", p, env);
p = scheme_make_immed_prim(unsafe_vector_ref,
"unsafe-vector-ref",
2, 2);
p = scheme_make_immed_prim(unsafe_struct_ref,
"unsafe-struct-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("unsafe-struct-ref", p, env);
p = scheme_make_immed_prim(unsafe_struct_set,
"unsafe-struct-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-struct-set!", p, env);
}
Scheme_Object *
scheme_make_vector (long size, Scheme_Object *fill)
{
@ -475,3 +520,35 @@ static Scheme_Object *vector_to_values (int argc, Scheme_Object *argv[])
return SCHEME_MULTIPLE_VALUES;
}
/************************************************************/
/* unsafe */
/************************************************************/
static Scheme_Object *unsafe_vector_len (int argc, Scheme_Object *argv[])
{
long n = SCHEME_VEC_SIZE(argv[0]);
return scheme_make_integer(n);
}
static Scheme_Object *unsafe_vector_ref (int argc, Scheme_Object *argv[])
{
return SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_vector_set (int argc, Scheme_Object *argv[])
{
SCHEME_VEC_ELS(argv[0])[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}
static Scheme_Object *unsafe_struct_ref (int argc, Scheme_Object *argv[])
{
return ((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])];
}
static Scheme_Object *unsafe_struct_set (int argc, Scheme_Object *argv[])
{
((Scheme_Structure *)argv[0])->slots[SCHEME_INT_VAL(argv[1])] = argv[2];
return scheme_void;
}