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

Merge branch 'master' of git:plt

Browse Source
This commit is contained in:
Matthias Felleisen 2010-09-30 08:16:18 -04:00
commit 8743172b20
70 changed files with 1825 additions and 622 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/drracket/drracket.filetypes
View File

@ -1,5 +1,5 @@
((("CFBundleTypeName"
"Scheme Source")
"Racket Source")
("CFBundleTypeIconFile"
"doc")
("CFBundleTypeRole"
@ -19,7 +19,7 @@
("CFBundleTypeExtensions"
(array "plt")))
(("CFBundleTypeName"
"Scheme Doc Source")
"Racket Doc Source")
("CFBundleTypeIconFile"
"doc")
("CFBundleTypeRole"

12
collects/drracket/private/main.rkt
View File

@ -118,6 +118,7 @@
(drr:set-default 'drracket:module-language-first-line-special? #t boolean?)
(drr:set-default 'drracket:defns-popup-sort-by-name? #f boolean?)
(drr:set-default 'drracket:show-line-numbers? #f boolean?)
(drr:set-default 'drracket:toolbar-state
'(#f . top)
@ -299,14 +300,15 @@
(preferences:add-general-checkbox-panel)
(let ([make-check-box
(λ (pref-sym string parent)
(λ (pref-sym string parent [extra-functionality #f])
(let ([q (make-object check-box%
string
parent
(λ (checkbox evt)
(preferences:set
pref-sym
(send checkbox get-value))))])
(define value (send checkbox get-value))
(preferences:set pref-sym value)
(when extra-functionality
(extra-functionality value))))])
(preferences:add-callback pref-sym (λ (p v) (send q set-value v)))
(send q set-value (preferences:get pref-sym))))])
(preferences:add-to-general-checkbox-panel
@ -325,7 +327,7 @@
(make-check-box 'drracket:defs/ints-horizontal
(string-constant interactions-beside-definitions)
editor-panel)
(make-check-box 'drracket:module-language-first-line-special?
(string-constant ml-always-show-#lang-line)
editor-panel)))

167
collects/drracket/private/unit.rkt
View File

@ -447,8 +447,99 @@ module browser threading seems wrong.
(set! definitions-text% (make-definitions-text%)))
definitions-text%)))
;; links two editor's together so they scroll in tandem
(define (linked-scroller %)
(class %
(super-new)
(field [linked #f])
(init-field [line-numbers? #f])
(inherit insert line-start-position line-end-position)
(define/public (link-to! who)
(set! linked who))
#;
(define/override (scroll-editor-to . args)
(printf "Scroll editor to ~a\n" args))
#;
(define/override (scroll-to-position . args)
(printf "Scroll-to-position ~a\n" args))
(define self (gensym))
(define (visible? want-start want-end)
(define start (box 0))
(define end (box 0))
(send this get-visible-line-range start end)
#;
(printf "Visible line range ~a ~a ~a\n" (unbox start) (unbox end) self)
(and (>= want-start (unbox start))
(<= want-end (unbox end))))
(define/public (scroll-to-line start end)
#;
(printf "Need to scroll to ~a ~a ~a\n" start end self)
;; dont need to scroll unless the range of lines is out of view
(when (not (visible? start end))
(send this scroll-to-position
(send this line-end-position start)
#f
(send this line-end-position end))))
(define/augment (after-delete start length)
(update-numbers)
(inner (void) after-delete start length))
(define/augment (after-insert start length)
(update-numbers)
(inner (void) after-insert start length))
(define/public (update-numbers)
(when (and (not line-numbers?) linked)
(send linked ensure-length (send this last-line))))
;; make sure the set of line numbers is complete
(define/public (ensure-length length)
(define lines (send this last-line))
(when line-numbers?
(when (> lines (add1 length))
(send this delete
(line-start-position (add1 length))
(line-end-position lines)
#f))
(send this begin-edit-sequence)
(for ([line (in-range (add1 lines) (add1 (add1 length)))])
#;
(printf "Insert line ~a\n" line)
(insert (format "~a\n" line)))
(send this end-edit-sequence)))
(define/override (on-paint . args)
(define start (box 0))
(define end (box 0))
(define (current-time) (current-inexact-milliseconds))
;; pass #f to avoid getting visible line ranges from multiple sources
(send this get-visible-line-range start end #f)
#;
(printf "text: Repaint at ~a to ~a at ~a!\n" (unbox start) (unbox end) (current-time))
;; update the linked editor when the main widget is redrawn
(when (and (not line-numbers?) linked)
#;
(printf "Send linked scroll to ~a ~a ~a\n" (unbox start) (unbox end) self)
(send linked scroll-to-line (unbox start) (unbox end)))
(super on-paint . args))
))
;; an editor that does not respond to key presses
(define (uneditable %)
(class %
(super-new)
(define/override (on-char . stuff) (void))))
(define (make-definitions-text%)
(let ([definitions-super%
(linked-scroller
((get-program-editor-mixin)
(text:first-line-mixin
(drracket:module-language:module-language-put-file-mixin
@ -461,7 +552,7 @@ module browser threading seems wrong.
(drracket:rep:drs-autocomplete-mixin
(λ (x) x)
(text:normalize-paste-mixin
text:info%)))))))))))])
text:info%))))))))))))])
(class* definitions-super% (definitions-text<%>)
(inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line)
@ -1357,6 +1448,12 @@ module browser threading seems wrong.
(λ (l) (remq execute-warning-panel l)))
(send execute-warning-canvas set-message #f))])))
(define (show-line-numbers?)
(preferences:get 'drracket:show-line-numbers?))
(define/public (show-line-numbers! show)
(re-initialize-definitions-canvas show))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; logging
@ -2460,6 +2557,16 @@ module browser threading seems wrong.
(set! interactions-shown? (not interactions-shown?))
(unless interactions-shown?
(set! definitions-shown? #t)))
(define (immediate-children parent children)
(define (immediate child)
(let loop ([child child])
(define immediate-parent (send child get-parent))
(if (eq? immediate-parent parent)
child
(loop immediate-parent))))
(for/list ([child children])
(immediate child)))
(define/override (update-shown)
(super update-shown)
@ -2488,7 +2595,9 @@ module browser threading seems wrong.
(send resizable-panel begin-container-sequence)
;; this might change the unit-window-size-percentage, so save/restore it
(send resizable-panel change-children (λ (l) new-children))
(send resizable-panel change-children
(λ (old)
(immediate-children resizable-panel new-children)))
(preferences:set 'drracket:unit-window-size-percentage p)
;; restore preferred interactions/definitions sizes
@ -2662,12 +2771,44 @@ module browser threading seems wrong.
(define/override (get-canvas)
(initialize-definitions-canvas)
definitions-canvas)
(define (create-definitions-canvas line-numbers?)
(define (with-line-numbers)
(define line-numbers-text (new (linked-scroller (uneditable scheme:text%))
[line-numbers? #t]))
(define shared-pane (new horizontal-panel% [parent resizable-panel]))
(define line-canvas (new editor-canvas%
[parent shared-pane]
[style '(hide-vscroll hide-hscroll)]
[editor line-numbers-text]
[stretchable-width #f]
[min-width 60]))
(send definitions-text link-to! line-numbers-text)
(send line-numbers-text link-to! definitions-text)
(new (drracket:get/extend:get-definitions-canvas)
[parent shared-pane]
[editor definitions-text]))
(define (without-line-numbers)
(send definitions-text link-to! #f)
(new (drracket:get/extend:get-definitions-canvas)
[parent resizable-panel]
[editor definitions-text]))
(if line-numbers?
(with-line-numbers)
(without-line-numbers)))
(define/private (re-initialize-definitions-canvas show)
(begin-container-sequence)
(set! definitions-canvas (create-definitions-canvas show))
(set! definitions-canvases (list definitions-canvas))
(update-shown)
(send (send definitions-canvas get-editor) update-numbers)
(end-container-sequence))
(define/private (initialize-definitions-canvas)
(unless definitions-canvas
(set! definitions-canvas
(new (drracket:get/extend:get-definitions-canvas)
(parent resizable-panel)
(editor definitions-text)))))
(set! definitions-canvas (create-definitions-canvas
(show-line-numbers?)))))
(define/override (get-delegated-text) definitions-text)
(define/override (get-open-here-editor) definitions-text)
@ -3769,6 +3910,20 @@ module browser threading seems wrong.
#f
has-editor-on-demand)
(register-capability-menu-item 'drscheme:special:insert-lambda insert-menu))
(new menu:can-restore-menu-item%
[label (if (show-line-numbers?)
(string-constant hide-line-numbers)
(string-constant show-line-numbers))]
[parent (get-show-menu)]
[callback (lambda (self event)
(define value (preferences:get 'drracket:show-line-numbers?))
(send self set-label
(if value
(string-constant show-line-numbers)
(string-constant hide-line-numbers)))
(preferences:set 'drracket:show-line-numbers? (not value))
(show-line-numbers! (not value)))])
(make-object separator-menu-item% (get-show-menu))

97
collects/ffi/examples/sndfile.rkt
View File

@ -1,15 +1,21 @@
#lang racket/base
(require ffi/unsafe
#;rackunit
racket/match)
ffi/vector
racket/match
racket/runtime-path)
;; the constants in this file are pulled from version 1.0.21 of the libsndfile header file. However,
;; I think it would be a mistake to specify this in the call to ffi-lib; it appears that
;; this version is a conservative extension of the earlier version (1.0.17?), and I
;; think you'll get graceful failures if the version is wrong.
(define libsndfile (ffi-lib "libsndfile"))
(define-runtime-path mac-ffi-path "./lib/libsndfile")
(define libsndfile
(match (system-type)
['unix (ffi-lib "libsndfile" '("1.0.21" "1.0.20" ""))]
['macosx (ffi-lib mac-ffi-path '("1.0.21" "1.0.20" ""))]
['windows (error 'libsndfile "libsndfile not supported on windows.")]))
;; ==================== Types etc ====================
@ -205,7 +211,7 @@
-> (if (sndfile-ptr sf)
(begin (set-sndfile-info! sf info) sf)
;; goofy way to get the error code:
(error 'sf-read "~a" (sf-strerror (make-sndfile #f #f)))))
(error 'sf-open "~a" (sf-strerror (make-sndfile #f #f)))))
(defsndfile sf-format-check : _sf-info-pointer -> _bool)
@ -247,9 +253,9 @@
(when found (sf-set-string sndfile st (cadr found))))))
;; read-sound-internal : path-string [bool] -> (values/c (or/c cblock (listof (listof sample))) a-list)
;; read-sound-internal : path-string -> (values/c (or/c cblock (listof (listof sample))) a-list)
;; read the data from a file.
(define (read-sound-internal file #:split [split-into-lists? #t])
(define (read-sound-internal file)
(let* ([sndfile (sf-open file 'sfm-read)]
[strings (get-meta-strings sndfile)]
[info (sndfile-info sndfile)]
@ -258,17 +264,14 @@
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[readf (sample-type->reader (sample-type))]
[cblock (malloc (* frames channels) stype)]
[num-read (readf sndfile cblock frames)]
[cblock ((sample-type->vector-maker (sample-type)) (* frames channels))]
[num-read (readf sndfile ((sample-type->cpointer-extractor (sample-type)) cblock) frames)]
[_ (unless (= frames num-read)
(error 'read-sound-internal
"wanted ~s frames, but got ~s: ~s"
frames num-read
(sf-strerror sndfile)))]
[data (if split-into-lists?
(split-sound-cblock cblock stype frames channels)
cblock)])
(begin0 (values data
(sf-strerror sndfile)))])
(begin0 (values cblock
`((frames ,frames)
(samplerate ,(sf-info-samplerate info))
(channels ,channels)
@ -280,9 +283,11 @@
"error while closing file: ~s"
(sf-strerror sndfile))))))
;; split-sound-cblock : cblock ffi-type nat nat -> (listof frame)
;; ... where frame is (listof sample-value)
(define (split-sound-cblock cblock stype frames channels)
;; NOT SUPPORTING THE LIST INTERFACE RIGHT NOW (2010-09-24)
#;(define (split-sound-cblock cblock stype frames channels)
(let* ([data (cblock->list cblock stype (* frames channels))])
(n-split data channels)))
@ -306,11 +311,12 @@
[(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)]))
;; there are some ugly hidden invariants here: what if the sample-type doesn't match
;; what's specified in the format? This is a question about libsndfile, and I should check it out...
;; write-sound-internal/cblock
(define (write-sound-internal/cblock file cblock format samplerate frames channels sample-type meta)
;; write-sound-internal/s16vector
(define (write-sound-internal/s16vector file cblock format samplerate frames channels sample-type meta)
(check-filename-format format file)
(let* ([writef (sample-type->writer sample-type)]
[info (make-sf-info frames samplerate channels format 1 #f)]
@ -318,13 +324,13 @@
(error 'write-sound-internal "bad format: ~s" format))]
[sndfile (sf-open file 'sfm-write info)]
[_ (set-meta-strings sndfile meta)]
[num-write (writef sndfile cblock frames)])
[num-write (writef sndfile (s16vector->cpointer cblock) frames)])
(unless (= frames num-write)
(error 'write-sound-internal/cblock
(error 'write-sound-internal/s16vector
"wanted to write ~s frames, but wrote only ~s. ~s"
frames num-write (sf-strerror sndfile)))
(unless (= 0 (sf-close sndfile))
(error 'write-sound-internal/cblock "failed to close file: ~s" (sf-strerror sndfile)))
(error 'write-sound-internal/s16vector "failed to close file: ~s" (sf-strerror sndfile)))
(void)))
;; write-sound-internal/lists : path-string (listof (listof sample)) (listof (list/c symbol? string?)) -> (void)
@ -341,7 +347,7 @@
[else (guess-format file)])]
[samplerate (cond [(assq 'samplerate meta) => cadr]
[else (default-samplerate)])])
(write-sound-internal/cblock file cblock format samplerate frames channels (sample-type) meta)))
(write-sound-internal/s16vector file cblock format samplerate frames channels (sample-type) meta)))
(define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file))
@ -402,7 +408,6 @@
(match-lambda
['short sf-readf-short]
['int sf-readf-int]
['float sf-readf-float]
['double sf-readf-double]))
;; return the writer that corresponds to a given sample-type
@ -410,19 +415,33 @@
(match-lambda
['short sf-writef-short]
['int sf-writef-int]
['float sf-writef-float]
['double sf-writef-double]))
;; return the vector-maker that corresponds to a given sample-type
(define sample-type->vector-maker
(match-lambda
['short make-s16vector]
['int make-s32vector]
['double make-f64vector]))
;; return the cpointer-extractor that corresponds to a given sample-type
(define sample-type->cpointer-extractor
(match-lambda
['short s16vector->cpointer]
['int s32vector->cpointer]
['double flvector->cpointer]))
;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, 'double, or 'float
;; types of samples we handle: 'short, 'int, 'double
(provide sample-type)
(define sample-type
(make-parameter
'float (lambda (x)
(if (memq x '(short int float double))
(if (memq x '(short int double))
x
(error 'sample-type "bad type: ~s" x)))))
(error 'sample-type "bad or unsupported type: ~s" x)))))
@ -465,25 +484,27 @@
;; C data. It's 2-channel 32-bit float only. Also, it discards
;; all meta-information except length and sample-rate.
;; read-sound/floatblock : path-string -> (list/c _pointer nat nat)
(define global-channels 2)
;; read-sound/s16vector : path-string -> (list/c _pointer nat nat)
;; read the file into a buffer, return the data, the number of frames,
;; and the sample rate.
(provide read-sound/floatblock)
(define (read-sound/floatblock file)
(parameterize ([sample-type 'float])
(let*-values ([(cblock meta) (read-sound-internal file #:split #f)])
(provide read-sound/s16vector)
(define (read-sound/s16vector file)
(parameterize ([sample-type 'short])
(let*-values ([(cblock meta) (read-sound-internal file)])
(list cblock (cadr (assq 'frames meta)) (cadr (assq 'samplerate meta))))))
;; write-sound/floatblock : _pointer nat nat path-string -> (void)
;; write the floatblock sound to the given file as a wav.
(provide write-sound/floatblock)
(define (write-sound/floatblock data frames sample-rate file)
(write-sound-internal/cblock file data '(wav float file)
;; write-sound/s16vector : _pointer nat nat path-string -> (void)
;; write the cblock sound to the given file as a wav.
(provide write-sound/s16vector)
(define (write-sound/s16vector data sample-rate file)
(write-sound-internal/s16vector file data '(wav pcm-16 file)
sample-rate
frames
(/ (s16vector-length data) global-channels)
2
'float
;; for now, no meta-data possible.
'short
;; meta-data not supported.
'()))

34
collects/ffi/vector.rkt
View File

@ -36,7 +36,9 @@
[_TAG (id "_" "")]
[_TAG* (id "_" "*")]
[TAGname name]
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)])
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)]
[s16? (if (eq? (syntax-e #'TAG) 's16) #'#t #'#f)]
[u16? (if (eq? (syntax-e #'TAG) 'u16) #'#t #'#f)])
#'(begin
(define-struct TAG (ptr length))
(provide TAG? TAG-length (rename-out [TAG s:TAG]))
@ -57,19 +59,28 @@
(define* (TAG-ref v i)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if f64? ;; use JIT-inlined operation
(unsafe-f64vector-ref v i)
(ptr-ref (TAG-ptr v) type i))
;; use JIT-inlined operation if available:
(cond
[f64? (unsafe-f64vector-ref v i)]
[s16? (unsafe-s16vector-ref v i)]
[u16? (unsafe-u16vector-ref v i)]
[else (ptr-ref (TAG-ptr v) type i)])
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-ref TAGname v)))
(define* (TAG-set! v i x)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if (and f64? ;; use JIT-inlined operation
(inexact-real? x))
(unsafe-f64vector-set! v i x)
(ptr-set! (TAG-ptr v) type i x))
;; use JIT-inlined operation if available:
(cond
[(and f64? (inexact-real? x))
(unsafe-f64vector-set! v i x)]
[(and s16? (fixnum? x) (unsafe-fx<= -32768 x) (unsafe-fx<= x 32767))
(unsafe-s16vector-set! v i x)]
[(and u16? (fixnum? x) (unsafe-fx<= 0 x) (unsafe-fx<= x 65535))
(unsafe-u16vector-set! v i x)]
[else
(ptr-set! (TAG-ptr v) type i x)])
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-set! TAGname v)))
@ -135,6 +146,13 @@
[bytes->list u8vector->list ]
[list->bytes list->u8vector ]
[_bytes _u8vector ]))
(define (u8vector->cpointer v)
(unless (bytes? v)
(raise-type-error 'u8vector->cpointer "byte string" v))
v)
(provide u8vector->cpointer)
;; additional `u8vector' bindings for srfi-66
(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
(define* (u8vector-compare v1 v2)

16
collects/racket/contract/private/arr-i.rkt
View File

@ -34,7 +34,7 @@
(struct ->i (arg-ctcs arg-dep-ctcs indy-arg-ctcs
rng-ctcs rng-dep-ctcs indy-rng-ctcs
pre/post-procs
mandatory-args opt-args mandatory-kwds opt-kwds rest?
mandatory-args opt-args mandatory-kwds opt-kwds rest? mtd?
here
mk-wrapper
name-info)
@ -149,7 +149,18 @@
,@(if post-info
`(#:post ,post-info ...)
'()))))
#:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
#:first-order
(λ (ctc)
(let ([has-rest? (->i-rest? ctc)]
[mtd? (->i-mtd? ctc)]
[mand-args (->i-mandatory-args ctc)]
[opt-args (->i-opt-args ctc)]
[mand-kwds (->i-mandatory-kwds ctc)]
[opt-kwds (->i-opt-kwds ctc)])
(λ (val)
(if has-rest?
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f)
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f)))))
#:stronger (λ (this that) (eq? this that)))) ;; WRONG
;; find-ordering : (listof arg) -> (values (listof arg) (listof number))
@ -731,6 +742,7 @@
(istx-args an-istx)))
keyword<?)
#,(and (istx-rst an-istx) #t)
#,(and (syntax-parameter-value #'making-a-method) #t)
(quote-module-path)
#,wrapper-func
'#(#,(for/list ([an-arg (in-list (istx-args an-istx))])

94
collects/racket/contract/private/arrow.rkt
View File

@ -965,13 +965,20 @@ v4 todo:
(λ (blame)
(let ([this->d-id (gensym '->d-tail-key)])
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame)
(if (->d-rest-ctc ->d-stct)
(check-procedure/more val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame))
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
@ -1246,7 +1253,16 @@ v4 todo:
(list '#:post '...)
(list)))))
#:first-order (λ (ctc) (λ (x) #f))
#:first-order (λ (ctc)
(λ (val)
(let* ([mtd? (->d-mtd? ctc)]
[dom-length (length (->d-mandatory-dom-ctcs ctc))]
[optionals (length (->d-optional-dom-ctcs ctc))]
[mandatory-kwds (->d-mandatory-keywords ctc)]
[optional-kwds (->d-optional-keywords ctc)])
(if (->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f)
(check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f)))))
#:stronger (λ (this that) (eq? this that))))
@ -1555,22 +1571,23 @@ v4 todo:
(null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-blame-error
blame
val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length)
(if (null? optionals) "" " mandatory")
(if (null? mandatory-kwds) "" " ordinary")
(if (= 1 dom-length) "" "s")
(if (zero? optionals) ""
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
(keyword-error-text mandatory-kwds optional-keywords)
val)))
(or (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(and blame
(raise-blame-error
blame
val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length)
(if (null? optionals) "" " mandatory")
(if (null? mandatory-kwds) "" " ordinary")
(if (= 1 dom-length) "" "s")
(if (zero? optionals) ""
(format " and up to ~a optional argument~a" optionals (if (= 1 optionals) "" "s")))
(keyword-error-text mandatory-kwds optional-keywords)
val))))
(define (procedure-arity-includes?/optionals f base optionals)
(cond
@ -1620,20 +1637,21 @@ v4 todo:
(format-keywords-error 'optional optional-keywords))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(raise-blame-error
blame
val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
(cond
[(zero? dom-length) "no"]
[else dom-length])
(if (= 1 dom-length) "" "s")
(keyword-error-text mandatory-kwds optional-kwds)
val)))
(or (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(and blame
(raise-blame-error
blame
val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
(cond
[(zero? dom-length) "no"]
[else dom-length])
(if (= 1 dom-length) "" "s")
(keyword-error-text mandatory-kwds optional-kwds)
val))))
;; timing & size tests

14
collects/racket/contract/private/base.rkt
View File

@ -48,13 +48,11 @@ improve method arity mismatch contract violation error messages?
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg usr #t))
v)])
(if (and name
(not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(if (and (not (parameter? new-val)) ;; when PR 11221 is fixed, remove this line
(procedure? new-val)
(not (eq? name (object-name new-val))))
(let ([name (if (symbol? name)
name
(string->symbol (format "~a" name)))])
(object-name v)
(not (eq? (object-name v) (object-name new-val))))
(let ([vs-name (object-name v)])
(cond
[(contracted-function? new-val)
;; when PR11222 is fixed, change these things:
@ -63,10 +61,10 @@ improve method arity mismatch contract violation error messages?
;; - change (struct-out contracted-function)
;; in arrow.rkt to make-contracted-function
(make-contracted-function
(procedure-rename (contracted-function-proc new-val) name)
(procedure-rename (contracted-function-proc new-val) vs-name)
(contracted-function-ctc new-val))]
[else
(procedure-rename new-val name)]))
(procedure-rename new-val vs-name)]))
new-val))))
(define-syntax (recursive-contract stx)

18
collects/racket/fixnum.rkt
View File

@ -1,5 +1,6 @@
#lang scheme/base
(require '#%flfxnum)
(require '#%flfxnum
"private/vector-wraps.rkt")
(provide fx->fl fl->fx
fxabs
@ -8,4 +9,17 @@
fxand fxior fxxor
fxnot fxrshift fxlshift
fx>= fx> fx= fx< fx<=
fxmin fxmax)
fxmin fxmax
fxvector? fxvector make-fxvector
shared-fxvector make-shared-fxvector
fxvector-length fxvector-ref fxvector-set!
fxvector-copy
in-fxvector for/fxvector for*/fxvector)
(define-vector-wraps "fxvector"
fxvector? fxvector-length fxvector-ref fxvector-set! make-fxvector
in-fxvector*
in-fxvector
for/fxvector
for*/fxvector
fxvector-copy)

110
collects/racket/flonum.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require '#%flfxnum (for-syntax racket/base))
(require '#%flfxnum
"private/vector-wraps.rkt")
(provide fl+ fl- fl* fl/
flabs flsqrt flexp fllog
@ -8,105 +9,16 @@
fl= fl< fl<= fl> fl>= flmin flmax
->fl fl->exact-integer
flvector? flvector make-flvector
shared-flvector make-shared-flvector
flvector-length flvector-ref flvector-set!
flvector-copy
flreal-part flimag-part make-flrectangular
in-flvector for/flvector for*/flvector shared-flvector make-shared-flvector)
(define (in-flvector* flv)
(let ((n (flvector-length flv)))
(make-do-sequence
(lambda ()
(values (lambda (i) (flvector-ref flv i))
add1
0
(lambda (i) (fx< i n))
(lambda (x) #t)
(lambda (i x) #t))))))
(define-sequence-syntax in-flvector
(lambda () (syntax in-flvector*))
(lambda (stx)
(syntax-case stx ()
(((x) (in-flvector flv-expr))
(syntax/loc stx
(() (:do-in (((v) flv-expr))
(when (not (flvector? v))
(error 'in-flvector "expecting a flvector, got ~a" v))
((i 0) (n (flvector-length v)))
(fx< i n)
(((x) (flvector-ref v i)))
#t
#t
((add1 i) n))))))))
(define (list->flvector l)
(let ((n (length l)))
(let ((v (make-flvector n)))
(for ((i (in-range n))
(x (in-list l)))
(flvector-set! v i x))
v)))
(define-syntax (for/flvector stx)
(syntax-case stx ()
((for/flvector (for-clause ...) body ...)
(syntax/loc stx
(list->flvector
(for/list (for-clause ...) body ...))))
((for/flvector #:length length-expr (for-clause ...) body ...)
(syntax/loc stx
(let ((len length-expr))
(unless (exact-nonnegative-integer? len)
(raise-type-error 'for/flvector "exact nonnegative integer" len))
(let ((v (make-flvector len)))
(for/fold ((i 0))
(for-clause ...
#:when (< i len))
(flvector-set! v i (begin body ...))
(add1 i))
v))))))
(define-syntax (for*/flvector stx)
(syntax-case stx ()
((for*/flvector (for-clause ...) body ...)
(syntax/loc stx
(list->flvector
(for*/list (for-clause ...) body ...))))
((for*/flvector #:length length-expr (for-clause ...) body ...)
(syntax/loc stx
(let ((len length-expr))
(unless (exact-nonnegative-integer? len)
(raise-type-error 'for*/flvector "exact nonnegative integer" len))
(let ((v (make-flvector len)))
(for*/fold ((i 0))
(for-clause ...
#:when (< i len))
(flvector-set! v i (begin body ...))
(add1 i))
v))))))
(define (flvector-copy flv [start 0] [end (and (flvector? flv) (flvector-length flv))])
(unless (flvector? flv)
(raise-type-error 'flvector-copy "flvector" flv))
(unless (exact-nonnegative-integer? start)
(raise-type-error 'flvector-copy "non-negative exact integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'flvector-copy "non-negative exact integer" end))
(let ([orig-len (flvector-length flv)])
(unless (<= start end orig-len)
(unless (<= start orig-len)
(raise-mismatch-error 'flvector-copy
(format "start index ~s out of range [~a, ~a] for flvector: "
start 0 orig-len)
flv))
(raise-mismatch-error 'flvector-copy
(format "end index ~s out of range [~a, ~a] for flvector: "
end start orig-len)
flv)))
(let* ([len (- end start)]
[vec (make-flvector len)])
(for ([i (in-range len)])
(flvector-set! vec i (flvector-ref flv (+ i start))))
vec))
in-flvector for/flvector for*/flvector)
(define-vector-wraps "flvector"
flvector? flvector-length flvector-ref flvector-set! make-flvector
in-flvector*
in-flvector
for/flvector
for*/flvector
flvector-copy)

6
collects/racket/private/kw.rkt
View File

@ -1209,14 +1209,12 @@
[(arity-at-least? a)
(b . >= . (arity-at-least-value a))]
[else
(ormap (lambda (b a) (includes? a b))
a)])]
(ormap (lambda (a) (includes? a b)) a)])]
[(arity-at-least? b) (cond
[(number? a) #f]
[(arity-at-least? a)
((arity-at-least-value b) . >= . (arity-at-least-value a))]
[else (ormap (lambda (b a) (includes? b a))
a)])]
[else (ormap (lambda (a) (includes? b a)) a)])]
[else (andmap (lambda (b) (includes? a b)) b)]))
(unless (includes? b a)

112
collects/racket/private/vector-wraps.rkt Normal file
View File

@ -0,0 +1,112 @@
#lang racket/base
(require '#%flfxnum
(for-syntax racket/base))
(provide define-vector-wraps)
(define-syntax-rule (define-vector-wraps
fXvector-str
fXvector? fXvector-length fXvector-ref fXvector-set! make-fXvector
in-fXvector*
in-fXvector
for/fXvector
for*/fXvector
fXvector-copy)
(...
(begin
(define (in-fXvector* flv)
(let ((n (fXvector-length flv)))
(make-do-sequence
(lambda ()
(values (lambda (i) (fXvector-ref flv i))
add1
0
(lambda (i) (fx< i n))
(lambda (x) #t)
(lambda (i x) #t))))))
(define-sequence-syntax in-fXvector
(lambda () (syntax in-fXvector*))
(lambda (stx)
(syntax-case stx ()
(((x) (in-fXvector flv-expr))
(syntax/loc stx
(() (:do-in (((v) flv-expr))
(when (not (fXvector? v))
(error 'in-fXvector "expecting a ~a, got ~a" fXvector-str v))
((i 0) (n (fXvector-length v)))
(fx< i n)
(((x) (fXvector-ref v i)))
#t
#t
((add1 i) n))))))))
(define (list->fXvector l)
(let ((n (length l)))
(let ((v (make-fXvector n)))
(for ((i (in-range n))
(x (in-list l)))
(fXvector-set! v i x))
v)))
(define-syntax (for/fXvector stx)
(syntax-case stx ()
((for/fXvector (for-clause ...) body ...)
(syntax/loc stx
(list->fXvector
(for/list (for-clause ...) body ...))))
((for/fXvector #:length length-expr (for-clause ...) body ...)
(syntax/loc stx
(let ((len length-expr))
(unless (exact-nonnegative-integer? len)
(raise-type-error 'for/fXvector "exact nonnegative integer" len))
(let ((v (make-fXvector len)))
(for/fold ((i 0))
(for-clause ...
#:when (< i len))
(fXvector-set! v i (begin body ...))
(add1 i))
v))))))
(define-syntax (for*/fXvector stx)
(syntax-case stx ()
((for*/fXvector (for-clause ...) body ...)
(syntax/loc stx
(list->fXvector
(for*/list (for-clause ...) body ...))))
((for*/fXvector #:length length-expr (for-clause ...) body ...)
(syntax/loc stx
(let ((len length-expr))
(unless (exact-nonnegative-integer? len)
(raise-type-error 'for*/fXvector "exact nonnegative integer" len))
(let ((v (make-fXvector len)))
(for*/fold ((i 0))
(for-clause ...
#:when (< i len))
(fXvector-set! v i (begin body ...))
(add1 i))
v))))))
(define (fXvector-copy flv [start 0] [end (and (fXvector? flv) (fXvector-length flv))])
(unless (fXvector? flv)
(raise-type-error 'fXvector-copy fXvector-str flv))
(unless (exact-nonnegative-integer? start)
(raise-type-error 'fXvector-copy "non-negative exact integer" start))
(unless (exact-nonnegative-integer? end)
(raise-type-error 'fXvector-copy "non-negative exact integer" end))
(let ([orig-len (fXvector-length flv)])
(unless (<= start end orig-len)
(unless (<= start orig-len)
(raise-mismatch-error 'fXvector-copy
(format "start index ~s out of range [~a, ~a] for ~a: "
start 0 orig-len fXvector-str)
flv))
(raise-mismatch-error 'fXvector-copy
(format "end index ~s out of range [~a, ~a] for ~a: "
end start orig-len fXvector-str)
flv)))
(let* ([len (- end start)]
[vec (make-fXvector len)])
(for ([i (in-range len)])
(fXvector-set! vec i (fXvector-ref flv (+ i start))))
vec)))))

5
collects/redex/gui.rkt
View File

@ -103,7 +103,4 @@
[default-pretty-printer
(-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%)
void?)]
[current-pretty-printer
(parameter/c
(-> any/c output-port? exact-nonnegative-integer? (is-a?/c text%)
void?))])
[pretty-print-parameters (parameter/c (-> (-> any) any))])

2
collects/redex/pict.rkt
View File

@ -59,6 +59,8 @@
(provide/contract
[label-style (parameter/c text-style/c)]
[literal-style (parameter/c text-style/c)]
[grammar-style (parameter/c text-style/c)]
[paren-style (parameter/c text-style/c)]
[metafunction-style (parameter/c text-style/c)]
[default-style (parameter/c text-style/c)]
[non-terminal-style (parameter/c text-style/c)]

25
collects/redex/private/core-layout.rkt
View File

@ -19,6 +19,7 @@
basic-text
metafunction-text
grammar-style
paren-style
default-style
label-style
non-terminal-style
@ -79,14 +80,19 @@
(if (and (lw? thing-in-hole)
(equal? (lw-e thing-in-hole) 'hole))
(list (blank) context (blank))
(list (blank) context "" "[" thing-in-hole "]")))))
(list (blank)
context
""
(basic-text "[" (default-style))
thing-in-hole
(basic-text "]" (default-style)))))))
(hide-hole ,(λ (args)
(list (blank)
(list-ref args 2)
(blank))))
(hole ,(λ (args)
(let ([name (lw-e (list-ref args 2))])
(list "[]"
(list (basic-text "[]" (default-style))
(basic-text (format "~a" name) (non-terminal-subscript-style))))))
(name ,(λ (args)
(let ([open-paren (list-ref args 0)]
@ -374,18 +380,6 @@
(values fst snd))
(values fst (blank)))))
(define (combine-into-loc-wrapper to-wrap)
(cond
[(null? to-wrap) (blank)]
[(null? (cdr to-wrap)) (car to-wrap)]
[else
(apply hbl-append (map make-single-pict to-wrap))]))
(define (make-single-pict x)
(cond
[(pict? x) x]
[(string? x) (basic-text x (default-style))]))
(define (drop-to-lw-and1 lst)
(let loop ([lst lst])
(cond
@ -713,6 +707,8 @@
[(symbol? atom)
(list (or (rewrite-atomic col span atom literal-style)
(make-string-token col span (symbol->string atom) (literal-style))))]
[(member atom '("(" ")" "[" "]" "{" "}"))
(list (make-string-token col span atom (paren-style)))]
[(string? atom)
(list (make-string-token col span atom (default-style)))]
[else (error 'atom->tokens "unk ~s" atom)]))
@ -757,6 +753,7 @@
(define non-terminal-superscript-style (make-parameter `(superscript . ,(non-terminal-style))))
(define default-style (make-parameter 'roman))
(define grammar-style (make-parameter 'roman))
(define paren-style (make-parameter 'roman))
(define metafunction-style (make-parameter 'swiss))
(define (metafunction-text str) ((current-text) str (metafunction-style) (metafunction-font-size)))
(define literal-style (make-parameter 'swiss))

1
collects/redex/private/pict.rkt
View File

@ -34,6 +34,7 @@
default-style
grammar-style
paren-style
label-style
literal-style
metafunction-style

63
collects/redex/private/sexp-diffs.rkt
View File

@ -4,7 +4,8 @@
mrlib/graph
scheme/pretty
scheme/class
framework)
framework
"size-snip.rkt")
(provide show-differences find-differences)
@ -90,8 +91,10 @@
;; render-sexp/colors : sexp ht text -> void
(define (render-sexp/colors sexp to-color text columns)
(let ([start '()])
(parameterize ([pretty-print-columns columns])
(pretty-print sexp (open-output-text-editor text)))
((pretty-print-parameters)
(λ ()
(parameterize ([pretty-print-columns columns])
(pretty-print sexp (open-output-text-editor text)))))
(for-each
(λ (p) (send text highlight-range (car p) (cdr p) (send the-color-database find-color "NavajoWhite")))
to-color)
@ -121,32 +124,34 @@
(set! pending-bytes (bytes))))
1]))
void)])
(parameterize ([pretty-print-columns columns]
[pretty-print-remap-stylable
(λ (val)
(and (wrap? val)
(symbol? (wrap-content val))
(wrap-content val)))]
[pretty-print-size-hook
(λ (val dsp? port)
(if (wrap? val)
(string-length (format "~s" (wrap-content val)))
#f))]
[pretty-print-print-hook
(λ (val dsp? port)
(write (wrap-content val) port))]
[pretty-print-pre-print-hook
(λ (obj port)
(when (hash-ref diff-ht obj #f)
(flush-output port)
(set! start (cons position start))))]
[pretty-print-post-print-hook
(λ (obj port)
(when (hash-ref diff-ht obj #f)
(flush-output port)
(set! to-color (cons (cons (car start) position) to-color))
(set! start (cdr start))))])
(pretty-print sexp counting-port))
((pretty-print-parameters)
(λ ()
(parameterize ([pretty-print-columns columns]
[pretty-print-remap-stylable
(λ (val)
(and (wrap? val)
(symbol? (wrap-content val))
(wrap-content val)))]
[pretty-print-size-hook
(λ (val dsp? port)
(if (wrap? val)
(string-length (format "~s" (wrap-content val)))
#f))]
[pretty-print-print-hook
(λ (val dsp? port)
(write (wrap-content val) port))]
[pretty-print-pre-print-hook
(λ (obj port)
(when (hash-ref diff-ht obj #f)
(flush-output port)
(set! start (cons position start))))]
[pretty-print-post-print-hook
(λ (obj port)
(when (hash-ref diff-ht obj #f)
(flush-output port)
(set! to-color (cons (cons (car start) position) to-color))
(set! start (cdr start))))])
(pretty-print sexp counting-port))))
to-color))
;; does a map-like operation, but if the list is dotted, flattens the results into an actual list.

10
collects/redex/private/size-snip.rkt
View File

@ -9,7 +9,7 @@
size-editor-snip%
size-text%
default-pretty-printer
current-pretty-printer
pretty-print-parameters
initial-char-width
resizing-pasteboard-mixin
get-user-char-width)
@ -22,6 +22,8 @@
[(number? cw/proc) cw/proc]
[else (cw/proc expr)]))
(define pretty-print-parameters (make-parameter (λ (thunk) (thunk))))
(define (default-pretty-printer v port w spec)
(parameterize ([pretty-print-columns w]
[pretty-print-size-hook
@ -37,9 +39,9 @@
(display "hole" op)]
[(eq? val 'hole)
(display ",'hole" op)]))])
(pretty-print v port)))
(define current-pretty-printer (make-parameter default-pretty-printer))
((pretty-print-parameters)
(λ ()
(pretty-print v port)))))
(define reflowing-snip<%>
(interface ()

33
collects/redex/private/stepper.rkt
View File

@ -50,10 +50,10 @@ todo:
(define updown-label (pick-label "↕" "^"))
(define back-label (pick-label "↩" "<-"))
(define (stepper red term [pp (current-pretty-printer)])
(define (stepper red term [pp default-pretty-printer])
(stepper/seed red (list term) pp))
(define (stepper/seed red seed [pp (current-pretty-printer)])
(define (stepper/seed red seed [pp default-pretty-printer])
(define term (car seed))
;; all-nodes-ht : hash[sexp -o> (is-a/c node%)]
(define all-nodes-ht (make-hash))
@ -402,23 +402,18 @@ todo:
;; makes the last column visible
(define (pb-last-column-visible)
(for-each
(λ (x)
(let ([admin (send pb get-admin)])
(when admin
(let ([w (box 0)]
[h (box 0)]
[sr (box 0)]
[s (send x get-big-snip)])
(send admin get-view #f #f w h)
(send pb get-snip-location s #f sr #t)
'(send ec scroll-to
(max 0 (- (unbox sr) (unbox w)))
0
(unbox w)
(unbox h)
#t)))))
(car (last-pair path))))
(let ([admin (send pb get-admin)]
[sl (box 0)]
[st (box 0)]
[sr (box 0)]
[sb (box 0)])
(when admin
;; reverse so the topmost snip is the last one
(for ([node (in-list (reverse (car (last-pair path))))])
(let ([s (send node get-big-snip)])
(send pb get-snip-location s sl st #f)
(send pb get-snip-location s sr sb #t)
(send pb scroll-to s 0 0 (- (unbox sr) (unbox sl)) (- (unbox sb) (unbox st)) #t))))))
(hash-set! all-nodes-ht term root)
(send root set-in-path? #t)

4
collects/redex/private/traces.rkt
View File

@ -130,7 +130,7 @@
(define (traces/ps reductions pre-exprs filename
#:multiple? [multiple? #f]
#:pred [pred (λ (x) #t)]
#:pp [pp (current-pretty-printer)]
#:pp [pp default-pretty-printer]
#:racket-colors? [racket-colors? #t]
#:scheme-colors? [scheme-colors? racket-colors?]
#:colors [colors '()]
@ -241,7 +241,7 @@
(define (traces reductions pre-exprs
#:multiple? [multiple? #f]
#:pred [pred (λ (x) #t)]
#:pp [pp (current-pretty-printer)]
#:pp [pp default-pretty-printer]
#:colors [colors '()]
#:racket-colors? [racket-colors? #t]
#:scheme-colors? [scheme-colors? racket-colors?]

69
collects/redex/redex.scrbl
View File

@ -1458,7 +1458,7 @@ exploring reduction sequences.
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
(current-pretty-printer)]
default-pretty-printer]
[#:colors colors
(listof
(cons/c string?
@ -1477,8 +1477,8 @@ exploring reduction sequences.
void?]{
This function opens a new window and inserts each expression
in expr (if @racket[multiple?] is #t -- if
@racket[multiple?] is #f, then expr is treated as a single
in expr (if @racket[multiple?] is @racket[#t] -- if
@racket[multiple?] is @racket[#f], then expr is treated as a single
expression). Then, it reduces the terms until at least
@racket[reduction-steps-cutoff] (see below) different terms are
found, or no more reductions can occur. It inserts each new
@ -1577,7 +1577,7 @@ inserted into the editor by this library have a
[#:pp pp
(or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
(current-pretty-printer)]
default-pretty-printer]
[#:colors colors
(listof
(cons/c string?
@ -1607,7 +1607,7 @@ just before the PostScript is created with the graph pasteboard.
[t any/c]
[pp (or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
(current-pretty-printer)])
default-pretty-printer])
void?]{
This function opens a stepper window for exploring the
@ -1615,14 +1615,21 @@ behavior of its third argument in the reduction system
described by its first two arguments.
The @racket[pp] argument is the same as to the
@racket[traces] functions (above).
@racket[traces] functions (above) but is here for
backwards compatibility only and
should not be changed for most uses, but instead adjusted with
@racket[pretty-print-parameters]. Specifically, the
highlighting shown in the stepper window can be wrong if
@racket[default-pretty-printer] does not print sufficiently similarly
to how @racket[pretty-print] prints (when adjusted by
@racket[pretty-print-parameters]'s behavior, of course).
}
@defproc[(stepper/seed [reductions reduction-relation?]
[seed (cons/c any/c (listof any/c))]
[pp (or/c (any -> string)
(any output-port number (is-a?/c text%) -> void))
(current-pretty-printer)])
default-pretty-printer])
void?]{
Like @racket[stepper], this function opens a stepper window, but it
@ -1748,20 +1755,24 @@ the color used to fill the arrowhead and the text colors control the
color used to draw the label on the edge.
}
@defparam[current-pretty-printer pp (-> any/c
output-port?
exact-nonnegative-integer?
(is-a?/c text%)
void?)]{
A parameter that is used by the graphics tools to render
expressions. Defaults to @racket[default-pretty-printer].
@defparam[pretty-print-parameters f (-> (-> any/c) any/c)]{
A parameter that is used to set other @racket[pretty-print]
parameters.
Specifically, whenever @racket[default-pretty-printer] prints
something it calls @racket[f] with a thunk that does the actual
printing. Thus, @racket[f] can adjust @racket[pretty-print]'s
parameters to adjust how printing happens.
}
@defproc[(default-pretty-printer [v any/c] [port output-port?] [width exact-nonnegative-integer?] [text (is-a?/c text%)]) void?]{
This is the default value of @racket[pp] used by @racket[traces] and
@racket[stepper] and it uses
@racket[pretty-print].
@racket[pretty-print].
This function uses the value of @racket[pretty-print-parameters] to adjust how it prints.
It sets the @racket[pretty-print-columns] parameter to
@racket[width], and it sets @racket[pretty-print-size-hook]
@ -1940,15 +1951,15 @@ This function sets @racket[dc-for-text-size]. See also
@defparam[extend-language-show-union show? boolean?]{
If this is #t, then a language constructed with
If this is @racket[#t], then a language constructed with
extend-language is shown as if the language had been
constructed directly with @racket[language]. If it is #f, then only
constructed directly with @racket[language]. If it is @racket[#f], then only
the last extension to the language is shown (with
four-period ellipses, just like in the concrete syntax).
Defaultly @racket[#f].
Note that the #t variant can look a little bit strange if
Note that the @racket[#t] variant can look a little bit strange if
@racket[....] are used and the original version of the language has
multi-line right-hand sides.
}
@ -2058,6 +2069,7 @@ cases appear. If it is a list of numbers, then only the selected cases appear (c
@deftogether[[
@defparam[label-style style text-style/c]{}
@defparam[grammar-style style text-style/c]{}
@defparam[paren-style style text-style/c]{}
@defparam[literal-style style text-style/c]{}
@defparam[metafunction-style style text-style/c]{}
@defparam[non-terminal-style style text-style/c]{}
@ -2077,7 +2089,12 @@ The @racket[label-style] is used for the reduction rule label
names. The @racket[literal-style] is used for names that aren't
non-terminals that appear in patterns. The
@racket[metafunction-style] is used for the names of
metafunctions. The @racket[grammar-style] is used for the ``::='' and ``|''
metafunctions.
The @racket[paren-style] is used for the parentheses
(including ``['', ``]'', ``@"{"'', and ``@"}"'',
as well as ``('' and ``)''), but not for the square brackets used for
in-hole decompositions, which use the @racket[default-style].
The @racket[grammar-style] is used for the ``::='' and ``|''
in grammars.
The @racket[non-terminal-style] is used for the names of non-terminals.
@ -2121,7 +2138,7 @@ relation. Defaults to 4.
Controls if the open and close quotes for strings are turned
into “ and ” or are left as merely ".
Defaults to #t.
Defaults to @racket[#t].
}
@defparam[current-text proc (-> string? text-style/c number? pict?)]{
@ -2144,7 +2161,7 @@ single reduction relation.
This parameter is used when typesetting metafunctions to
determine how to create the @"\u301a\u301b"
characters. Rather than using those characters directory
characters. Rather than using those characters directly
(since glyphs tend not to be available in PostScript
fonts), they are created by combining two ‘[’ characters
or two ‘]’ characters together.
@ -2178,7 +2195,7 @@ single reduction relation.
}
@deftech{Removing the pink background from PLT Redex rendered picts and ps files}
@section[#:tag "pink"]{Removing the pink background from PLT Redex rendered picts and ps files}
When reduction rules, a metafunction, or a grammar contains
unquoted Racket code or side-conditions, they are rendered
@ -2203,7 +2220,9 @@ another @racket[lw] that contains a rewritten version of the
code.
}
@defform[(with-atomic-rewriter name-symbol string-or-thunk-returning-pict expression)]{
@defform[(with-atomic-rewriter name-symbol
string-or-thunk-returning-pict
expression)]{
This extends the current set of atomic-rewriters with one
new one that rewrites the value of name-symbol to
@ -2215,7 +2234,9 @@ of string-or-thunk-returning-pict is used whever the symbol
appears in a pattern.
}
@defform[(with-compound-rewriter name-symbol proc expression)]{
@defform[(with-compound-rewriter name-symbol
proc
expression)]{
This extends the current set of compound-rewriters with one
new one that rewrites the value of name-symbol via proc,

3
collects/scribblings/foreign/cvector.scrbl
View File

@ -25,7 +25,8 @@ needed.}
@defproc[(make-cvector [type ctype?] [length exact-nonnegative-integer?]) cvector?]{
Allocates a C vector using the given @scheme[type] and
@scheme[length].}
@scheme[length]. The resulting vector is not guaranteed to
contain any particular values.}
@defproc[(cvector [type ctype?] [val any/c] ...) cvector?]{

28
collects/scribblings/foreign/vector.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "utils.ss")
@(require "utils.ss"
(only-in scribble/decode make-splice))
@title[#:tag "homogeneous-vectors"]{Safe Homogenous Vectors}
@ -7,24 +8,21 @@
Homogenous vectors are similar to C vectors (see
@secref["foreign:cvector"]), except that they define different types
of vectors, each with a hard-wired type.
An exception is the @schemeidfont{u8} family of bindings, which are
just aliases for byte-string bindings: @scheme[make-u8vector],
@scheme[u8vector]. @scheme[u8vector?], @scheme[u8vector-length],
@scheme[u8vector-ref], @scheme[u8vector-set!],
@scheme[list->u8vector], @scheme[u8vector->list].
of vectors, each with a hard-wired type. An exception is the
@schemeidfont{u8} family of bindings, which are just aliases for
byte-string bindings; for example, @scheme[make-u8vector] is an alias
for @racket[make-bytes].
@(begin
(require (for-syntax scheme/base))
(define-syntax (srfi-4-vector stx)
(syntax-case stx ()
[(_ id elem)
#'(srfi-4-vector/desc id elem
#'(srfi-4-vector/desc id elem make-splice
"Like " (scheme make-vector) ", etc., but for " (scheme elem) " elements.")]))
(define-syntax (srfi-4-vector/desc stx)
(syntax-case stx ()
[(_ id elem . desc)
[(_ id elem extra desc ...)
(let ([mk
(lambda l
(datum->syntax
@ -57,7 +55,10 @@ just aliases for byte-string bindings: @scheme[make-u8vector],
[(list-> [lst (listof number?)]) ?]
[(->list [vec ?]) (listof number?)]
[(->cpointer [vec ?]) cpointer?])
. desc)
desc ...
(extra
(list
" The " (scheme ->cpointer) " function extracts a plain pointer to the underlying array.")))
;; Big pain: make up relatively-correct source locations
;; for pieces in the _vec definition:
(defform* [#,(datum->syntax
@ -93,10 +94,11 @@ just aliases for byte-string bindings: @scheme[make-u8vector],
"Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))])))
@srfi-4-vector/desc[u8 _uint8]{
@srfi-4-vector/desc[u8 _uint8 (lambda (x) (make-splice null))]{
Like @scheme[_cvector], but for vectors of @scheme[_byte] elements. These are
aliases for @schemeidfont{byte} operations.}
aliases for @schemeidfont{byte} operations, where @racket[u8vector->cpointer]
is the identity function.}
@srfi-4-vector[s8 _int8]
@srfi-4-vector[s16 _int16]

22
collects/scribblings/reference/chaperones.scrbl
View File

@ -150,7 +150,20 @@ order of the supplied arguments' keywords.
Pairs of @scheme[prop] and @scheme[prop-val] (the number of arguments
to @scheme[procedure-proxy] must be even) add proxy properties
or override proxy-property values of @scheme[proc].}
or override proxy-property values of @scheme[proc].
If any @scheme[prop] is @racket[proxy-prop:application-mark] and if the
associated @racket[prop-val] is a pair, then the call to @racket[proc]
is wrapped with @racket[with-continuation-mark] using @racket[(car
prop-val)] as the mark key and @racket[(cdr prop-val)] as the mark
value. In addition, if @racket[continuation-mark-set-first] with
@racket[(car prop-val)] produces a value for the immediate
continuation frame of the call to the proxied procedure, the value is
also installed as an immediate value for @racket[(car prop-val)] as a
mark during the call to @racket[wrapper-proc] (which allows tail-calls
of proxies with respect to wrapping proxies to be detected within
@racket[wrapper-proc]).}
@defproc[(proxy-struct [v any/c]
[orig-proc (or/c struct-accessor-procedure?
@ -537,3 +550,10 @@ descriptor} value, @scheme[#f] otherwise.}
Returns @scheme[#t] if @scheme[v] is an accessor procedure produced
by @scheme[make-proxy-property], @scheme[#f] otherwise.}
@defthing[proxy-prop:application-mark proxy-property?]{
A @tech{proxy property} that is recognized by @racket[proxy-procedure]
and @racket[chaperone-procedure].}

119
collects/scribblings/reference/numbers.scrbl
View File

@ -11,6 +11,10 @@
@(define math-eval (make-base-eval))
@(interaction-eval #:eval math-eval (require racket/math))
@(define flfx-eval (make-base-eval))
@(interaction-eval #:eval flfx-eval (require racket/fixnum))
@(interaction-eval #:eval flfx-eval (require racket/flonum))
@title[#:tag "numbers"]{Numbers}
@guideintro["numbers"]{numbers}
@ -1064,7 +1068,7 @@ Returns @racket[#t] if @racket[v] is a @tech{flvector}, @racket[#f] otherwise.}
Creates a @tech{flvector} containing the given inexact real numbers.
@mz-examples[(flvector 2.0 3.0 4.0 5.0)]}
@mz-examples[#:eval flfx-eval (flvector 2.0 3.0 4.0 5.0)]}
@defproc[(make-flvector [size exact-nonnegative-integer?]
[x inexact-real? 0.0])
@ -1073,7 +1077,7 @@ Creates a @tech{flvector} containing the given inexact real numbers.
Creates a @tech{flvector} with @racket[size] elements, where every
slot in the @tech{flvector} is filled with @racket[x].
@mz-examples[(make-flvector 4 3.0)]}
@mz-examples[#:eval flfx-eval (make-flvector 4 3.0)]}
@defproc[(flvector-length [vec flvector?]) exact-nonnegative-integer?]{
@ -1103,9 +1107,7 @@ first slot is position @racket[0], and the last slot is one less than
Creates a fresh @tech{flvector} of size @racket[(- end start)], with all of the
elements of @racket[vec] from @racket[start] (inclusive) to
@racket[end] (exclusive).
Returns a fresh copy of @racket[vec].}
@racket[end] (exclusive).}
@defproc[(in-flvector (v flvector?)) sequence?]{
@ -1126,10 +1128,10 @@ Like @scheme[for/vector] or @scheme[for*/vector], but for
@defproc[(shared-flvector [x inexact-real?] ...) flvector?]{
Creates a @tech{flvector} containing the given inexact real numbers.
When @secref["places"] are enabled, the new @tech{flvector} is
When @tech{places} are enabled, the new @tech{flvector} is
allocated in the @tech{shared memory space}.
@mz-examples[(shared-flvector 2.0 3.0 4.0 5.0)]}
@mz-examples[#:eval flfx-eval (shared-flvector 2.0 3.0 4.0 5.0)]}
@defproc[(make-shared-flvector [size exact-nonnegative-integer?]
@ -1138,10 +1140,10 @@ allocated in the @tech{shared memory space}.
Creates a @tech{flvector} with @racket[size] elements, where every
slot in the @tech{flvector} is filled with @racket[x].
When @secref["places"] are enabled, the new @tech{flvector} is
When @tech{places} are enabled, the new @tech{flvector} is
allocated in the @tech{shared memory space}.
@mz-examples[(make-shared-flvector 4 3.0)]}
@mz-examples[#:eval flfx-eval (make-shared-flvector 4 3.0)]}
@section{Fixnum Operations}
@ -1165,6 +1167,8 @@ to drop in unsafe versions of the library. Alternately, when
encountering crashes with code that uses unsafe fixnum operations, use
the @racketmodname[racket/fixnum] library to help debug the problems.
@subsection{Fixnum Arithmetic}
@deftogether[(
@defproc[(fx+ [a fixnum?] [b fixnum?]) fixnum?]
@defproc[(fx- [a fixnum?] [b fixnum?]) fixnum?]
@ -1220,6 +1224,102 @@ Safe versions of @racket[unsafe-fx=], @racket[unsafe-fx<],
Safe versions of @racket[unsafe-fx->fl] and @racket[unsafe-fl->fx].}
@subsection{Fixnum Vectors}
A @deftech{fxvector} is like a @tech{vector}, but it holds only
@tech{fixnums}. The only advantage of an @tech{fxvector} over a
@tech{vector} is that a shared version can be created with functions
like @racket[shared-fxvector].
Two @tech{fxvectors} are @racket[equal?] if they have the same length,
and if the values in corresponding slots of the @tech{fxvectors} are
@racket[equal?].
@defproc[(fxvector? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a @tech{fxvector}, @racket[#f] otherwise.}
@defproc[(fxvector [x fixnum?] ...) fxvector?]{
Creates a @tech{fxvector} containing the given @tech{fixnums}.
@mz-examples[#:eval flfx-eval (fxvector 2 3 4 5)]}
@defproc[(make-fxvector [size exact-nonnegative-integer?]
[x fixnum? 0])
fxvector?]{
Creates a @tech{fxvector} with @racket[size] elements, where every
slot in the @tech{fxvector} is filled with @racket[x].
@mz-examples[#:eval flfx-eval (make-fxvector 4 3)]}
@defproc[(fxvector-length [vec fxvector?]) exact-nonnegative-integer?]{
Returns the length of @racket[vec] (i.e., the number of slots in the
@tech{fxvector}).}
@defproc[(fxvector-ref [vec fxvector?] [pos exact-nonnegative-integer?])
fixnum?]{
Returns the @tech{fixnum} in slot @racket[pos] of
@racket[vec]. The first slot is position @racket[0], and the last slot
is one less than @racket[(fxvector-length vec)].}
@defproc[(fxvector-set! [vec fxvector?] [pos exact-nonnegative-integer?]
[x fixnum?])
fixnum?]{
Sets the @tech{fixnum} in slot @racket[pos] of @racket[vec]. The
first slot is position @racket[0], and the last slot is one less than
@racket[(fxvector-length vec)].}
@defproc[(fxvector-copy [vec fxvector?]
[start exact-nonnegative-integer? 0]
[end exact-nonnegative-integer? (vector-length v)])
fxvector?]{
Creates a fresh @tech{fxvector} of size @racket[(- end start)], with all of the
elements of @racket[vec] from @racket[start] (inclusive) to
@racket[end] (exclusive).}
@defproc[(in-fxvector (v fxvector?)) sequence?]{
Produces a sequence that gives the elements of @scheme[v] in order.
Inside a @scheme[for] form, this can be optimized to step through the
elements of @scheme[v] efficiently as in @scheme[in-list],
@scheme[in-vector], etc.}
@deftogether[(
@defform*[((for/fxvector (for-clause ...) body ...)
(for/fxvector #:length length-expr (for-clause ...) body ...))]
@defform*[((for*/fxvector (for-clause ...) body ...)
(for*/fxvector #:length length-expr (for-clause ...) body ...))])]{
Like @scheme[for/vector] or @scheme[for*/vector], but for
@tech{fxvector}s.}
@defproc[(shared-fxvector [x fixnum?] ...) fxvector?]{
Creates a @tech{fxvector} containing the given @tech{fixnums}.
When @tech{places} are enabled, the new @tech{fxvector} is
allocated in the @tech{shared memory space}.
@mz-examples[#:eval flfx-eval (shared-fxvector 2 3 4 5)]}
@defproc[(make-shared-fxvector [size exact-nonnegative-integer?]
[x fixnum? 0])
fxvector?]{
Creates a @tech{fxvector} with @racket[size] elements, where every
slot in the @tech{fxvector} is filled with @racket[x].
When @tech{places} are enabled, the new @tech{fxvector} is
allocated in the @tech{shared memory space}.
@mz-examples[#:eval flfx-eval (make-shared-fxvector 4 3)]}
@; ------------------------------------------------------------------------
@section{Extra Constants and Functions}
@ -1287,3 +1387,4 @@ Hence also:
@; ----------------------------------------------------------------------
@close-eval[math-eval]
@close-eval[flfx-eval]

2
collects/scribblings/reference/places.scrbl
View File

@ -16,7 +16,7 @@
@; ----------------------------------------------------------------------
The PLT Places API enables the development of parallel programs which
@deftech{Places} enable the development of parallel programs that
take advantage of machines with multiple processors, cores, or
hardware threads.

26
collects/scribblings/reference/unsafe.scrbl
View File

@ -5,7 +5,13 @@
(only-in ffi/vector
f64vector?
f64vector-ref
f64vector-set!)))
f64vector-set!
u16vector?
u16vector-ref
u16vector-set!
s16vector?
s16vector-ref
s16vector-set!)))
@title[#:tag "unsafe"]{Unsafe Operations}
@ -257,6 +263,24 @@ Unsafe versions of @scheme[f64vector-ref] and
@scheme[f64vector-set!].}
@deftogether[(
@defproc[(unsafe-s16vector-ref [vec s16vector?] [k fixnum?]) (integer-in -32768 32767)]
@defproc[(unsafe-s16vector-set! [vec s16vector?] [k fixnum?] [n (integer-in -32768 32767)]) void?]
)]{
Unsafe versions of @scheme[s16vector-ref] and
@scheme[s16vector-set!].}
@deftogether[(
@defproc[(unsafe-u16vector-ref [vec u16vector?] [k fixnum?]) (integer-in 0 65535)]
@defproc[(unsafe-u16vector-set! [vec u16vector?] [k fixnum?] [n (integer-in 0 65535)]) void?]
)]{
Unsafe versions of @scheme[u16vector-ref] and
@scheme[u16vector-set!].}
@deftogether[(
@defproc[(unsafe-struct-ref [v (not/c chaperone?)] [k fixnum?]) any/c]
@defproc[(unsafe-struct-set! [v (not/c chaperone?)] [k fixnum?] [val any/c]) void?]

6
collects/string-constants/english-string-constants.rkt
View File

@ -446,8 +446,10 @@ please adhere to these guidelines:
(online-coloring-active "Color syntax interactively")
(open-files-in-tabs "Open files in separate tabs (not separate windows)")
(show-interactions-on-execute "Automatically open interactions window when running a program")
(switch-to-module-language-automatically "Automatically switch to the module language when opening a module")
(interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one
(switch-to-module-language-automatically "Automatically switch to the module language when opening a module")
(interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one
(show-line-numbers "Show line numbers")
(hide-line-numbers "Hide line numbers")
(limit-interactions-size "Limit interactions size")
(background-color "Background Color")
(default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color"

4
collects/tests/drracket/hangman.rkt
View File

@ -8,7 +8,9 @@
(define defs (send drs get-definitions-text))
(define rep (send drs get-interactions-text))
(set-language-level! (list #rx"How to Design Programs" #rx"Beginning Student$"))
(send defs load-file (collection-file-path "hangman1.rkt" "htdp" "tests"))
(run-one/sync
(lambda ()
(send defs load-file (collection-file-path "hangman1.rkt" "htdp" "tests"))))
(do-execute drs)
(insert-in-interactions drs "(hangman make-word reveal symbol?)")
(alt-return-in-interactions drs)

48
collects/tests/racket/chaperone.rktl
View File

@ -1151,4 +1151,52 @@
;; ----------------------------------------
(let ()
(define (f x)
(call-with-immediate-continuation-mark
'z
(lambda (val)
(list val
(continuation-mark-set->list (current-continuation-marks) 'z)))))
(define saved null)
(define g (chaperone-procedure
f
(lambda (a)
(set! saved (cons (continuation-mark-set-first #f 'z)
saved))
(values (lambda (r) r)
a))
proxy-prop:application-mark
(cons 'z 12)))
(define h (chaperone-procedure
g
(lambda (a)
(values (lambda (r) r)
a))
proxy-prop:application-mark
(cons 'z 9)))
(define i (chaperone-procedure
f
(lambda (a)
(set! saved (cons (continuation-mark-set-first #f 'z)
saved))
a)
proxy-prop:application-mark
(cons 'z 11)))
(define j (chaperone-procedure
i
(lambda (a) a)
proxy-prop:application-mark
(cons 'z 12)))
(test (list 12 '(12)) g 10)
(test '(#f) values saved)
(test (list 12 '(12 9)) h 10)
(test '(9 #f) values saved)
(test (list 11 '(11)) i 10)
(test '(#f 9 #f) values saved)
(test (list 11 '(11)) j 10)
(test '(12 #f 9 #f) values saved))
;; ----------------------------------------
(report-errs)

6
collects/tests/racket/contract-test.rktl
View File

@ -9552,6 +9552,12 @@ so that propagation occurs.
(ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x y . z) #f))
(ctest #f contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ (x) #f))
(ctest #t contract-first-order-passes? (->* (integer?) () #:rest any/c (values char? any/c)) (λ x #f))
(ctest #t contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x) x))
(ctest #f contract-first-order-passes? (->d ((z any/c)) () (result any/c)) (λ (x y) x))
(ctest #t contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x) x))
(ctest #f contract-first-order-passes? (->i ((z any/c)) () (result any/c)) (λ (x y) x))
(ctest #t contract-first-order-passes? (listof integer?) (list 1))
(ctest #f contract-first-order-passes? (listof integer?) #f)

70
collects/tests/racket/fixnum.rktl
View File

@ -151,4 +151,74 @@
;; check a small range
(same-results/range/table)
;; ----------------------------------------
;; in-fxvector tests.
(let ((flv (fxvector 1 2 3)))
(let ((flv-seq (in-fxvector flv)))
(for ((x (in-fxvector flv))
(xseq flv-seq)
(i (in-naturals)))
(test (+ i 1) 'in-fxvector-fast x)
(test (+ i 1) 'in-fxvector-sequence xseq))))
;; for/fxvector test
(let ((flv (fxvector 1 2 3))
(flv1 (for/fxvector ((i (in-range 3))) (+ i 1)))
(flv2 (for/fxvector #:length 3 ((i (in-range 3))) (+ i 1))))
(test flv 'for/fxvector flv1)
(test flv 'for/fxvector-fast flv2))
;; for*/fxvector test
(let ((flv (fxvector 0 0 0 0 1 2 0 2 4))
(flv1 (for*/fxvector ((i (in-range 3)) (j (in-range 3))) (* 1 i j)))
(flv2 (for*/fxvector #:length 9 ((i (in-range 3)) (j (in-range 3))) (* 1 i j))))
(test flv 'for*/fxvector flv1)
(test flv 'for*/fxvector-fast flv2))
;; Test for both length too long and length too short
(let ((v (make-fxvector 3)))
(fxvector-set! v 0 0)
(fxvector-set! v 1 1)
(let ((w (for/fxvector #:length 3 ((i (in-range 2))) i)))
(test v 'for/fxvector-short-iter w)))
(let ((v (make-fxvector 10)))
(for* ((i (in-range 3))
(j (in-range 3)))
(fxvector-set! v (+ j (* i 3)) (+ 1 i j)))
(let ((w (for*/fxvector #:length 10 ((i (in-range 3)) (j (in-range 3))) (+ 1 i j))))
(test v 'for*/fxvector-short-iter w)))
(test 2 'for/fxvector-long-iter
(fxvector-length (for/fxvector #:length 2 ((i (in-range 10))) i)))
(test 5 'for*/fxvector-long-iter
(fxvector-length (for*/fxvector #:length 5 ((i (in-range 3)) (j (in-range 3))) (+ i j))))
;; Test for many body expressions
(let* ((flv (fxvector 1 2 3))
(flv2 (for/fxvector ((i (in-range 3)))
(fxvector-set! flv i (+ (fxvector-ref flv i) 1))
(fxvector-ref flv i)))
(flv3 (for/fxvector #:length 3 ((i (in-range 3)))
(fxvector-set! flv i (+ (fxvector-ref flv i) 1))
(fxvector-ref flv i))))
(test (fxvector 2 3 4) 'for/fxvector-many-body flv2)
(test (fxvector 3 4 5) 'for/fxvector-length-many-body flv3))
;; fxvector-copy test
(let ((v (fxvector 0 1 2 3)))
(let ((vc (fxvector-copy v)))
(test (fxvector-length v) 'fxvector-copy (fxvector-length vc))
(for ((vx (in-fxvector v))
(vcx (in-fxvector vc)))
(test vx 'fxvector-copy vcx))
(fxvector-set! vc 2 -10)
(test 2 'fxvector-copy (fxvector-ref v 2))
(test -10 'fxvector-copy (fxvector-ref vc 2))
(test '(2 3) 'fxvector-copy (for/list ([i (in-fxvector (fxvector-copy v 2))]) i))
(test '(2) 'fxvector-copy (for/list ([i (in-fxvector (fxvector-copy v 2 3))]) i))))
;; ----------------------------------------
(report-errs)

7
collects/tests/racket/optimize.rktl
View File

@ -552,6 +552,10 @@
(bin-exact 3.3 'flvector-ref (flvector 1.1 2.2 3.3) 2)
(un-exact 3 'flvector-length (flvector 1.1 2.2 3.3) #t)
(bin-exact 11 'fxvector-ref (fxvector 11 21 31) 0 #t)
(bin-exact 31 'fxvector-ref (fxvector 11 21 31) 2)
(un-exact 3 'fxvector-length (fxvector 11 21 31) #t)
(bin-exact #\a 'string-ref "abc\u2001" 0 #t)
(bin-exact #\b 'string-ref "abc\u2001" 1)
(bin-exact #\c 'string-ref "abc\u2001" 2)
@ -594,7 +598,8 @@
(test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t)
(test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f)
(test-setter make-string #\a #\7 'string-set! string-set! string-ref #f)
(test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f))
(test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f)
(test-setter make-fxvector 1 7 'fxvector-set! fxvector-set! fxvector-ref #f))
(let ([v (box 1)])
(check-error-message 'set-box! (eval `(lambda (x) (set-box! x 10))))

26
collects/tests/racket/unsafe.rktl
View File

@ -5,6 +5,7 @@
(require scheme/unsafe/ops
scheme/flonum
scheme/fixnum
scheme/foreign)
(let ()
@ -271,6 +272,31 @@
#:post (lambda (x) (list x (f64vector-ref v 2)))
#:literal-ok? #f))
(test-bin 95 'unsafe-fxvector-ref (fxvector 10 95 187) 1)
(test-un 5 'unsafe-fxvector-length (fxvector 11 20 31 45 57))
(let ([v (fxvector 10 95 187)])
(test-tri (list (void) 274) 'unsafe-fxvector-set! v 2 274
#:pre (lambda () (fxvector-set! v 2 0))
#:post (lambda (x) (list x (fxvector-ref v 2)))
#:literal-ok? #f))
(test-bin 95 'unsafe-s16vector-ref (s16vector 10 95 187) 1)
(let ([v (s16vector 10 95 187)])
(test-tri (list (void) 274) 'unsafe-s16vector-set! v 2 274
#:pre (lambda () (s16vector-set! v 2 0))
#:post (lambda (x) (list x (s16vector-ref v 2)))
#:literal-ok? #f))
(test-bin -32768 'unsafe-s16vector-ref (s16vector 10 -32768 187) 1)
(test-bin 32767 'unsafe-s16vector-ref (s16vector 10 32767 187) 1)
(test-bin 95 'unsafe-u16vector-ref (u16vector 10 95 187) 1)
(let ([v (u16vector 10 95 187)])
(test-tri (list (void) 274) 'unsafe-u16vector-set! v 2 274
#:pre (lambda () (u16vector-set! v 2 0))
#:post (lambda (x) (list x (u16vector-ref v 2)))
#:literal-ok? #f))
(test-bin 65535 'unsafe-u16vector-ref (u16vector 10 65535 187) 1)
(for ([star (list values (add-star "star"))])
(define-struct posn (x [y #:mutable] z))
(test-bin 'a unsafe-struct-ref (make-posn 'a 'b 'c) 0 #:literal-ok? #f)

5
collects/texpict/utils.rkt
View File

@ -47,7 +47,6 @@
color-series
scale-color
scale
scale/improve-new-text
cellophane
@ -56,7 +55,7 @@
clip
hyperlinkize)
(define (pict-path? p)
(or (pict? p)
(and (pair? p)
@ -64,6 +63,8 @@
(andmap pict? p))))
(provide/contract
[scale (case-> (-> pict? number? number? pict?)
(-> pict? number? pict?))]
[pin-line (->* (pict?
pict-path? (-> pict? pict-path? (values number? number?))
pict-path? (-> pict? pict-path? (values number? number?)))

102
collects/typed-scheme/typecheck/tc-app-helper.rkt
View File

@ -1,7 +1,8 @@
#lang scheme/base
(require "../utils/utils.rkt" racket/match unstable/list
(utils tc-utils) (rep type-rep) (types utils union abbrev))
(only-in srfi/1 unzip4) (only-in racket/list make-list)
(utils tc-utils) (rep type-rep) (types utils union abbrev subtype))
(provide (all-defined-out))
@ -59,20 +60,91 @@
""))]
[else
(let ([label (if expected "Types: " "Domains: ")]
[nl+spc (if expected "\n " "\n ")]
[pdoms (map make-printable doms)])
(string-append
label
(stringify (if expected
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str
"\n"
(if expected
(format "Expected result: ~a\n" (make-printable expected))
"")))]))
[nl+spc (if expected "\n " "\n ")])
;; we restrict the domains shown in the error messages to those that
;; are useful
(let-values ([(pdoms rngs rests drests) (possible-domains doms rests drests rngs expected)])
(let ([pdoms (map make-printable pdoms)])
(string-append
label
(stringify (if expected
(map stringify-domain pdoms rests drests rngs)
(map stringify-domain pdoms rests drests))
nl+spc)
"\nArguments: "
arguments-str
"\n"
(if expected
(format "Expected result: ~a\n" (make-printable expected))
"")))))]))
;; to avoid long and confusing error messages, in the case of functions with
;; multiple similar domains (<, >, +, -, etc.), we show only the domains that
;; are relevant to this specific error
;; this is done in several ways:
;; - if a case-lambda case is subsumed by another, we don't need to show it
;; (subsumed cases may be useful for their filter information, but this is
;; unrelated to error reporting)
;; - if we have an expected type, we don't need to show the domains for which
;; the result type is not a subtype of the expected type
(define (possible-domains doms rests drests rngs expected)
;; is fun-ty subsumed by a function type in others?
(define (is-subsumed-in? fun-ty others)
;; assumption: domains go from more specific to less specific
;; thus, a domain can only be subsumed by another that is further down
;; the list.
;; this is reasonable because a more specific domain coming after a more
;; general domain would never be matched
;; a case subsumes another if the first one is a subtype of the other
(ormap (lambda (x) (subtype x fun-ty))
others))
(define expected-ty (and expected (match expected [(tc-result1: t) t])))
(define (returns-subtype-of-expected? fun-ty)
(and fun-ty ; was not skipped by a previous check
(or (not expected)
(match fun-ty
[(Function: (list (arr: _ rng _ _ _)))
(let ([rng (match rng
[(Values: (list (Result: t _ _)))
t]
[(ValuesDots: (list (Result: t _ _)) _ _)
t])])
(subtype rng expected-ty))]))))
(let loop ([cases (map (compose make-Function list make-arr)
doms
(map (lambda (rng) ; strip filters
(match rng
[(Values: (list (Result: t _ _) ...))
(-values t)]
[(ValuesDots: (list (Result: t _ _) ...) _ _)
(-values t)]))
rngs)
rests drests (make-list (length doms) null))]
[candidates '()])
(if (not (null? cases))
;; discard subsumed cases
(let ([head (car cases)] [tail (cdr cases)])
(if (is-subsumed-in? head tail)
(loop tail (cons #f candidates)) ; will be skipped later
(loop tail (cons head candidates))))
;; keep only the domains for which the associated function type
;; fits our criteria
(unzip4 (map cdr ; doms, rests drests
(let* ([orig (map list
(reverse candidates)
doms
rngs
rests
drests)]
[after (filter (compose returns-subtype-of-expected? car)
orig)])
;; if we somehow eliminate all the cases (bogus expected type)
;; fall back to the showing extra cases
(if (null? after) orig after)))))))
(define (poly-fail t argtypes #:name [name #f] #:expected [expected #f])
(match t

4
collects/typed-scheme/typecheck/tc-app.rkt
View File

@ -140,7 +140,9 @@
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches arities doms rests drests rngs (map tc-expr (syntax->list pos-args)) #f #f)))
(domain-mismatches arities doms rests drests rngs
(map tc-expr (syntax->list pos-args))
#f #f #:expected expected)))
(tc/funapp (car (syntax-e form)) kw-args
(ret (make-Function new-arities))
(map tc-expr (syntax->list pos-args)) expected)))]))

2
collects/typed-scheme/typecheck/tc-funapp.rkt
View File

@ -58,7 +58,7 @@
(tc-error/expr
#:return (or expected (ret (Un)))
(string-append "No function domains matched in function application:\n"
(domain-mismatches t doms rests drests rngs argtys-t #f #f))))]
(domain-mismatches t doms rests drests rngs argtys-t #f #f #:expected expected))))]
;; any kind of dotted polymorphic function without mandatory keyword args
[((tc-result1: (and t (PolyDots:
(and vars (list fixed-vars ... dotted-var))

1
collects/typed-scheme/utils/tc-utils.rkt
View File

@ -83,6 +83,7 @@ don't depend on any other portion of the system
(define (reset!) (set! delayed-errors null))
(match (reverse delayed-errors)
[(list) (void)]
;; if there's only one, we don't need multiple-error handling
[(list (struct err (msg stx)))
(reset!)
(raise-typecheck-error msg stx)]

2
collects/web-server/http/response.rkt
View File

@ -264,7 +264,7 @@
(- (cdr range) (car range)))
converted-ranges)))
(with-handlers ([exn:fail? (lambda (exn) (network-error 'output-file (exn-message exn)))])
(call-with-input-file file-path
(call-with-input-file* file-path
(lambda (input)
(if (= (length converted-ranges) 1)
; Single ranges (in 200 or 206 responses) are sent straight out

3
collects/web-server/scribblings/servlet-env-int.scrbl
View File

@ -25,7 +25,6 @@ These functions optimize the construction of dispatchers and launching of server
[#:stateless? stateless? boolean? #f]
[#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer]
[#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))]
[#:namespace namespace (listof module-path?) empty]
[#:current-directory servlet-current-directory path-string? (current-directory)])
dispatcher/c]{
@racket[serve/servlet] starts a server and uses a particular dispatching sequence. For some applications, this
@ -41,7 +40,7 @@ These functions optimize the construction of dispatchers and launching of server
The servlet is loaded with @racket[manager] as its continuation manager. (The default manager limits the amount of memory to 64 MB and
deals with memory pressure as discussed in the @racket[make-threshold-LRU-manager] documentation.)
The modules specified by @racket[servlet-namespace] are shared with other servlets.
The servlet is run in the @racket[(current-namespace)].
}
@defproc[(serve/launch/wait

15
collects/web-server/scribblings/servlet-env.scrbl
View File

@ -108,8 +108,7 @@ Suppose you would like to start a server for a stateless Web servlet @filepath{s
(serve/servlet start #:stateless? #t)
]
@bold{Warning:} If you put the call to @racket[serve/servlet] in a @racketmodname[web-server] module directly it will not work correctly.
Consider the following module:
You can also put the call to @racket[serve/servlet] in the @racketmodname[web-server] module directly:
@racketmod[
web-server
(require web-server/servlet-env)
@ -122,11 +121,7 @@ Consider the following module:
(serve/servlet start #:stateless? #t)
]
First, if this module is not saved in a file (e.g., @filepath{servlet.rkt}), then the serialization layer cannot locate the definitions of the
serialized continuations. Second, due to an unfortunately subtle bug that we have not yet corrected,
every time the continuation link is clicked, @racket[serve/servlet] will
run and attempt to start a Web server instance and open a browser window. These problems do not occur if your servlet is saved in a file
and if @racket[serve/servlet] is run in another module.
Like always, you don't even need to save the file.
@section{Full API}
@ -194,13 +189,13 @@ and if @racket[serve/servlet] is run in another module.
as its continuation manager. (The default manager limits the amount of memory to 64 MB and
deals with memory pressure as discussed in the @racket[make-threshold-LRU-manager] documentation.)
The modules specified by @racket[servlet-namespace] are shared with other servlets.
The server files are rooted at @racket[server-root-path] (which is defaultly the distribution root.)
File paths, in addition to the @filepath["htdocs"] directory under @racket[server-root-path] may be
provided with @racket[extra-files-paths]. These paths are checked first, in the order they appear in the list.
Other servlets are served from @racket[servlets-root].
Other servlets are served from @racket[servlets-root].
The modules specified by @racket[servlet-namespace] are shared between servlets found in @racket[servlets-root] and the current namespace (and therefore
the @racket[start] procedure.)
If a file cannot be found, @racket[file-not-found-responder] is used to generate an error response.

13
collects/web-server/servlet-dispatch.rkt
View File

@ -28,7 +28,6 @@
[dispatch/servlet (((request? . -> . response/c))
(#:regexp regexp?
#:current-directory path-string?
#:namespace (listof module-path?)
#:stateless? boolean?
#:stuffer (stuffer/c serializable? bytes?)
#:manager manager?)
@ -50,9 +49,7 @@
#:regexp
[servlet-regexp #rx""]
#:current-directory
[servlet-current-directory (current-directory)]
#:namespace
[servlet-namespace empty]
[servlet-current-directory (current-directory)]
#:stateless?
[stateless? #f]
#:stuffer
@ -65,8 +62,7 @@
(body (p "Sorry, this page has expired. Please go back."))))
(* 64 1024 1024))])
(define servlet-box (box #f))
(define make-servlet-namespace
(make-make-servlet-namespace #:to-be-copied-module-specs servlet-namespace))
(define namespace-now (current-namespace))
(filter:make
servlet-regexp
(servlets:make
@ -74,10 +70,7 @@
(or (unbox servlet-box)
(let ([servlet
(parameterize ([current-custodian (make-custodian)]
[current-namespace
(make-servlet-namespace
#:additional-specs
default-module-specs)])
[current-namespace namespace-now])
(if stateless?
(make-stateless.servlet servlet-current-directory stuffer manager start)
(make-v2.servlet servlet-current-directory manager start)))])

1
collects/web-server/servlet-env.rkt
View File

@ -148,7 +148,6 @@
(dispatch/servlet
start
#:regexp servlet-regexp
#:namespace servlet-namespace
#:stateless? stateless?
#:stuffer stuffer
#:current-directory servlet-current-directory

4
doc/release-notes/racket/HISTORY.txt
View File

@ -1,3 +1,7 @@
Version 5.0.1.7
Added fxvectors
Added unsafe-{s,u}16-{ref,set!}
Version 5.0.1.6
Added prop:proxy-of

5
doc/release-notes/redex/HISTORY.txt
View File

@ -1,3 +1,8 @@
* added pretty-print-parameters
* added grammar-style and paren-style that give finer-grained control
over the typesetting styles
v5.0.1
* changed the matching of `where' clauses in a

4
src/racket/include/scheme.h
View File

@ -432,6 +432,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
#define SCHEME_IMMUTABLE_VECTORP(obj) (SCHEME_VECTORP(obj) && SCHEME_IMMUTABLEP(obj))
#define SCHEME_FLVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_flvector_type)
#define SCHEME_FXVECTORP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_fxvector_type)
#define SCHEME_STRUCTP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_structure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type))
#define SCHEME_STRUCT_TYPEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_struct_type_type)
@ -543,6 +544,9 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data)
#define SCHEME_FLVEC_SIZE(obj) (((Scheme_Double_Vector *)(obj))->size)
#define SCHEME_FLVEC_ELS(obj) (((Scheme_Double_Vector *)(obj))->els)
#define SCHEME_FXVEC_SIZE(obj) SCHEME_VEC_SIZE(obj)
#define SCHEME_FXVEC_ELS(obj) SCHEME_VEC_ELS(obj)
#define SCHEME_ENVBOX_VAL(obj) (*((Scheme_Object **)(obj)))
#define SCHEME_WEAK_BOX_VAL(obj) SCHEME_BOX_VAL(obj)

3
src/racket/src/bool.c
View File

@ -424,7 +424,8 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql)
goto top;
} else
return 0;
} else if (SCHEME_VECTORP(obj1)) {
} else if (SCHEME_VECTORP(obj1)
|| SCHEME_FXVECTORP(obj1)) {
# include "mzeqchk.inc"
if ((eql->for_chaperone == 1) && (!SCHEME_IMMUTABLEP(obj1)
|| !SCHEME_IMMUTABLEP(obj2)))

50
src/racket/src/cstartup.inc
View File

@ -1,44 +1,44 @@
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,54,51,0,0,0,1,0,0,10,0,13,0,
22,0,26,0,31,0,38,0,45,0,50,0,55,0,59,0,72,0,79,0,82,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,55,51,0,0,0,1,0,0,10,0,13,0,
22,0,26,0,31,0,38,0,45,0,50,0,55,0,68,0,72,0,79,0,82,
0,88,0,102,0,116,0,119,0,125,0,129,0,131,0,142,0,144,0,158,0,
165,0,187,0,189,0,203,0,14,1,43,1,54,1,65,1,75,1,111,1,144,
1,177,1,236,1,46,2,124,2,190,2,195,2,215,2,106,3,126,3,177,3,
243,3,128,4,14,5,66,5,89,5,168,5,0,0,109,7,0,0,69,35,37,
109,105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,63,108,
101,116,64,99,111,110,100,66,117,110,108,101,115,115,66,100,101,102,105,110,101,
64,119,104,101,110,64,108,101,116,42,63,97,110,100,72,112,97,114,97,109,101,
116,101,114,105,122,101,66,108,101,116,114,101,99,62,111,114,65,113,117,111,116,
64,119,104,101,110,64,108,101,116,42,72,112,97,114,97,109,101,116,101,114,105,
122,101,63,97,110,100,66,108,101,116,114,101,99,62,111,114,65,113,117,111,116,
101,29,94,2,14,68,35,37,107,101,114,110,101,108,11,29,94,2,14,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,36,11,8,240,141,85,0,0,95,
102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,151,85,0,0,95,
159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,4,2,2,
2,6,2,2,2,7,2,2,2,8,2,2,2,9,2,2,2,10,2,2,2,
5,2,2,2,11,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240,141,
11,2,2,2,5,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240,151,
85,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2,2,
2,3,96,38,11,8,240,141,85,0,0,16,0,96,11,11,8,240,141,85,0,
2,3,96,38,11,8,240,151,85,0,0,16,0,96,11,11,8,240,151,85,0,
0,16,0,13,16,4,36,29,11,11,2,2,11,18,16,2,99,64,104,101,114,
101,8,32,8,31,8,30,8,29,8,28,93,8,224,148,85,0,0,95,9,8,
224,148,85,0,0,2,2,27,248,22,150,4,195,249,22,143,4,80,158,39,36,
101,8,32,8,31,8,30,8,29,8,28,93,8,224,158,85,0,0,95,9,8,
224,158,85,0,0,2,2,27,248,22,150,4,195,249,22,143,4,80,158,39,36,
251,22,82,2,17,248,22,97,199,12,249,22,72,2,18,248,22,99,201,27,248,
22,150,4,195,249,22,143,4,80,158,39,36,251,22,82,2,17,248,22,97,199,
249,22,72,2,18,248,22,99,201,12,27,248,22,74,248,22,150,4,196,28,248,
22,80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73,193,
249,22,143,4,80,158,39,36,251,22,82,2,17,248,22,73,199,249,22,72,2,
10,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8,28,
16,4,11,11,2,19,3,1,8,101,110,118,49,51,50,56,54,16,4,11,11,
2,20,3,1,8,101,110,118,49,51,50,56,55,93,8,224,149,85,0,0,95,
9,8,224,149,85,0,0,2,2,27,248,22,74,248,22,150,4,196,28,248,22,
11,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8,28,
16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,48,54,16,4,11,11,
2,20,3,1,8,101,110,118,49,51,51,48,55,93,8,224,159,85,0,0,95,
9,8,224,159,85,0,0,2,2,27,248,22,74,248,22,150,4,196,28,248,22,
80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73,193,249,
22,143,4,80,158,39,36,250,22,82,2,21,248,22,82,249,22,82,248,22,82,
2,22,248,22,73,201,251,22,82,2,17,2,22,2,22,249,22,72,2,13,248,
22,74,204,18,16,2,101,11,8,32,8,31,8,30,8,29,8,28,16,4,11,
11,2,19,3,1,8,101,110,118,49,51,50,56,57,16,4,11,11,2,20,3,
1,8,101,110,118,49,51,50,57,48,93,8,224,150,85,0,0,95,9,8,224,
150,85,0,0,2,2,248,22,150,4,193,27,248,22,150,4,194,249,22,72,248,
11,2,19,3,1,8,101,110,118,49,51,51,48,57,16,4,11,11,2,20,3,
1,8,101,110,118,49,51,51,49,48,93,8,224,160,85,0,0,95,9,8,224,
160,85,0,0,2,2,248,22,150,4,193,27,248,22,150,4,194,249,22,72,248,
22,82,248,22,73,196,248,22,74,195,27,248,22,74,248,22,150,4,23,197,1,
249,22,143,4,80,158,39,36,28,248,22,57,248,22,144,4,248,22,73,23,198,
2,27,249,22,2,32,0,89,162,8,44,37,43,9,222,33,40,248,22,150,4,
@ -67,9 +67,9 @@
26,248,22,74,202,251,22,82,2,17,28,249,22,191,8,248,22,144,4,248,22,
73,200,64,101,108,115,101,10,248,22,73,197,250,22,83,2,21,9,248,22,74,
200,249,22,72,2,5,248,22,74,202,100,8,32,8,31,8,30,8,29,8,28,
16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,49,50,16,4,11,11,
2,20,3,1,8,101,110,118,49,51,51,49,51,93,8,224,151,85,0,0,18,
16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,151,85,0,0,2,
16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,51,50,16,4,11,11,
2,20,3,1,8,101,110,118,49,51,51,51,51,93,8,224,161,85,0,0,18,
16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,161,85,0,0,2,
2,27,248,22,74,248,22,150,4,196,249,22,143,4,80,158,39,36,28,248,22,
57,248,22,144,4,248,22,73,197,250,22,82,2,27,248,22,82,248,22,73,199,
248,22,97,198,27,248,22,144,4,248,22,73,197,250,22,82,2,27,248,22,82,
@ -84,13 +84,13 @@
36,36,20,105,159,36,16,0,16,1,33,33,10,16,5,2,6,89,162,8,44,
37,53,9,223,0,33,34,36,20,105,159,36,16,1,2,3,16,0,11,16,5,
2,8,89,162,8,44,37,53,9,223,0,33,35,36,20,105,159,36,16,1,2,
3,16,0,11,16,5,2,10,89,162,8,44,37,53,9,223,0,33,36,36,20,
3,16,0,11,16,5,2,11,89,162,8,44,37,53,9,223,0,33,36,36,20,
105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,13,89,162,8,44,37,
56,9,223,0,33,38,36,20,105,159,36,16,1,2,3,16,1,33,39,11,16,
5,2,4,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16,1,
2,3,16,0,11,16,5,2,12,89,162,8,44,37,53,9,223,0,33,44,36,
20,105,159,36,16,1,2,3,16,0,11,16,5,2,9,89,162,8,44,37,54,
9,223,0,33,45,36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,11,
9,223,0,33,45,36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,10,
89,162,8,44,37,55,9,223,0,33,46,36,20,105,159,36,16,1,2,3,16,
0,11,16,5,2,5,89,162,8,44,37,58,9,223,0,33,47,36,20,105,159,
36,16,1,2,3,16,1,33,49,11,16,5,2,7,89,162,8,44,37,54,9,
@ -99,7 +99,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 2024);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,54,72,0,0,0,1,0,0,8,0,21,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,55,72,0,0,0,1,0,0,8,0,21,0,
26,0,43,0,58,0,76,0,92,0,106,0,128,0,146,0,166,0,182,0,200,
0,231,0,4,1,26,1,40,1,46,1,60,1,65,1,75,1,83,1,111,1,
143,1,188,1,194,1,201,1,207,1,252,1,20,2,59,2,61,2,227,2,61,
@ -514,13 +514,13 @@
EVAL_ONE_SIZED_STR((char *)expr, 8641);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,54,9,0,0,0,1,0,0,10,0,16,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,55,9,0,0,0,1,0,0,10,0,16,0,
29,0,44,0,58,0,72,0,86,0,128,0,0,0,57,1,0,0,69,35,37,
98,117,105,108,116,105,110,65,113,117,111,116,101,29,94,2,2,67,35,37,117,
116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114,107,11,29,
94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,68,35,37,101,
120,112,111,98,115,11,29,94,2,2,68,35,37,107,101,114,110,101,108,11,97,
36,11,8,240,34,86,0,0,98,159,2,3,36,36,159,2,4,36,36,159,2,
36,11,8,240,44,86,0,0,98,159,2,3,36,36,159,2,4,36,36,159,2,
5,36,36,159,2,6,36,36,159,2,7,36,36,159,2,7,36,36,16,0,159,
36,20,105,159,36,16,1,11,16,0,83,158,42,20,103,145,2,1,2,1,29,
11,11,11,11,11,18,96,11,44,44,44,36,80,158,36,36,20,105,159,36,16,
@ -534,7 +534,7 @@
EVAL_ONE_SIZED_STR((char *)expr, 352);
}
{
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,54,74,0,0,0,1,0,0,7,0,18,0,
SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,53,46,48,46,49,46,55,74,0,0,0,1,0,0,7,0,18,0,
45,0,51,0,64,0,73,0,80,0,102,0,124,0,150,0,162,0,180,0,200,
0,212,0,228,0,251,0,7,1,38,1,45,1,50,1,55,1,60,1,65,1,
70,1,79,1,84,1,88,1,94,1,101,1,107,1,115,1,124,1,145,1,166,

46
src/racket/src/fun.c
View File

@ -4174,8 +4174,10 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
{
const char *what;
Scheme_Chaperone *px;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj;
Scheme_Object *v, *a[1], *a2[3], **argv2, *post, *result_v, *orig_obj, *app_mark;
int c, i, need_restore = 0;
int need_pop_mark = 0;
Scheme_Cont_Frame_Data cframe;
if (argv == MZ_RUNSTACK) {
/* Pushing onto the runstack ensures that px->redirects won't
@ -4221,6 +4223,26 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
return NULL;
}
if (px->props) {
app_mark = scheme_hash_tree_get(px->props, scheme_app_mark_proxy_property);
/* app_mark should be (cons mark val) */
if (app_mark && !SCHEME_PAIRP(app_mark))
app_mark = NULL;
} else
app_mark = NULL;
if (app_mark) {
v = scheme_extract_one_cc_mark(NULL, SCHEME_CAR(app_mark));
if (v) {
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(SCHEME_CAR(app_mark), v);
MZ_CONT_MARK_POS -= 2;
need_pop_mark = 1;
} else
need_pop_mark = 0;
} else
need_pop_mark = 0;
v = _scheme_apply_multi(px->redirects, argc, argv);
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
@ -4233,6 +4255,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
a2[0] = v;
argv2 = a2;
}
if (need_pop_mark) {
MZ_CONT_MARK_POS += 2;
scheme_pop_continuation_frame(&cframe);
}
if ((c == argc) || (c == (argc + 1))) {
if (c > argc) {
@ -4278,6 +4305,8 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
if (c == argc) {
/* No filter for the result, so tail call: */
if (app_mark)
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
return do_apply_chaperone(px->prev, c, argv2, auto_val);
@ -4299,6 +4328,15 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
what,
px->redirects,
post);
if (app_mark) {
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(SCHEME_CAR(app_mark), SCHEME_CDR(app_mark));
MZ_CONT_MARK_POS -= 2;
need_pop_mark = 1;
} else
need_pop_mark = 0;
if (auto_val) {
if (SCHEME_CHAPERONEP(px->prev))
result_v = do_apply_chaperone(px->prev, argc, argv2, auto_val);
@ -4314,6 +4352,7 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
v = _scheme_apply_multi(orig_obj, argc, argv2);
result_v = NULL;
}
if (v == SCHEME_MULTIPLE_VALUES) {
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
if (SAME_OBJ(p->ku.multiple.array, p->values_buffer))
@ -4325,6 +4364,11 @@ Scheme_Object *scheme_apply_chaperone(Scheme_Object *o, int argc, Scheme_Object
a[0] = v;
argv = a;
}
if (need_pop_mark) {
MZ_CONT_MARK_POS += 2;
scheme_pop_continuation_frame(&cframe);
}
if (!scheme_check_proc_arity(NULL, c, 0, -1, &post))
scheme_raise_exn(MZEXN_FAIL_CONTRACT,

2
src/racket/src/hash.c
View File

@ -1066,6 +1066,7 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi)
break;
}
case scheme_vector_type:
case scheme_fxvector_type:
case scheme_wrap_chunk_type:
{
int len = SCHEME_VEC_SIZE(o), i, val;
@ -1479,6 +1480,7 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi)
return v1 + v2;
}
case scheme_vector_type:
case scheme_fxvector_type:
case scheme_wrap_chunk_type:
{
int len = SCHEME_VEC_SIZE(o), i;

210
src/racket/src/jit.c
View File

@ -150,10 +150,12 @@ SHARED_OK static void *bad_flimag_part_code, *bad_flreal_part_code, *bad_make_fl
SHARED_OK static void *unbox_code, *set_box_code;
SHARED_OK static void *bad_vector_length_code;
SHARED_OK static void *bad_flvector_length_code;
SHARED_OK static void *bad_fxvector_length_code;
SHARED_OK static void *vector_ref_code, *vector_ref_check_index_code, *vector_set_code, *vector_set_check_index_code;
SHARED_OK static void *string_ref_code, *string_ref_check_index_code, *string_set_code, *string_set_check_index_code;
SHARED_OK static void *bytes_ref_code, *bytes_ref_check_index_code, *bytes_set_code, *bytes_set_check_index_code;
SHARED_OK static void *flvector_ref_check_index_code, *flvector_set_check_index_code, *flvector_set_flonum_check_index_code;
SHARED_OK static void *fxvector_ref_code, *fxvector_ref_check_index_code, *fxvector_set_code, *fxvector_set_check_index_code;
SHARED_OK static void *struct_ref_code, *struct_set_code;
SHARED_OK static void *syntax_e_code;
SHARED_OK void *scheme_on_demand_jit_code;
@ -6702,14 +6704,17 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
return 1;
} else if (IS_NAMED_PRIM(rator, "vector-length")
|| IS_NAMED_PRIM(rator, "fxvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-length")
|| IS_NAMED_PRIM(rator, "flvector-length")
|| IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
GC_CAN_IGNORE jit_insn *reffail, *ref;
int unsafe = 0, for_fl = 0, can_chaperone = 0;
int unsafe = 0, for_fl = 0, for_fx = 0, can_chaperone = 0;
if (IS_NAMED_PRIM(rator, "unsafe-vector-length")) {
if (IS_NAMED_PRIM(rator, "unsafe-vector-length")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-length")) {
unsafe = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-length")) {
unsafe = 1;
@ -6719,6 +6724,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
} else if (IS_NAMED_PRIM(rator, "unsafe-flvector-length")) {
unsafe = 1;
for_fl = 1;
} else if (IS_NAMED_PRIM(rator, "fxvector-length")) {
for_fx = 1;
} else {
can_chaperone = 1;
}
@ -6740,19 +6747,23 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
__END_TINY_JUMPS__(1);
reffail = _jit.x.pc;
if (!for_fl)
(void)jit_calli(bad_vector_length_code);
else
if (for_fl)
(void)jit_calli(bad_flvector_length_code);
else if (for_fx)
(void)jit_calli(bad_fxvector_length_code);
else
(void)jit_calli(bad_vector_length_code);
/* bad_vector_length_code may unpack a proxied object */
__START_TINY_JUMPS__(1);
mz_patch_branch(ref);
jit_ldxi_s(JIT_R1, JIT_R0, &((Scheme_Object *)0x0)->type);
if (!for_fl)
(void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type);
else
if (for_fl)
(void)jit_bnei_i(reffail, JIT_R1, scheme_flvector_type);
else if (for_fx)
(void)jit_bnei_i(reffail, JIT_R1, scheme_fxvector_type);
else
(void)jit_bnei_i(reffail, JIT_R1, scheme_vector_type);
__END_TINY_JUMPS__(1);
} else if (can_chaperone) {
__START_TINY_JUMPS__(1);
@ -6925,7 +6936,6 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in
}
if (name[0] != 'f') {
/* can return */
jit_retval(JIT_R0);
CHECK_LIMIT();
__START_TINY_JUMPS__(1);
refdone = jit_jmpi(jit_forward());
@ -7294,7 +7304,8 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app,
static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int base_offset,
int for_fl, int unsafe,
int unbox_flonum, int result_ignored, int can_chaperone, int for_struct)
int unbox_flonum, int result_ignored, int can_chaperone,
int for_struct, int for_fx)
/* R0 has vector. In set mode, R2 has value; if not unboxed, not unsafe, or can chaperone,
RUNSTACK has space for a temporary (intended for R2).
If int_ready, R1 has num index (for safe mode) and V1 has pre-computed offset,
@ -7323,6 +7334,8 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
if (set) {
if (for_struct)
(void)jit_calli(struct_set_code);
else if (for_fx)
(void)jit_calli(fxvector_set_check_index_code);
else if (!for_fl)
(void)jit_calli(vector_set_check_index_code);
else if (unbox_flonum)
@ -7332,6 +7345,8 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
} else {
if (for_struct)
(void)jit_calli(struct_ref_code);
else if (for_fx)
(void)jit_calli(fxvector_ref_check_index_code);
else if (!for_fl)
(void)jit_calli(vector_ref_check_index_code);
else
@ -7350,8 +7365,13 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
if (!unsafe) {
if (!int_ready)
(void)jit_bmci_ul(reffail, JIT_R1, 0x1);
if (set && for_fx)
(void)jit_bmci_ul(reffail, JIT_R2, 0x1);
jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type);
if (!for_fl) {
if (for_fx) {
(void)jit_bnei_i(reffail, JIT_R2, scheme_fxvector_type);
jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_FXVEC_SIZE(0x0));
} else if (!for_fl) {
(void)jit_bnei_i(reffail, JIT_R2, scheme_vector_type);
jit_ldxi_i(JIT_R2, JIT_R0, (int)&SCHEME_VEC_SIZE(0x0));
} else {
@ -7418,9 +7438,9 @@ static int generate_vector_op(mz_jit_state *jitter, int set, int int_ready, int
else
generate_alloc_double(jitter, 0);
}
if (can_chaperone)
mz_patch_ucbranch(pref);
}
if (can_chaperone)
mz_patch_ucbranch(pref);
return 1;
}
@ -7807,18 +7827,28 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
|| IS_NAMED_PRIM(rator, "unsafe-string-ref")
|| IS_NAMED_PRIM(rator, "bytes-ref")
|| IS_NAMED_PRIM(rator, "unsafe-bytes-ref")
|| IS_NAMED_PRIM(rator, "flvector-ref")) {
|| IS_NAMED_PRIM(rator, "flvector-ref")
|| IS_NAMED_PRIM(rator, "fxvector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-ref")) {
int simple;
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int unbox = jitter->unbox;
int can_chaperone = 1, for_struct = 0;
int can_chaperone = 1, for_struct = 0, for_fx = 0;
if (IS_NAMED_PRIM(rator, "vector-ref"))
which = 0;
else if (IS_NAMED_PRIM(rator, "fxvector-ref")) {
which = 0;
else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
for_fx = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector-ref")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxvector-ref")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
for_fx = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-ref")) {
which = 0;
unsafe = 1;
@ -7867,12 +7897,12 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which) {
/* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0, base_offset, 0, unsafe,
0, 0, can_chaperone, for_struct);
0, 0, can_chaperone, for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 0, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct);
unbox, 0, can_chaperone, for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -7924,12 +7954,12 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
if (!which) {
/* vector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1, base_offset, 0, unsafe,
0, 0, can_chaperone, for_struct);
0, 0, can_chaperone, for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-ref is relatively simple and worth inlining */
generate_vector_op(jitter, 0, 1, base_offset, 1, unsafe,
unbox, 0, can_chaperone, for_struct);
unbox, 0, can_chaperone, for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -7997,6 +8027,27 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i
generate_alloc_double(jitter, 0);
}
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-s16vector-ref")
|| IS_NAMED_PRIM(rator, "unsafe-u16vector-ref")) {
int is_u;
is_u = IS_NAMED_PRIM(rator, "unsafe-u16vector-ref");
generate_two_args(app->rand1, app->rand2, jitter, 1, 2);
jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
jit_subi_l(JIT_R1, JIT_R1, 1);
if (is_u)
jit_ldxr_us(JIT_R0, JIT_R0, JIT_R1);
else
jit_ldxr_s(JIT_R0, JIT_R0, JIT_R1);
jit_lshi_l(JIT_R0, JIT_R0, 0x1);
jit_ori_l(JIT_R0, JIT_R0, 0x1);
return 1;
} else if (IS_NAMED_PRIM(rator, "set-mcar!")
|| IS_NAMED_PRIM(rator, "set-mcdr!")) {
@ -8312,6 +8363,8 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
|| IS_NAMED_PRIM(rator, "unsafe-vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-vector*-set!")
|| IS_NAMED_PRIM(rator, "flvector-set!")
|| IS_NAMED_PRIM(rator, "fxvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-fxvector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct-set!")
|| IS_NAMED_PRIM(rator, "unsafe-struct*-set!")
|| IS_NAMED_PRIM(rator, "string-set!")
@ -8321,14 +8374,22 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
int simple, constval, can_delay_vec, can_delay_index;
int which, unsafe = 0, base_offset = ((int)&SCHEME_VEC_ELS(0x0));
int pushed, flonum_arg;
int can_chaperone = 1, for_struct = 0;
int can_chaperone = 1, for_struct = 0, for_fx = 0;
if (IS_NAMED_PRIM(rator, "vector-set!"))
which = 0;
else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) {
else if (IS_NAMED_PRIM(rator, "fxvector-set!")) {
which = 0;
for_fx = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector-set!")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
} else if (IS_NAMED_PRIM(rator, "unsafe-fxvector-set!")) {
which = 0;
unsafe = 1;
can_chaperone = 0;
for_fx = 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-vector*-set!")) {
which = 0;
unsafe = 1;
@ -8484,12 +8545,14 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0, base_offset, 0, unsafe,
flonum_arg, result_ignored, can_chaperone, for_struct);
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 0, base_offset, 1, unsafe,
flonum_arg, result_ignored, can_chaperone, for_struct);
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -8531,12 +8594,14 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
if (!which) {
/* vector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1, base_offset, 0, unsafe,
flonum_arg, result_ignored, can_chaperone, for_struct);
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 3) {
/* flvector-set! is relatively simple and worth inlining */
generate_vector_op(jitter, 1, 1, base_offset, 1, unsafe,
flonum_arg, result_ignored, can_chaperone, for_struct);
flonum_arg, result_ignored, can_chaperone,
for_struct, for_fx);
CHECK_LIMIT();
} else if (which == 1) {
if (unsafe) {
@ -8629,6 +8694,36 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int
jit_stxr_d_fppop(JIT_R1, JIT_R0, JIT_FPR0);
CHECK_LIMIT();
if (!result_ignored)
(void)jit_movi_p(JIT_R0, scheme_void);
return 1;
} else if (IS_NAMED_PRIM(rator, "unsafe-s16vector-set!")
|| IS_NAMED_PRIM(rator, "unsafe-u16vector-set!")) {
int is_u;
is_u = IS_NAMED_PRIM(rator, "unsafe-u16vector-set!");
generate_app(app, NULL, 3, jitter, 0, 0, 2);
CHECK_LIMIT();
mz_rs_ldxi(JIT_R2, 2);
mz_rs_ldr(JIT_R0);
mz_rs_ldxi(JIT_R1, 1);
mz_rs_inc(3); /* no sync */
mz_runstack_popped(jitter, 3);
CHECK_LIMIT();
jit_ldxi_p(JIT_R0, JIT_R0, (long)&(((Scheme_Structure *)0x0)->slots[0]));
jit_ldxi_p(JIT_R0, JIT_R0, (long)&SCHEME_CPTR_VAL(0x0));
jit_subi_l(JIT_R1, JIT_R1, 1);
jit_rshi_ul(JIT_R2, JIT_R2, 1);
if (is_u)
jit_stxr_us(JIT_R1, JIT_R0, JIT_R2);
else
jit_stxr_s(JIT_R1, JIT_R0, JIT_R2);
CHECK_LIMIT();
if (!result_ignored)
(void)jit_movi_p(JIT_R0, scheme_void);
@ -10976,6 +11071,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
case 8:
case 9:
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1));
JIT_UPDATE_THREAD_RSPTR();
jit_retval(JIT_R0);
mz_epilog(JIT_R1);
break;
@ -11096,6 +11192,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
register_sub_func(jitter, bad_flvector_length_code, scheme_false);
/* *** bad_fxvector_length_code *** */
/* R0 is argument */
bad_fxvector_length_code = jit_get_ip().ptr;
mz_prolog(JIT_R1);
jit_prepare(1);
jit_pusharg_i(JIT_R0);
(void)mz_finish(ts_scheme_fxvector_length);
CHECK_LIMIT();
register_sub_func(jitter, bad_fxvector_length_code, scheme_false);
/* *** call_original_unary_arith_code *** */
/* R0 is arg, R2 is code pointer, V1 is return address (for false);
if for branch, LOCAL2 is target address for true */
@ -11386,7 +11492,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
vector, it includes the offset to the start of the elements array.
In set mode, value is on run stack. */
for (iii = 0; iii < 2; iii++) { /* ref, set */
for (ii = 0; ii < 3; ii++) { /* vector, string, bytes */
for (ii = 0; ii < 4; ii++) { /* vector, string, bytes, fx */
for (i = 0; i < 2; i++) { /* check index? */
jit_insn *ref, *reffail;
Scheme_Type ty;
@ -11434,7 +11540,6 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
}
break;
default:
case 2:
ty = scheme_byte_string_type;
offset = (int)&SCHEME_BYTE_STR_VAL(0x0);
@ -11454,6 +11559,26 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
}
}
break;
default:
case 3:
ty = scheme_fxvector_type;
offset = (int)&SCHEME_VEC_ELS(0x0);
count_offset = (int)&SCHEME_VEC_SIZE(0x0);
log_elem_size = JIT_LOG_WORD_SIZE;
if (!iii) {
if (!i) {
fxvector_ref_code = code;
} else {
fxvector_ref_check_index_code = code;
}
} else {
if (!i) {
fxvector_set_code = code;
} else {
fxvector_set_check_index_code = code;
}
}
break;
}
__START_TINY_JUMPS__(1);
@ -11487,19 +11612,16 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
case 0:
if (!iii) {
(void)mz_finish(ts_scheme_checked_vector_ref);
CHECK_LIMIT();
/* Might return, if arg was chaperone */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
} else {
(void)mz_finish(ts_scheme_checked_vector_set);
/* Might return, if arg was chaperone */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(3));
JIT_UPDATE_THREAD_RSPTR();
mz_epilog(JIT_R2);
}
CHECK_LIMIT();
/* Might return, if arg was chaperone */
jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(2));
JIT_UPDATE_THREAD_RSPTR();
if (!iii)
jit_retval(JIT_R0);
mz_epilog(JIT_R2);
break;
case 1:
if (!iii) {
@ -11521,6 +11643,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
(void)mz_finish(ts_scheme_checked_byte_string_set);
}
break;
case 3:
if (!iii) {
(void)mz_finish(ts_scheme_checked_fxvector_ref);
} else {
(void)mz_finish(ts_scheme_checked_fxvector_set);
}
break;
}
/* doesn't return */
CHECK_LIMIT();
@ -11556,6 +11685,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* ref mode: */
switch (ii) {
case 0: /* vector */
case 3: /* fxvector */
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
break;
case 1: /* string */
@ -11581,7 +11711,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* set mode: */
jit_ldr_p(JIT_R2, JIT_RUNSTACK);
switch (ii) {
case 0: /* vector */
case 3: /* fxvector */
(void)jit_bmci_l(reffail, JIT_R2, 0x1);
case 0: /* vector, fall-though from fxvector */
jit_stxr_p(JIT_V1, JIT_R0, JIT_R2);
break;
case 1: /* string */

6
src/racket/src/jit_ts.c
View File

@ -73,6 +73,7 @@ define_ts_tt_s(scheme_make_complex, FSRC_OTHER)
define_ts_s_s(scheme_unbox, FSRC_MARKS)
define_ts_s_s(scheme_vector_length, FSRC_MARKS)
define_ts_s_s(scheme_flvector_length, FSRC_MARKS)
define_ts_s_s(scheme_fxvector_length, FSRC_MARKS)
define_ts_si_s(scheme_struct_ref, FSRC_MARKS)
define_ts_sis_v(scheme_struct_set, FSRC_MARKS)
define_ts_s_s(tail_call_with_values_from_multiple_result, FSRC_MARKS)
@ -87,6 +88,8 @@ define_ts_iS_s(scheme_checked_byte_string_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_byte_string_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_flvector_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_fxvector_ref, FSRC_MARKS)
define_ts_iS_s(scheme_checked_fxvector_set, FSRC_MARKS)
define_ts_iS_s(scheme_checked_syntax_e, FSRC_MARKS)
define_ts_iS_s(scheme_extract_checked_procedure, FSRC_MARKS)
define_ts_S_s(apply_checked_fail, FSRC_MARKS)
@ -145,6 +148,7 @@ define_ts_siS_v(wrong_argument_count, FSRC_MARKS)
# define ts_scheme_set_box scheme_set_box
# define ts_scheme_vector_length scheme_vector_length
# define ts_scheme_flvector_length scheme_flvector_length
# define ts_scheme_fxvector_length scheme_fxvector_length
# define ts_scheme_struct_ref scheme_struct_ref
# define ts_scheme_struct_set scheme_struct_set
# define ts_tail_call_with_values_from_multiple_result tail_call_with_values_from_multiple_result
@ -159,6 +163,8 @@ define_ts_siS_v(wrong_argument_count, FSRC_MARKS)
# define ts_scheme_checked_byte_string_set scheme_checked_byte_string_set
# define ts_scheme_checked_flvector_ref scheme_checked_flvector_ref
# define ts_scheme_checked_flvector_set scheme_checked_flvector_set
# define ts_scheme_checked_fxvector_ref scheme_checked_fxvector_ref
# define ts_scheme_checked_fxvector_set scheme_checked_fxvector_set
# define ts_scheme_checked_syntax_e scheme_checked_syntax_e
# define ts_scheme_extract_checked_procedure scheme_extract_checked_procedure
# define ts_apply_checked_fail apply_checked_fail

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

@ -265,6 +265,7 @@ typedef _uc jit_insn;
#define _qO_r_XB( OP ,R ,MD,MB,MI,MS ) ( _qO ( OP,R,0,MB),_qr_X(R,MD,MB,MI,MS) )
#define _qO_r_Xd( OP ,R ,MD,MB,MI,MS ) ( _qOd ( OP,R,0,MB),_qr_X(R,MD,MB,MI,MS) )
#define _OO_r_X( OP ,R ,MD,MB,MI,MS ) ( _OO ( OP ),_r_X( R ,MD,MB,MI,MS) )
#define _qOO_r_X( OP ,R ,MD,MB,MI,MS ) ( _qOO ( OP ),_r_X( R ,MD,MB,MI,MS) )
#define _O_r_X_B( OP ,R ,MD,MB,MI,MS,B ) ( _O ( OP ),_r_X( R ,MD,MB,MI,MS) ,_jit_B(B) )
#define _O_r_X_W( OP ,R ,MD,MB,MI,MS,W ) ( _O ( OP ),_r_X( R ,MD,MB,MI,MS) ,_jit_W(W) )
#define _O_r_X_L( OP ,R ,MD,MB,MI,MS,L ) ( _O ( OP ),_r_X( R ,MD,MB,MI,MS) ,_jit_I(L) )
@ -706,6 +707,8 @@ typedef _uc jit_insn;
#define MOVSWLrr(RS, RD) _OO_Mrm (0x0fbf ,_b11,_r1(RD),_r1(RS) )
#define MOVSWLmr(MD, MB, MI, MS, RD) _OO_r_X (0x0fbf ,_r1(RD) ,MD,MB,MI,MS )
#define MOVSWQmr(MD, MB, MI, MS, RD) _qOO_r_X (0x0fbf ,_r1(RD) ,MD,MB,MI,MS )
#define MULBr(RS) _O_Mrm (0xf6 ,_b11,_b100 ,_r1(RS) )
#define MULBm(MD,MB,MI,MS) _O_r_X (0xf6 ,_b100 ,MD,MB,MI,MS )

2
src/racket/src/lightning/i386/core.h
View File

@ -596,7 +596,7 @@ static long _CHECK_TINY(long diff) { if ((diff < -128) || (diff > 127)) *(long *
#define jit_ldi_s(d, is) MOVSWLmr((is), 0, 0, 0, (d))
#define jit_ldr_s(d, rs) MOVSWLmr(0, (rs), 0, 0, (d))
#define jit_ldxr_s(d, s1, s2) MOVSWLmr(0, (s1), (s2), 1, (d))
#define jit_ldxr_s(d, s1, s2) MOVSWQmr(0, (s1), (s2), 1, (d))
#define jit_ldxi_s(d, rs, is) MOVSWLmr((is), (rs), 0, 0, (d))
#define jit_ldi_us(d, is) MOVZWLmr((is), 0, 0, 0, (d))

28
src/racket/src/mzmark.c
View File

@ -1453,6 +1453,34 @@ static int vector_obj_FIXUP(void *p, struct NewGC *gc) {
#define vector_obj_IS_CONST_SIZE 0
static int fxvector_obj_SIZE(void *p, struct NewGC *gc) {
Scheme_Vector *vec = (Scheme_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((vec->size - 1) * sizeof(Scheme_Object *))));
}
static int fxvector_obj_MARK(void *p, struct NewGC *gc) {
Scheme_Vector *vec = (Scheme_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((vec->size - 1) * sizeof(Scheme_Object *))));
}
static int fxvector_obj_FIXUP(void *p, struct NewGC *gc) {
Scheme_Vector *vec = (Scheme_Vector *)p;
return
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((vec->size - 1) * sizeof(Scheme_Object *))));
}
#define fxvector_obj_IS_ATOMIC 1
#define fxvector_obj_IS_CONST_SIZE 0
static int flvector_obj_SIZE(void *p, struct NewGC *gc) {
Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;

9
src/racket/src/mzmarksrc.c
View File

@ -548,6 +548,15 @@ vector_obj {
+ ((vec->size - 1) * sizeof(Scheme_Object *))));
}
fxvector_obj {
Scheme_Vector *vec = (Scheme_Vector *)p;
mark:
size:
gcBYTES_TO_WORDS((sizeof(Scheme_Vector)
+ ((vec->size - 1) * sizeof(Scheme_Object *))));
}
flvector_obj {
Scheme_Double_Vector *vec = (Scheme_Double_Vector *)p;

436
src/racket/src/number.c
View File

@ -101,6 +101,15 @@ static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *fxvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *fxvector_p (int argc, Scheme_Object *argv[]);
static Scheme_Object *fxvector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_fxvector (int argc, Scheme_Object *argv[]);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_fxvector (int argc, Scheme_Object *argv[]);
static Scheme_Object *make_shared_fxvector (int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *integer_to_fl (int argc, Scheme_Object *argv[]);
static Scheme_Object *fl_to_integer (int argc, Scheme_Object *argv[]);
@ -141,6 +150,14 @@ static Scheme_Object *unsafe_flvector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_flvector_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fxvector_length (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fxvector_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_fxvector_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *s16_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *s16_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *u16_ref (int argc, Scheme_Object *argv[]);
static Scheme_Object *u16_set (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_make_flrectangular (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_flreal_part (int argc, Scheme_Object *argv[]);
static Scheme_Object *unsafe_flimag_part (int argc, Scheme_Object *argv[]);
@ -580,6 +597,46 @@ void scheme_init_flfxnum_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("flvector-set!", p, env);
scheme_add_global_constant("fxvector",
scheme_make_prim_w_arity(fxvector,
"fxvector",
0, -1),
env);
scheme_add_global_constant("fxvector?",
scheme_make_folding_prim(fxvector_p,
"fxvector?",
1, 1, 1),
env);
scheme_add_global_constant("make-fxvector",
scheme_make_immed_prim(make_fxvector,
"make-fxvector",
1, 2),
env);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
GLOBAL_PRIM_W_ARITY("shared-fxvector", shared_fxvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_shared_fxvector, 1, 2, env);
#else
GLOBAL_PRIM_W_ARITY("shared-fxvector", fxvector, 0, -1, env);
GLOBAL_PRIM_W_ARITY("make-shared-fxvector", make_fxvector, 1, 2, env);
#endif
p = scheme_make_immed_prim(fxvector_length, "fxvector-length", 1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant("fxvector-length", p, env);
p = scheme_make_immed_prim(scheme_checked_fxvector_ref,
"fxvector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant("fxvector-ref", p, env);
p = scheme_make_immed_prim(scheme_checked_fxvector_set,
"fxvector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("fxvector-set!", p, env);
p = scheme_make_folding_prim(integer_to_fl, "->fl", 1, 1, 1);
if (scheme_can_inline_fp_op())
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
@ -815,6 +872,45 @@ void scheme_init_unsafe_number(Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-flvector-set!", p, env);
p = scheme_make_immed_prim(unsafe_fxvector_length, "unsafe-fxvector-length",
1, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_UNARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxvector-length", p, env);
p = scheme_make_immed_prim(unsafe_fxvector_ref, "unsafe-fxvector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
scheme_add_global_constant("unsafe-fxvector-ref", p, env);
p = scheme_make_immed_prim(unsafe_fxvector_set, "unsafe-fxvector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-fxvector-set!", p, env);
p = scheme_make_immed_prim(s16_ref, "unsafe-s16vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
scheme_add_global_constant("unsafe-s16vector-ref", p, env);
p = scheme_make_immed_prim(s16_set, "unsafe-s16vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-s16vector-set!", p, env);
p = scheme_make_immed_prim(u16_ref, "unsafe-u16vector-ref",
2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL;
scheme_add_global_constant("unsafe-u16vector-ref", p, env);
p = scheme_make_immed_prim(u16_set, "unsafe-u16vector-set!",
3, 3);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_NARY_INLINED;
scheme_add_global_constant("unsafe-u16vector-set!", p, env);
p = scheme_make_folding_prim(unsafe_make_flrectangular, "unsafe-make-flrectangular", 2, 2, 1);
SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
| SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL);
@ -3171,60 +3267,37 @@ static Scheme_Double_Vector *alloc_shared_flvector(long size)
void *original_gc;
original_gc = GC_switch_to_master_gc();
vec = (Scheme_Double_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged,
sizeof(Scheme_Double_Vector)
+ ((size - 1) * sizeof(double)));
vec = scheme_alloc_flvector(size);
GC_switch_back_from_master(original_gc);
vec->iso.so.type = scheme_flvector_type;
SHARED_ALLOCATED_SET(vec);
vec->size = size;
return vec;
}
#endif
static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
static Scheme_Object *do_flvector (const char *name, Scheme_Double_Vector *vec, int argc, Scheme_Object *argv[])
{
int i;
Scheme_Double_Vector *vec;
for (i = 0; i < argc; i++) {
if (!SCHEME_FLOATP(argv[i])) {
scheme_wrong_type("flvector", "inexact real", i, argc, argv);
scheme_wrong_type(name, "inexact real", i, argc, argv);
return NULL;
}
}
vec = scheme_alloc_flvector(argc);
for (i = 0; i < argc; i++) {
vec->els[i] = SCHEME_FLOAT_VAL(argv[i]);
}
return (Scheme_Object *)vec;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *shared_flvector (int argc, Scheme_Object *argv[])
static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
{
int i;
Scheme_Double_Vector *vec;
return do_flvector("flvector", scheme_alloc_flvector(argc), argc, argv);
}
for (i = 0; i < argc; i++) {
if (!SCHEME_FLOATP(argv[i])) {
scheme_wrong_type("flvector", "inexact real", i, argc, argv);
return NULL;
}
}
vec = alloc_shared_flvector(argc);
for (i = 0; i < argc; i++) {
vec->els[i] = SCHEME_FLOAT_VAL(argv[i]);
}
return (Scheme_Object *)vec;
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *flvector (int argc, Scheme_Object *argv[])
{
return do_flvector("shared-flvector", scheme_alloc_shared_flvector(argc), argc, argv);
}
#endif
@ -3236,7 +3309,7 @@ static Scheme_Object *flvector_p (int argc, Scheme_Object *argv[])
return scheme_false;
}
static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
static Scheme_Object *do_make_flvector (const char *name, int as_shared, int argc, Scheme_Object *argv[])
{
Scheme_Double_Vector *vec;
long size;
@ -3245,7 +3318,7 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
size = SCHEME_INT_VAL(argv[0]);
else if (SCHEME_BIGNUMP(argv[0])) {
if (SCHEME_BIGPOS(argv[0])) {
scheme_raise_out_of_memory("make-flvector", NULL);
scheme_raise_out_of_memory(name, NULL);
return NULL;
} else
size = -1;
@ -3253,14 +3326,20 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
size = -1;
if (size < 0)
scheme_wrong_type("make-flvector", "exact non-negative integer", 0, argc, argv);
scheme_wrong_type(name, "exact non-negative integer", 0, argc, argv);
if (argc > 1) {
if (!SCHEME_FLOATP(argv[1]))
scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv);
scheme_wrong_type(name, "inexact real", 1, argc, argv);
}
vec = scheme_alloc_flvector(size);
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
if (as_shared)
vec = scheme_alloc_shared_flvector(size);
else
#else
vec = scheme_alloc_flvector(size);
#endif
if (argc > 1) {
int i;
@ -3273,42 +3352,15 @@ static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
return (Scheme_Object *)vec;
}
static Scheme_Object *make_flvector (int argc, Scheme_Object *argv[])
{
return do_make_flvector("make-flvector", 0, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *make_shared_flvector (int argc, Scheme_Object *argv[])
{
Scheme_Double_Vector *vec;
long size;
if (SCHEME_INTP(argv[0]))
size = SCHEME_INT_VAL(argv[0]);
else if (SCHEME_BIGNUMP(argv[0])) {
if (SCHEME_BIGPOS(argv[0])) {
scheme_raise_out_of_memory("make-flvector", NULL);
return NULL;
} else
size = -1;
} else
size = -1;
if (size < 0)
scheme_wrong_type("make-flvector", "exact non-negative integer", 0, argc, argv);
if (argc > 1) {
if (!SCHEME_FLOATP(argv[1]))
scheme_wrong_type("make-flvector", "inexact real", 1, argc, argv);
}
vec = alloc_shared_flvector(size);
if (argc > 1) {
int i;
double d = SCHEME_FLOAT_VAL(argv[1]);
for (i = 0; i < size; i++) {
vec->els[i] = d;
}
}
return (Scheme_Object *)vec;
return do_make_flvector("make-shared-flvector", 1, argc, argv);
}
#endif
@ -3377,6 +3429,189 @@ Scheme_Object *scheme_checked_flvector_set (int argc, Scheme_Object *argv[])
return scheme_void;
}
/************************************************************************/
/* fxvectors */
/************************************************************************/
Scheme_Vector *scheme_alloc_fxvector(long size)
{
Scheme_Vector *vec;
vec = (Scheme_Vector *)scheme_malloc_fail_ok(scheme_malloc_atomic_tagged,
sizeof(Scheme_Vector)
+ ((size - 1) * sizeof(Scheme_Object*)));
vec->iso.so.type = scheme_fxvector_type;
vec->size = size;
return vec;
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Vector *alloc_shared_fxvector(long size)
{
Scheme_Vector *vec;
void *original_gc;
original_gc = GC_switch_to_master_gc();
vec = scheme_alloc_fxvector(size);
GC_switch_back_from_master(original_gc);
return vec;
}
#endif
static Scheme_Object *do_fxvector (const char *name, Scheme_Vector *vec, int argc, Scheme_Object *argv[])
{
int i;
for (i = 0; i < argc; i++) {
if (!SCHEME_INTP(argv[i])) {
scheme_wrong_type(name, "fixnum", i, argc, argv);
return NULL;
}
vec->els[i] = argv[i];
}
return (Scheme_Object *)vec;
}
static Scheme_Object *fxvector (int argc, Scheme_Object *argv[])
{
return do_fxvector("fxvector", scheme_alloc_fxvector(argc), argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *fxvector (int argc, Scheme_Object *argv[])
{
return do_fxvector("shared-fxvector", scheme_alloc_shared_fxvector(argc), argc, argv);
}
#endif
static Scheme_Object *fxvector_p (int argc, Scheme_Object *argv[])
{
if (SCHEME_FXVECTORP(argv[0]))
return scheme_true;
else
return scheme_false;
}
static Scheme_Object *do_make_fxvector (const char *name, int as_shared, int argc, Scheme_Object *argv[])
{
Scheme_Vector *vec;
long size;
if (SCHEME_INTP(argv[0]))
size = SCHEME_INT_VAL(argv[0]);
else if (SCHEME_BIGNUMP(argv[0])) {
if (SCHEME_BIGPOS(argv[0])) {
scheme_raise_out_of_memory(name, NULL);
return NULL;
} else
size = -1;
} else
size = -1;
if (size < 0)
scheme_wrong_type(name, "exact non-negative integer", 0, argc, argv);
if (argc > 1) {
if (!SCHEME_INTP(argv[1]))
scheme_wrong_type(name, "fixnum", 1, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
if (as_shared)
vec = scheme_alloc_shared_fxvector(size);
else
#else
vec = scheme_alloc_fxvector(size);
#endif
{
int i;
Scheme_Object *val = ((argc > 1) ? argv[1] : scheme_make_integer(0));
for (i = 0; i < size; i++) {
vec->els[i] = val;
}
}
return (Scheme_Object *)vec;
}
static Scheme_Object *make_fxvector (int argc, Scheme_Object *argv[])
{
return do_make_fxvector("make-fxvector", 0, argc, argv);
}
#if defined(MZ_USE_PLACES) && defined(MZ_PRECISE_GC)
static Scheme_Object *make_shared_fxvector (int argc, Scheme_Object *argv[])
{
return do_make_fxvector("make-shared-fxvector", 1, argc, argv);
}
#endif
Scheme_Object *scheme_fxvector_length(Scheme_Object *vec)
{
if (!SCHEME_FXVECTORP(vec))
scheme_wrong_type("fxvector-length", "fxvector", 0, 1, &vec);
return scheme_make_integer(SCHEME_FXVEC_SIZE(vec));
}
static Scheme_Object *fxvector_length (int argc, Scheme_Object *argv[])
{
return scheme_fxvector_length(argv[0]);
}
Scheme_Object *scheme_checked_fxvector_ref (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec;
long len, pos;
vec = argv[0];
if (!SCHEME_FXVECTORP(vec))
scheme_wrong_type("fxvector-ref", "fxvector", 0, argc, argv);
len = SCHEME_FXVEC_SIZE(vec);
pos = scheme_extract_index("fxvector-ref", 1, argc, argv, len, 0);
if (pos >= len) {
scheme_bad_vec_index("fxvector-ref", argv[1],
"fxvector", vec,
0, len);
return NULL;
}
return SCHEME_FXVEC_ELS(vec)[pos];
}
Scheme_Object *scheme_checked_fxvector_set (int argc, Scheme_Object *argv[])
{
Scheme_Object *vec;
long len, pos;
vec = argv[0];
if (!SCHEME_FXVECTORP(vec))
scheme_wrong_type("fxvector-set!", "fxvector", 0, argc, argv);
len = SCHEME_FXVEC_SIZE(vec);
pos = scheme_extract_index("fxvector-set!", 1, argc, argv, len, 0);
if (!SCHEME_INTP(argv[2]))
scheme_wrong_type("fxvector-set!", "fixnum", 2, argc, argv);
if (pos >= len) {
scheme_bad_vec_index("fxvector-set!", argv[1],
"fxvector", vec,
0, len);
return NULL;
}
SCHEME_FXVEC_ELS(vec)[pos] = argv[2];
return scheme_void;
}
/************************************************************************/
/* Unsafe */
/************************************************************************/
@ -3560,6 +3795,63 @@ static Scheme_Object *unsafe_flvector_set (int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *unsafe_fxvector_length (int argc, Scheme_Object *argv[])
{
return scheme_make_integer(SCHEME_FXVEC_SIZE(argv[0]));
}
static Scheme_Object *unsafe_fxvector_ref (int argc, Scheme_Object *argv[])
{
long pos;
pos = SCHEME_INT_VAL(argv[1]);
return SCHEME_FXVEC_ELS(argv[0])[pos];
}
static Scheme_Object *unsafe_fxvector_set (int argc, Scheme_Object *argv[])
{
long pos;
pos = SCHEME_INT_VAL(argv[1]);
SCHEME_FXVEC_ELS(argv[0])[pos] = argv[2];
return scheme_void;
}
static Scheme_Object *s16_ref (int argc, Scheme_Object *argv[])
{
long v;
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
v = ((short *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
return scheme_make_integer(v);
}
static Scheme_Object *s16_set (int argc, Scheme_Object *argv[])
{
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
((short *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = (short)SCHEME_INT_VAL(argv[2]);
return scheme_void;
}
static Scheme_Object *u16_ref (int argc, Scheme_Object *argv[])
{
long v;
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
v = ((unsigned short *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])];
return scheme_make_integer(v);
}
static Scheme_Object *u16_set (int argc, Scheme_Object *argv[])
{
Scheme_Object *p;
p = ((Scheme_Structure *)argv[0])->slots[0];
((unsigned short *)SCHEME_CPTR_VAL(p))[SCHEME_INT_VAL(argv[1])] = (unsigned short)SCHEME_INT_VAL(argv[2]);
return scheme_void;
}
static Scheme_Object *integer_to_fl (int argc, Scheme_Object *argv[])
{
if (SCHEME_INTP(argv[0])

4
src/racket/src/schminc.h
View File

@ -14,8 +14,8 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 1011
#define EXPECTED_UNSAFE_COUNT 69
#define EXPECTED_FLFXNUM_COUNT 60
#define EXPECTED_UNSAFE_COUNT 76
#define EXPECTED_FLFXNUM_COUNT 68
#define EXPECTED_FUTURES_COUNT 5
#ifdef MZSCHEME_SOMETHING_OMITTED

6
src/racket/src/schpriv.h
View File

@ -386,6 +386,8 @@ extern Scheme_Object *scheme_input_port_property, *scheme_output_port_property;
extern Scheme_Object *scheme_equal_property;
extern Scheme_Object *scheme_proxy_of_property;
extern Scheme_Object *scheme_app_mark_proxy_property;
extern Scheme_Object *scheme_reduced_procedure_struct;
/*========================================================================*/
@ -3455,6 +3457,10 @@ Scheme_Double_Vector *scheme_alloc_flvector(long size);
Scheme_Object *scheme_checked_flvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_flvector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_flvector_length(Scheme_Object *v);
Scheme_Vector *scheme_alloc_fxvector(long size);
Scheme_Object *scheme_checked_fxvector_ref(int argc, Scheme_Object **argv);
Scheme_Object *scheme_checked_fxvector_set(int argc, Scheme_Object **argv);
Scheme_Object *scheme_fxvector_length(Scheme_Object *v);
Scheme_Object *scheme_checked_real_part (int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_checked_imag_part (int argc, Scheme_Object *argv[]);
Scheme_Object *scheme_checked_make_rectangular (int argc, Scheme_Object *argv[]);

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.0.1.6"
#define MZSCHEME_VERSION "5.0.1.7"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 0
#define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 6
#define MZSCHEME_VERSION_W 7
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

21
src/racket/src/struct.c
View File

@ -38,6 +38,7 @@ READ_ONLY Scheme_Object *scheme_current_inspector_proc;
READ_ONLY Scheme_Object *scheme_recur_symbol;
READ_ONLY Scheme_Object *scheme_display_symbol;
READ_ONLY Scheme_Object *scheme_write_special_symbol;
READ_ONLY Scheme_Object *scheme_app_mark_proxy_property;
READ_ONLY static Scheme_Object *location_struct;
READ_ONLY static Scheme_Object *write_property;
@ -170,6 +171,8 @@ static Scheme_Object *proxy_struct(int argc, Scheme_Object **argv);
static Scheme_Object *chaperone_struct_type(int argc, Scheme_Object **argv);
static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name);
#define PRE_REDIRECTS 2
#ifdef MZ_PRECISE_GC
@ -722,9 +725,13 @@ scheme_init_struct (Scheme_Env *env)
1, 1, 1),
env);
scheme_add_global_constant("proxy-prop:application-mark",
scheme_false,
env);
{
REGISTER_SO(scheme_app_mark_proxy_property);
scheme_app_mark_proxy_property = make_chaperone_property_from_c(scheme_intern_symbol("application-mark"));
scheme_add_global_constant("proxy-prop:application-mark",
scheme_app_mark_proxy_property,
env);
}
}
/*========================================================================*/
@ -1104,6 +1111,14 @@ static Scheme_Object *make_chaperone_property(int argc, Scheme_Object *argv[])
return scheme_values(3, a);
}
static Scheme_Object *make_chaperone_property_from_c(Scheme_Object *name)
{
Scheme_Object *a[3];
a[0] = name;
return make_struct_type_property_from_c(1, a, &a[1], &a[2], scheme_chaperone_property_type);
}
Scheme_Object *scheme_make_struct_type_property_w_guard(Scheme_Object *name, Scheme_Object *guard)
{
Scheme_Object *a[2];

151
src/racket/src/stypes.h
View File

@ -176,86 +176,87 @@ enum {
scheme_prune_context_type, /* 157 */
scheme_future_type, /* 158 */
scheme_flvector_type, /* 159 */
scheme_place_type, /* 160 */
scheme_place_async_channel_type, /* 161 */
scheme_place_bi_channel_type, /* 162 */
scheme_once_used_type, /* 163 */
scheme_serialized_symbol_type, /* 164 */
scheme_serialized_structure_type, /* 165 */
scheme_fxvector_type, /* 160 */
scheme_place_type, /* 161 */
scheme_place_async_channel_type, /* 162 */
scheme_place_bi_channel_type, /* 163 */
scheme_once_used_type, /* 164 */
scheme_serialized_symbol_type, /* 165 */
scheme_serialized_structure_type, /* 166 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 166 */
_scheme_last_normal_type_, /* 167 */
scheme_rt_weak_array, /* 167 */
scheme_rt_weak_array, /* 168 */
scheme_rt_comp_env, /* 168*/
scheme_rt_constant_binding, /* 169 */
scheme_rt_resolve_info, /* 170 */
scheme_rt_optimize_info, /* 171 */
scheme_rt_compile_info, /* 172 */
scheme_rt_cont_mark, /* 173 */
scheme_rt_saved_stack, /* 174 */
scheme_rt_reply_item, /* 175 */
scheme_rt_closure_info, /* 176 */
scheme_rt_overflow, /* 177 */
scheme_rt_overflow_jmp, /* 178 */
scheme_rt_meta_cont, /* 179 */
scheme_rt_dyn_wind_cell, /* 180 */
scheme_rt_dyn_wind_info, /* 181 */
scheme_rt_dyn_wind, /* 182 */
scheme_rt_dup_check, /* 183 */
scheme_rt_thread_memory, /* 184 */
scheme_rt_input_file, /* 185 */
scheme_rt_input_fd, /* 186 */
scheme_rt_oskit_console_input, /* 187 */
scheme_rt_tested_input_file, /* 188 */
scheme_rt_tested_output_file, /* 189 */
scheme_rt_indexed_string, /* 190 */
scheme_rt_output_file, /* 191 */
scheme_rt_load_handler_data, /* 192 */
scheme_rt_pipe, /* 193 */
scheme_rt_beos_process, /* 194 */
scheme_rt_system_child, /* 195 */
scheme_rt_tcp, /* 196 */
scheme_rt_write_data, /* 197 */
scheme_rt_tcp_select_info, /* 198 */
scheme_rt_param_data, /* 199 */
scheme_rt_will, /* 200 */
scheme_rt_struct_proc_info, /* 201 */
scheme_rt_linker_name, /* 202 */
scheme_rt_param_map, /* 203 */
scheme_rt_finalization, /* 204 */
scheme_rt_finalizations, /* 205 */
scheme_rt_cpp_object, /* 206 */
scheme_rt_cpp_array_object, /* 207 */
scheme_rt_stack_object, /* 208 */
scheme_rt_preallocated_object, /* 209 */
scheme_thread_hop_type, /* 210 */
scheme_rt_srcloc, /* 211 */
scheme_rt_evt, /* 212 */
scheme_rt_syncing, /* 213 */
scheme_rt_comp_prefix, /* 214 */
scheme_rt_user_input, /* 215 */
scheme_rt_user_output, /* 216 */
scheme_rt_compact_port, /* 217 */
scheme_rt_read_special_dw, /* 218 */
scheme_rt_regwork, /* 219 */
scheme_rt_buf_holder, /* 220 */
scheme_rt_parameterization, /* 221 */
scheme_rt_print_params, /* 222 */
scheme_rt_read_params, /* 223 */
scheme_rt_native_code, /* 224 */
scheme_rt_native_code_plus_case, /* 225 */
scheme_rt_jitter_data, /* 226 */
scheme_rt_module_exports, /* 227 */
scheme_rt_delay_load_info, /* 228 */
scheme_rt_marshal_info, /* 229 */
scheme_rt_unmarshal_info, /* 230 */
scheme_rt_runstack, /* 231 */
scheme_rt_sfs_info, /* 232 */
scheme_rt_validate_clearing, /* 233 */
scheme_rt_rb_node, /* 234 */
scheme_rt_frozen_tramp, /* 235 */
scheme_rt_constant_binding, /* 170 */
scheme_rt_resolve_info, /* 171 */
scheme_rt_optimize_info, /* 172 */
scheme_rt_compile_info, /* 173 */
scheme_rt_cont_mark, /* 174 */
scheme_rt_saved_stack, /* 175 */
scheme_rt_reply_item, /* 176 */
scheme_rt_closure_info, /* 177 */
scheme_rt_overflow, /* 178 */
scheme_rt_overflow_jmp, /* 179 */
scheme_rt_meta_cont, /* 180 */
scheme_rt_dyn_wind_cell, /* 181 */
scheme_rt_dyn_wind_info, /* 182 */
scheme_rt_dyn_wind, /* 183 */
scheme_rt_dup_check, /* 184 */
scheme_rt_thread_memory, /* 185 */
scheme_rt_input_file, /* 186 */
scheme_rt_input_fd, /* 187 */
scheme_rt_oskit_console_input, /* 188 */
scheme_rt_tested_input_file, /* 189 */
scheme_rt_tested_output_file, /* 190 */
scheme_rt_indexed_string, /* 191 */
scheme_rt_output_file, /* 192 */
scheme_rt_load_handler_data, /* 193 */
scheme_rt_pipe, /* 194 */
scheme_rt_beos_process, /* 195 */
scheme_rt_system_child, /* 196 */
scheme_rt_tcp, /* 197 */
scheme_rt_write_data, /* 198 */
scheme_rt_tcp_select_info, /* 199 */
scheme_rt_param_data, /* 200 */
scheme_rt_will, /* 201 */
scheme_rt_struct_proc_info, /* 202 */
scheme_rt_linker_name, /* 203 */
scheme_rt_param_map, /* 204 */
scheme_rt_finalization, /* 205 */
scheme_rt_finalizations, /* 206 */
scheme_rt_cpp_object, /* 207 */
scheme_rt_cpp_array_object, /* 208 */
scheme_rt_stack_object, /* 209 */
scheme_rt_preallocated_object, /* 210 */
scheme_thread_hop_type, /* 211 */
scheme_rt_srcloc, /* 212 */
scheme_rt_evt, /* 213 */
scheme_rt_syncing, /* 214 */
scheme_rt_comp_prefix, /* 215 */
scheme_rt_user_input, /* 216 */
scheme_rt_user_output, /* 217 */
scheme_rt_compact_port, /* 218 */
scheme_rt_read_special_dw, /* 219 */
scheme_rt_regwork, /* 220 */
scheme_rt_buf_holder, /* 221 */
scheme_rt_parameterization, /* 222 */
scheme_rt_print_params, /* 223 */
scheme_rt_read_params, /* 224 */
scheme_rt_native_code, /* 225 */
scheme_rt_native_code_plus_case, /* 226 */
scheme_rt_jitter_data, /* 227 */
scheme_rt_module_exports, /* 228 */
scheme_rt_delay_load_info, /* 229 */
scheme_rt_marshal_info, /* 230 */
scheme_rt_unmarshal_info, /* 231 */
scheme_rt_runstack, /* 232 */
scheme_rt_sfs_info, /* 233 */
scheme_rt_validate_clearing, /* 234 */
scheme_rt_rb_node, /* 235 */
scheme_rt_frozen_tramp, /* 236 */
#endif

2
src/racket/src/type.c
View File

@ -167,6 +167,7 @@ scheme_init_type ()
set_name(scheme_macro_type, "<macro>");
set_name(scheme_vector_type, "<vector>");
set_name(scheme_flvector_type, "<flvector>");
set_name(scheme_fxvector_type, "<fxvector>");
set_name(scheme_bignum_type, "<bignum-integer>");
set_name(scheme_escaping_cont_type, "<escape-continuation>");
set_name(scheme_sema_type, "<semaphore>");
@ -552,6 +553,7 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_raw_pair_type, cons_cell);
GC_REG_TRAV(scheme_vector_type, vector_obj);
GC_REG_TRAV(scheme_flvector_type, flvector_obj);
GC_REG_TRAV(scheme_fxvector_type, fxvector_obj);
GC_REG_TRAV(scheme_cpointer_type, cpointer_obj);
GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj);

2
src/worksp/gracket/gracket.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="5.0.1.6"
version="5.0.1.7"
processorArchitecture="X86"
name="Org.PLT-Scheme.GRacket"
type="win32"

8
src/worksp/gracket/gracket.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "gracket.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 5,0,1,6
PRODUCTVERSION 5,0,1,6
FILEVERSION 5,0,1,7
PRODUCTVERSION 5,0,1,7
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "Racket GUI application\0"
VALUE "InternalName", "GRacket\0"
VALUE "FileVersion", "5, 0, 1, 6\0"
VALUE "FileVersion", "5, 0, 1, 7\0"
VALUE "LegalCopyright", "Copyright © 1995-2010\0"
VALUE "OriginalFilename", "GRacket.exe\0"
VALUE "ProductName", "Racket\0"
VALUE "ProductVersion", "5, 0, 1, 6\0"
VALUE "ProductVersion", "5, 0, 1, 7\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 5,0,1,6
PRODUCTVERSION 5,0,1,6
FILEVERSION 5,0,1,7
PRODUCTVERSION 5,0,1,7
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "5, 0, 1, 6"
VALUE "FileVersion", "5, 0, 1, 7"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2010 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "5, 0, 1, 6"
VALUE "ProductVersion", "5, 0, 1, 7"
END
END
BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.5.0.1.6 = s 'MzObj Class'
MzCOM.MzObj.5.0.1.7 = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
}
MzCOM.MzObj = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.5.0.1.6'
CurVer = s 'MzCOM.MzObj.5.0.1.7'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.5.0.1.6'
ProgID = s 'MzCOM.MzObj.5.0.1.7'
VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

8
src/worksp/racket/racket.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "racket.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 5,0,1,6
PRODUCTVERSION 5,0,1,6
FILEVERSION 5,0,1,7
PRODUCTVERSION 5,0,1,7
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "Racket application\0"
VALUE "InternalName", "Racket\0"
VALUE "FileVersion", "5, 0, 1, 6\0"
VALUE "FileVersion", "5, 0, 1, 7\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2010\0"
VALUE "OriginalFilename", "racket.exe\0"
VALUE "ProductName", "Racket\0"
VALUE "ProductVersion", "5, 0, 1, 6\0"
VALUE "ProductVersion", "5, 0, 1, 7\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 5,0,1,6
PRODUCTVERSION 5,0,1,6
FILEVERSION 5,0,1,7
PRODUCTVERSION 5,0,1,7
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "Racket Launcher\0"
#endif
VALUE "FileVersion", "5, 0, 1, 6\0"
VALUE "FileVersion", "5, 0, 1, 7\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0"
#endif
VALUE "ProductName", "Racket\0"
VALUE "ProductVersion", "5, 0, 1, 6\0"
VALUE "ProductVersion", "5, 0, 1, 7\0"
END
END
BLOCK "VarFileInfo"