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

r6rs io work; compiler tweaks

Browse Source 
svn: r8805
This commit is contained in:
Matthew Flatt 2008-02-26 13:54:54 +00:00
parent ffc0643a55
commit 743db7529d
26 changed files with 1057 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/r6rs/main.ss
View File

@ -2,6 +2,7 @@
#|
FIXME:
* Check that exported identifiers are defined in some phase.
* Check that each identifier is imported only once across phases.
|#

8
collects/r6rs/private/conds.ss Normal file
View File

@ -0,0 +1,8 @@
#lang scheme
(provide (struct-out exn:fail:r6rs)
(struct-out exn:fail:contract:r6rs))
(define-struct (exn:fail:r6rs exn:fail) (who irritants))
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants))

57
collects/r6rs/private/io-conds.ss Normal file
View File

@ -0,0 +1,57 @@
#!r6rs
(library (r6rs private io-conds)
(export &i/o make-i/o-error i/o-error
&i/o-read make-i/o-read-error i/o-read-error?
&i/o-write make-i/o-write-error i/o-write-error?
&i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position
&i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename
&i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error?
&i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error?
&i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error?
&i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?
&i/o-port make-i/o-port-error i/o-port-error? i/o-error-port)
(import (rnrs base (6))
(rnrs conditions (6)))
(define-condition-type &i/o &error
make-i/o-error i/o-error?)
(define-condition-type &i/o-read &i/o
make-i/o-read-error i/o-read-error?)
(define-condition-type &i/o-write &i/o
make-i/o-write-error i/o-write-error?)
(define-condition-type &i/o-invalid-position &i/o
make-i/o-invalid-position-error
i/o-invalid-position-error?
(position i/o-error-position))
(define-condition-type &i/o-filename &i/o
make-i/o-filename-error i/o-filename-error?
(filename i/o-error-filename))
(define-condition-type &i/o-file-protection
&i/o-filename
make-i/o-file-protection-error
i/o-file-protection-error?)
(define-condition-type &i/o-file-is-read-only
&i/o-file-protection
make-i/o-file-is-read-only-error
i/o-file-is-read-only-error?)
(define-condition-type &i/o-file-already-exists
&i/o-filename
make-i/o-file-already-exists-error
i/o-file-already-exists-error?)
(define-condition-type &i/o-file-does-not-exist
&i/o-filename
make-i/o-file-does-not-exist-error
i/o-file-does-not-exist-error?)
(define-condition-type &i/o-port &i/o
make-i/o-port-error i/o-port-error?
(port i/o-error-port)))

11
collects/r6rs/private/readtable.ss
View File

@ -123,6 +123,7 @@
strs)])
#`(quote ((init-char rx result-char . str) ...))))]))])
(char-names
"nul"
"space"
"newline"
"alarm"
@ -250,7 +251,7 @@
[(#\v) #"\v"]
[(#\f) #"\f"]
[(#\\) #"\\"]
[(#\\) #"\""])
[(#\") #"\""])
(loop (cdar m)))]
[(eq? char #\x)
(let ([hm (regexp-match-positions #px"^[a-zA-Z0-9]*;"
@ -391,7 +392,7 @@
(define sign "(?:[+-]|)")
(define mantissa-width (or "" (seq "[|]" (+ digit-10))))
(define exponent-marker "[eEsSfFdDlL]")
(define suffix (or "" (seq exponent-marker sign digit-10)))
(define suffix (or "" (seq exponent-marker sign (+ digit-10))))
(define (prefix R) (or (seq (radix R) exactness)
(seq exactness (radix R))))
@ -429,7 +430,7 @@
(num 16)
(num 8)
(num 2)))
(values (pregexp (string-append "^" identifier "$"))
(pregexp (string-append "^" number "$")))))
@ -438,7 +439,9 @@
;; then make sure it's a number or identifier.
(let ([thing (bytes-append
(string->bytes/utf-8 prefix)
(car (or (regexp-match #px"^(?:\\\\x[0-9a-fA-F]+;|[^\\s\\[\\]()#\";,'`])*" port)
(car (or (if (string=? prefix "\\")
(regexp-match #px"^x[0-9a-fA-F]+;(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port)
(regexp-match #px"^(?:\\\\x[0-9a-fA-F]+;|[^\\\\\\s\\[\\]()#\";,'`])*" port))
'(#""))))])
(cond
[(regexp-match rx:number thing)

2
collects/r6rs/private/records-core.ss
View File

@ -40,7 +40,7 @@
record-field-mutable? record-type-generative?
record? record-rtd)
(import (rnrs base (6))
(rnrs list (6))
(rnrs lists (6))
(rnrs io simple (6)) ;; REMOVEME
(r6rs private vector-types))

15
collects/r6rs/private/records-explicit.ss
View File

@ -31,8 +31,9 @@
record-constructor-descriptor
fields mutable immutable parent protocol
sealed opaque nongenerative)
(import (rnrs base)
(rnrs records procedural))
(import (for (rnrs base) run expand)
(rnrs records procedural)
(for (rnrs syntax-case) expand))
(define-syntax define-aux
(syntax-rules ()
@ -222,9 +223,13 @@
(syntax-rules ()
((define-record-type-name ?name ?rtd ?constructor-descriptor)
(define-syntax ?name
(syntax-rules (descriptor constructor-descriptor)
((?name descriptor) ?rtd)
((?name constructor-descriptor) ?constructor-descriptor))))))
(make-variable-transformer
(lambda (stx)
(syntax-case stx (descriptor constructor-descriptor set!)
(?name (identifier? #'?name) #'?rtd)
((set! ?name . rest) (syntax-violation #f "cannot mutate record-type descriptor binding" stx #'name))
((?name descriptor) #'?rtd)
((?name constructor-descriptor) #'?constructor-descriptor))))))))
(define-syntax no-record-type
(syntax-rules (descriptor constructor-descriptor)

4
collects/rnrs/base-6.ss
View File

@ -3,6 +3,7 @@
(require (for-syntax scheme/base
r6rs/private/identifier-syntax)
r6rs/private/qq-gen
r6rs/private/conds
(prefix-in r5rs: r5rs)
(only-in r6rs/private/readtable rx:number)
scheme/bool)
@ -287,9 +288,6 @@
(make-mapper "vector" for/list map in-vector vector-length vector->list))
(define-struct (exn:fail:r6rs exn:fail) (who irritants))
(define-struct (exn:fail:contract:r6rs exn:fail:contract) (who irritants))
(define (r6rs:error who msg . irritants)
(raise
(make-exn:fail:r6rs

192
collects/rnrs/conditions-6.ss Normal file
View File

@ -0,0 +1,192 @@
#lang scheme/base
(require rnrs/records/syntactic-6
rnrs/records/procedural-6
r6rs/private/conds)
(provide &condition
condition?
condition
simple-conditions
condition-predicate
condition-accessor
define-condition-type
&message make-message-condition message-condition? condition-message
&warning make-warning warning?
&serious make-serious-condition serious-condition?
&error make-error error?
&violation make-violation violation?
&assertion make-assertion-violation assertion-violation?
&irritants make-irritants-condition irritants-condition? condition-irritants
&who make-who-condition who-condition? condition-who
&non-continuable make-non-continuable-violation non-continuable-violation?
&implementation-restriction make-implementation-restriction-violation implementation-restriction-violation?
&lexical make-lexical-violation lexical-violation?
&syntax make-syntax-violation syntax-violation? syntax-violation-form syntax-violation-subform
&undefined make-undefined-violation undefined-violation?)
(define-record-type &condition (fields))
(define-struct (compound-condition exn) (conditions))
(define-struct (compound-condition:fail exn:fail) (conditions))
(define-struct has-continuation-marks (marks))
(define (condition? v)
(or (&condition? v)
(compound-condition? v)
(compound-condition:fail? v)
(exn? v)))
(define (condition . conds)
(for-each (lambda (c)
(unless (condition? c)
(raise-type-error 'condition "condition" c)))
conds)
(let ([conditions
(make-compound-condition
(apply append
(map simple-conditions conds)))])
((if (ormap serious-condition? conditions)
make-compound-condition:fail
make-compound-condition)
(ormap (lambda (c)
(and (message-condition? c)
(condition-message c)))
conditions)
(or (ormap (lambda (c)
(and (has-continuation-marks? c)
(has-continuation-marks-marks c)))
conditions)
(current-continuation-marks))
conditions)))
(define (condition-predicate rtd)
(let ([pred (record-predicate rtd)])
(lambda (v)
(and (condition? v)
(ormap pred (simple-conditions v))))))
(define (condition-accessor rtd proc)
(let ([pred (record-predicate rtd)])
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'condition-accessor "procedure (arity 1)" proc))
(lambda (v)
(let ([v (ormap pred (simple-conditions v))])
(if v
(proc v)
(raise-type-error 'a-condition-accessor "specific kind of condition" v))))))
(define (simple-conditions c)
(cond
[(&condition? c) (list c)]
[(compound-condition? c)
(compound-condition-conditions c)]
[(compound-condition:fail? c)
(compound-condition:fail-conditions c)]
[(exn? c)
(append
(list
(make-message-condition (exn-message c))
(make-has-continuation-marks (exn-continuation-marks c)))
(if (exn:fail? c)
(list (make-error))
null)
(if (exn:fail:contract? c)
(list (make-assertion-violation))
null)
(if (exn:fail:r6rs? c)
(append
(if (exn:fail:r6rs-who c)
(list (make-who-condition (exn:fail:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:r6rs-irritants c))))
null)
(if (exn:fail:contract:r6rs? c)
(append
(if (exn:fail:contract:r6rs-who c)
(list (make-who-condition (exn:fail:contract:r6rs-who c)))
null)
(list (make-irritants-condition (exn:fail:contract:r6rs-irritants c))))
null)
(list (make-non-continuable-violation))
(if (exn:fail:unsupported? c)
(list (make-implementation-restriction-violation))
null)
(if (exn:fail:read? c)
(list (make-lexical-violation))
null)
(if (exn:fail:syntax? c)
(let ([forms (exn:fail:syntax-exprs c)])
(list (make-syntax-violation
(if (pair? forms)
(car forms)
#f)
(if (and (pair? forms)
(pair? (cdr forms)))
(cadr forms)
#f))))
null)
(if (exn:fail:contract:variable? c)
(make-undefined-violation)
null))]
[else (raise-type-error 'simple-conditions
"condition"
c)]))
(define-syntax-rule (define-condition-type type supertype
constructor predicate
field ...)
(define-record-type (type constructor predicate)
(fields (immutable . field) ...)
(parent supertype)))
(define-condition-type &message &condition
make-message-condition message-condition?
(message condition-message))
(define-condition-type &warning &condition
make-warning warning?)
(define-condition-type &serious &condition
make-serious-condition serious-condition?)
(define-condition-type &error &serious
make-error error?)
(define-condition-type &violation &serious
make-violation violation?)
(define-condition-type &assertion &violation
make-assertion-violation assertion-violation?)
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
(irritants condition-irritants))
(define-condition-type &who &condition
make-who-condition who-condition?
(who condition-who))
(define-condition-type &non-continuable &violation
make-non-continuable-violation
non-continuable-violation?)
(define-condition-type &implementation-restriction
&violation
make-implementation-restriction-violation
implementation-restriction-violation?)
(define-condition-type &lexical &violation
make-lexical-violation lexical-violation?)
(define-condition-type &syntax &violation
make-syntax-violation syntax-violation?
(form syntax-violation-form)
(subform syntax-violation-subform))
(define-condition-type &undefined &violation
make-undefined-violation undefined-violation?)

80
collects/rnrs/exceptions-6.ss Normal file
View File

@ -0,0 +1,80 @@
#lang scheme/base
(provide with-exception-handler
guard else =>
(rename-out [r6rs:raise raise])
raise-continuable)
(define-struct (exn:continuable exn:fail) (base continuation))
(define (with-exception-handler proc thunk)
(unless (and (procedure? proc)
(procedure-arity-includes? proc 1))
(raise-type-error 'with-exception-handler "procedure (arity 1)" proc))
(unless (and (procedure? thunk)
(procedure-arity-includes? thunk 0))
(raise-type-error 'with-exception-handler "procedure (arity 0)" thunk))
(call-with-exception-handler
(lambda (exn)
(let/ec esc
(call-with-exception-handler
(lambda (new-exn)
;; Chain to enclosing handler by returning:
(esc new-exn))
(lambda ()
(call-with-values (lambda () (proc (if (exn:continuable? exn)
(exn:continuable-base exn)
exn)))
(if (continuable? exn)
(lambda args
((continuable-continuation exn) (lambda () (apply values args))))
(lambda args
(error 'raise
"when handling a non-continuable exception, exception handler returned~a"
(if (null? args)
" (no values)"
(apply
string-append
":"
(let loop ([args args][n 10])
(cond
[(null? args) null]
[(zero? n)
(list " ...")]
[else
(cons (format " ~e" (car args))
(loop (cdr args) (sub1 n)))]))))))))))))
thunk))
(define (continuable? exn)
(or (exn:break? exn)
(exn:continuable? exn)))
(define (continuable-continuation exn)
(if (exn:break? exn)
(exn:break-continuation exn)
(exn:continuable-continuation exn)))
(define-syntax-rule (guard (id cond-clause ...) body0 body ...)
(with-handlers ([(lambda (x) #t)
(lambda (id)
(let ([id (if (exn:continuable? id)
(exn:continuable-base id)
id)])
(cond
cond-clause ...
[else (raise id)])))])
body0 body ...))
(define (r6rs:raise exn)
;; No barrier
(raise exn #t))
(define (raise-continuable exn)
((let/cc cont
(r6rs:raise
(make-exn:continuable
(if (exn? exn) (exn-message exn) "continuable exception")
(if (exn? exn) (exn-continuation-marks exn) (current-continuation-marks))
exn
cont)))))

453
collects/rnrs/io/ports-6.ss Normal file
View File

@ -0,0 +1,453 @@
#lang scheme/base
(require rnrs/enums-6
rnrs/conditions-6
r6rs/private/io-conds
scheme/port)
(provide (all-from-out r6rs/private/io-conds)
file-options
buffer-mode buffer-mode?
latin-1-codec utf-8-codec utf-16-codec
eol-style native-eol-style
&i/o-decoding make-i/o-decoding-error i/o-decoding-error?
&i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char
error-handling-mode
(rename-out [r6rs:make-transcoder make-transcoder])
transcoder-codec
transcoder-eol-style
transcoder-error-handling-mode
;bytevector->string
;string->bytevector
(rename-out [eof eof-object])
eof-object?
port?
port-transcoder
textual-port?
binary-port?
transcoded-port
port-has-port-position?
port-position
port-has-set-port-position!?
set-port-position!
close-port
call-with-port
input-port?
port-eof?
open-file-input-port
open-bytevector-input-port
open-string-input-port
standard-input-port
current-input-port
make-custom-binary-input-port
make-custom-textual-input-port)
;; ----------------------------------------
(define-enumeration -file-option (no-create no-fail no-truncate)
file-options)
(define-enumeration buffer-mode (none line block)
-buffer-modes)
(define (buffer-mode? m)
(enum-set-member? m (-buffer-modes none line block)))
(define-enumeration eol-style (lf cr crlf nel crnel ls)
-eol-styles)
(define-struct codec (enc))
(define latin-1 (make-codec "latin-1"))
(define utf-8 (make-codec "utf-8"))
(define utf-16 (make-codec "utf-16"))
(define (latin-1-codec) latin-1)
(define (utf-8-codec) utf-8)
(define (utf-16-codec) utf-16)
(define (native-eol-style)
(if (eq? (system-type) 'windows)
'crlf
'lf))
(define-condition-type &i/o-decoding &i/o-port
make-i/o-decoding-error i/o-decoding-error?)
(define-condition-type &i/o-encoding &i/o-port
make-i/o-encoding-error i/o-encoding-error?
(char i/o-encoding-error-char))
(define-enumeration error-handling-mode (ignore raise replace)
-handling-modes)
(define-struct transcoder (codec eol-style error-handling-mode))
(define (r6rs:make-transcoder codec
[eol-style (native-eol-style)]
[handling-mode 'replace])
(unless (codec? codec)
(raise-type-error 'make-transcoder "codec" codec))
(unless (enum-set-member? eol-style (-eol-styles lf cr crlf nel crnel ls))
(raise-type-error 'make-transcoder "'lf, 'cr, 'crlf, 'nel, 'crnel, or 'ls" eol-style))
(unless (enum-set-member? handling-mode (-handling-modes ignore raise replace))
(raise-type-error 'make-transcoder "'ignore, 'raise, or 'replace" eol-style))
(make-transcoder codec eol-style handling-mode))
(define (native-transcoder)
(make-transcoder utf-8))
;; ----------------------------------------
(define (make-disconnectable-input-port port)
(define disconnected? #f)
(define (check-disconnect)
(when disconnected?
(error 'read-byte "cannot read for transcoded binary port")))
(values
(make-input-port
(object-name port)
(lambda (bytes)
(check-disconnect)
(let ([n (read-bytes-avail!* bytes port)])
(if (eq? n 0)
port
n)))
(lambda (bytes skip evt)
(check-disconnect)
(let ([n (peek-bytes-avail! bytes skip evt port)])
(if (eq? n 0)
port
n)))
(lambda ()
(unless disconnected?
(close-input-port port)))
(and (port-provides-progress-evts? port)
(lambda ()
(check-disconnect)
(port-progress-evt port)))
(and (port-provides-progress-evts? port)
(lambda (k evt done)
(port-commit-peeked k evt done port)))
(lambda ()
(check-disconnect)
(port-next-location port))
(lambda ()
(check-disconnect)
(port-count-lines! port))
1
(case-lambda
[() (check-disconnect) (file-stream-buffer-mode port)]
[(mode) (check-disconnect) (file-stream-buffer-mode port mode)]))
(lambda ()
(set! disconnected? #t)
port)))
(define (make-disconnectable-output-port port)
(define disconnected? #f)
(define (check-disconnect)
(when disconnected?
(error 'read-byte "cannot read for transcoded binary port")))
(values
(make-output-port
(object-name port)
port
(lambda (bytes start end can-buffer/block? enable-breaks?)
(check-disconnect)
(cond
[enable-breaks?
(parameterize-break #t (write-bytes (subbytes start end) port))]
[can-buffer/block?
(write-bytes (subbytes start end) port)]
[else
(write-bytes-avail* (subbytes start end) port)]))
(lambda ()
(unless disconnected?
(close-output-port port)))
(and (port-writes-special? port)
(lambda (v can-buffer/block? enable-breaks?)
(check-disconnect)
(cond
[enable-breaks?
(parameterize-break #t (write-special v port))]
[can-buffer/block?
(write-special v port)]
[else
(write-special-avail* v port)])))
(and (port-writes-atomic? port)
(lambda (bytes start end)
(check-disconnect)
(write-bytes-avail-evt bytes port start end)))
(and (port-writes-special? port)
(port-writes-atomic? port)
(lambda (v)
(check-disconnect)
(write-special-evt v port)))
(lambda ()
(check-disconnect)
(port-next-location port))
(lambda ()
(check-disconnect)
(port-count-lines! port))
1
(case-lambda
[() (check-disconnect) (file-stream-buffer-mode port)]
[(mode) (check-disconnect) (file-stream-buffer-mode port mode)]))
(lambda ()
(set! disconnected? #t)
port)))
;; R6RS functions that generate binary ports wrap them with `binary-...-port'
;; structures, so that the binary ports can be "closed" by `transcoded-port'.
(define-struct binary-input-port (port disconnect get-pos set-pos!)
#:property prop:input-port 0)
(define-struct binary-output-port (port disconnect get-pos set-pos!)
#:property prop:output-port 0)
(define-struct (binary-input/output-port binary-input-port) (out-port out-disconnect)
#:property prop:output-port 0)
;; Textual ports are transcoded
(define-struct textual-input-port (port transcoder)
#:property prop:input-port 0)
(define-struct textual-output-port (port transcoder)
#:property prop:output-port 0)
(define-struct (textual-input/output-port textual-input-port) (out-port)
#:property prop:output-port 0)
(define (port-transcoder port)
(cond
[(textual-input-port? port) (textual-input-port-transcoder port)]
[(textual-output-port? port) (textual-output-port-transcoder port)]
[(input-port? port) #f]
[(output-port? port) #f]
[else (raise-type-error 'port-transcoder "port" port)]))
(define (textual-port? v)
(if (port? v)
(or (textual-input-port? v)
(textual-output-port? v))
(raise-type-error 'textual-port? "port" v)))
(define (binary-port? v)
(if (port? v)
(not (or (textual-input-port? v)
(textual-output-port? v)))
(raise-type-error 'binary-port? "port" v)))
(define (wrap-binary-input-port p get-pos set-pos!)
(let-values ([(p disconnect) (make-disconnectable-input-port p)])
(make-binary-input-port p disconnect get-pos set-pos!)))
(define (transcode-input p t)
(let ([p (if (binary-input-port? p)
((binary-input-port-disconnect p))
p)])
(reencode-input-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))
(define (transcode-output p t)
(let ([p (cond
[(binary-output-port? p)
((binary-output-port-disconnect p))]
[(binary-input/output-port? p)
((binary-input/output-port-out-disconnect p))]
[else p])])
(reencode-output-port p
(codec-enc (transcoder-codec t))
(case (transcoder-error-handling-mode t)
[(raise) #f]
[(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))
(define (transcoded-port p t)
(unless (and (port? p)
(binary-port? p))
(raise-type-error 'transcoded-port "binary port" p))
(unless (transcoder? t)
(raise-type-error 'transcoded-port "transcoder" t))
(cond
[(and (input-port? p) (output-port? p))
(make-textual-input/output-port (transcode-input p)
t
(transcode-output p))]
[(input-port? p)
(make-textual-input-port (transcode-input p t) t)]
[(output-port? p)
(make-textual-input-port (transcode-output p t) t)]))
(define (port-has-port-position? p)
(unless (port? p)
(raise-type-error 'port-has-port-position? "port" p))
(cond
[(binary-input-port? p)
(and (binary-input-port-get-pos p))]
[(binary-output-port? p)
(and (binary-output-port-get-pos p))]
[(textual-input-port? p)
(port-has-port-position? (textual-input-port-port p))]
[(textual-output-port? p)
(port-has-port-position? (textual-output-port-port p))]
[else #t]))
(define (port-position p)
(cond
[(binary-input-port? p)
((binary-input-port-get-pos p))]
[(binary-output-port? p)
((binary-output-port-get-pos p))]
[(textual-input-port? p)
(port-position (textual-input-port-port p))]
[(textual-output-port? p)
(port-position (textual-output-port-port p))]
[else (file-position p)]))
(define (port-has-set-port-position!? p)
(unless (port? p)
(raise-type-error 'port-has-port-set-position!? "port" p))
(cond
[(binary-input-port? p)
(and (binary-input-port-set-pos! p) #t)]
[(binary-output-port? p)
(and (binary-output-port-set-pos! p) #t)]
[(textual-input-port? p)
(port-has-set-port-position!? (textual-input-port-port p))]
[(textual-output-port? p)
(port-has-set-port-position!? (textual-output-port-port p))]
[else
;; FIXME
(or (file-stream-port? p)
#t)]))
(define (set-port-position! p pos)
(unless (and (port? p)
(port-has-set-port-position!? p))
(raise-type-error 'set-port-position! "port with settable position" p))
(cond
[(binary-input-port? p)
((binary-input-port-set-pos! p) pos)]
[(binary-output-port? p)
((binary-output-port-set-pos! p) pos)]
[(textual-input-port? p)
(set-port-position! (textual-input-port-port p) pos)]
[(textual-output-port? p)
(set-port-position! (textual-output-port-port p) pos)]
[else
(file-position p pos)]))
(define (call-with-port port proc)
(unless (port? port)
(raise-type-error 'call-with-port "port" port))
(begin0
(proc port)
(close-port port)))
(define (close-port port)
(when (input-port? port)
(close-input-port port))
(when (output-port? port)
(close-output-port port)))
;; ----------------------------------------
(define (port-eof? p)
(eof-object? (peek-byte p)))
(define (open-file-input-port filename
[options (file-options)]
[buffer-mode 'block]
[maybe-transcoder #f])
(unless (enum-set=? (enum-set-universe options)
(enum-set-universe (file-options)))
(raise-type-error 'open-file-input-port "file-options enum set" options))
(unless (enum-set-member? buffer-mode (-buffer-modes none line block))
(raise-type-error 'open-file-input-port "'none, 'line, or 'block" buffer-mode))
(when maybe-transcoder
(unless (transcoder? maybe-transcoder)
(raise-type-error 'open-file-input-port "transcoder or #f" maybe-transcoder)))
(let ([p (open-input-file filename)])
(file-stream-buffer-mode p buffer-mode)
(if maybe-transcoder
(transcoded-port p maybe-transcoder)
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define (open-bytevector-input-port bytes [maybe-transcoder #f])
(unless (bytes? bytes)
(raise-type-error 'open-bytevector-input-port "bytevector" bytes))
(when maybe-transcoder
(unless (transcoder? maybe-transcoder)
(raise-type-error 'open-bytevector-input-port "transcoder or #f" maybe-transcoder)))
(let ([p (open-input-bytes bytes)])
(if maybe-transcoder
(transcoded-port p maybe-transcoder)
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos))))))
(define (open-string-input-port str)
(unless (string? str)
(raise-type-error 'open-bytevector-input-port "string" str))
(transcoded-port (open-input-string str) utf-8))
(define standard-input-port
(let ([p (current-input-port)])
(wrap-binary-input-port p
(lambda () (file-position p))
(lambda (pos) (file-position p pos)))))
(define input-ports (make-hash-table 'weak))
(define (r6rs:current-input-port)
(let ([p (current-input-port)])
(cond
[(textual-port? p) p]
[(hash-table-get input-ports p #f)
=> ephemeron-value]
[else
(let ([p2 (transcoded-port p utf-8)])
(hash-table-put! input-ports p (make-ephemeron p p2))
p2)])))
(define (make-custom-binary-input-port id read! get-position set-position! close)
(let ([p (make-input-port/read-to-peek
id
(lambda (bytes)
(let ([v (read! bytes 0 (bytes-length bytes))])
(if (zero? v)
eof
v)))
#f
close)])
(wrap-binary-input-port p
get-position
set-position!)))
(define (make-custom-textual-input-port id read! get-position set-position! close)
(make-textual-input-port
(make-custom-binary-input-port
id
(let-values ([(in out) (make-pipe)])
(lambda (bstr offset len)
(let loop ()
(let ([n (read-bytes-avail! bstr in offset len)])
(if (zero? n)
(let ([str (make-string (bytes-length bstr))])
(let ([len (read! str 0 (bytes-length bstr))])
(if (zero? len)
eof
(begin
(write-string (substring str 0 len) out)
(loop)))))
n)))))
get-position
set-position!
close)))
;; ----------------------------------------

13
collects/rnrs/io/simple-6.ss
View File

@ -1,5 +1,7 @@
#lang scheme/base
(require r6rs/private/readtable)
(provide (rename-out [eof eof-object])
eof-object?
call-with-input-file
@ -17,8 +19,17 @@
close-output-port
read-char
peek-char
read
(rename-out [r6rs:read read])
write-char
newline
display
write)
(define (r6rs:read [in (current-input-port)])
(let loop ([v (with-r6rs-reader-parameters (lambda () (read in)))])
(cond
[(pair? v) (mcons (loop (car v))
(loop (cdr v)))]
[(vector? v) (list->vector
(map loop (vector->list v)))]
[else v])))

4
collects/rnrs/list-6.ss → collects/rnrs/lists-6.ss
View File

@ -235,6 +235,10 @@
p
(loop (cdr alist))))))))))
(define-assoc-like assoc equal?)
(define-assoc-like assq eq?)
(define-assoc-like assv eqv?)
(define (cons* obj . objs)
(if (null? objs)
obj

6
collects/rnrs/mutable-pairs-6.ss Normal file
View File

@ -0,0 +1,6 @@
#lang scheme/base
(require scheme/mpair)
(provide (rename-out [set-mcdr! set-cdr!]
[set-mcar! set-car!]))

3
collects/scheme/private/list.ss
View File

@ -115,6 +115,9 @@
(make-precompiled-sort string<?)
(make-precompiled-sort string-ci<?)
(make-precompiled-sort keyword<?)
(hash-table-put! sort-internals <= (hash-table-get sort-internals <))
(hash-table-put! sort-internals string<=? (hash-table-get sort-internals string<?))
(hash-table-put! sort-internals string-ci<=? (hash-table-get sort-internals string-ci<?))
(lambda (less? lst n)
((or (hash-table-get sort-internals less? #f)
(sort-internal* less?))

6
collects/scribble/manual.ss
View File

@ -1885,6 +1885,12 @@
(cond
[(string? i)
(cond
[(regexp-match #px"^(.*)_([a-zA-Z0-9]+)(.*)$" i)
=> (lambda (m)
(append (loop (cadr m))
(list (make-element 'subscript
(loop (caddr m))))
(loop (cadddr m))))]
[(regexp-match #px"^(.*)([()0-9{}\\[\\]])(.*)$" i)
=> (lambda (m)
(append (loop (cadr m))

12
collects/scribblings/reference/custom-ports.scrbl
View File

@ -217,7 +217,7 @@ The arguments implement the port as follows:
@item{a progress event produced by @scheme[get-progress-evt];}
@item{an event, @scheme[done], that is either a channel-put
@item{an event, @scheme[_done], that is either a channel-put
event, channel, semaphore, semaphore-peek event, always
event, or never event.}
@ -243,14 +243,14 @@ The arguments implement the port as follows:
or @math{k_p} items, whichever is smaller, and only if @math{k_p} is
positive.}
@item{It must never choose @scheme[done] in a synchronization
after the given progress event is ready, or after @scheme[done]
@item{It must never choose @scheme[_done] in a synchronization
after the given progress event is ready, or after @scheme[_done]
has been synchronized once.}
@item{It must not treat any data as read from the port unless
@scheme[done] is chosen in a synchronization.}
@scheme[_done] is chosen in a synchronization.}
@item{It must not block indefinitely if @scheme[done] is ready;
@item{It must not block indefinitely if @scheme[_done] is ready;
it must return soon after the read completes or soon after the
given progress event is ready, whichever is first.}
@ -717,7 +717,7 @@ procedures.
@item{a boolean; @scheme[#t] indicates that if the port blocks
for a write, then it should enable breaks while blocking (e.g.,
using @scheme[sync/enable-break]; this argument is always
using @scheme[sync/enable-break]); this argument is always
@scheme[#f] if the fourth argument is @scheme[#t].}
}

34
collects/scribblings/reference/exns.scrbl
View File

@ -25,15 +25,22 @@ particular required arity (e.g., @scheme[call-with-input-file],
@;------------------------------------------------------------------------
@section[#:tag "errorproc"]{Raising Exceptions}
@defproc[(raise [v any/c]) any]{
@defproc[(raise [v any/c][barrier? any/c #t]) any]{
Raises an exception, where @scheme[v] represents the exception being
raised. The @scheme[v] argument can be anything; it is passed to the
current @deftech{exception handler}. Breaks are disabled from the
time the exception is raised until the exception handler obtains
control, and the handler itself is @scheme[parameterize-break]ed to
disable breaks initially; see @secref["breakhandler"] for more
information on breaks.}
current @deftech{exception handler}.
If @scheme[barrier?] is true, then the call to the @tech{exception
handler} is protected by a @tech{continuation barrier}, so that
multiple returns/escapes are impossible. All exceptions raised by
@schememodname[scheme] functions effectively use @scheme[raise] with a
@scheme[#t] value for @scheme[barrier?].
Breaks are disabled from the time the exception is raised until the
exception handler obtains control, and the handler itself is
@scheme[parameterize-break]ed to disable breaks initially; see
@secref["breakhandler"] for more information on breaks.}
@defproc*[([(error [sym symbol?]) any]
@ -184,17 +191,18 @@ Installs @scheme[f] as the @tech{exception handler} for the
is raised during the evaluation of @scheme[thunk] (in an extension of
the current continuation that does not have its own exception
handler), then @scheme[f] is applied to the @scheme[raise]d value in
the continuation of the @scheme[raise] call (but extended with a
@tech{continuation barrier}; see @secref["prompt-model"]).
the continuation of the @scheme[raise] call (but normally extended
with a @tech{continuation barrier}; see @secref["prompt-model"] and
@scheme[raise]).
Any procedure that takes one argument can be an exception handler. If
the exception handler returns a value when invoked by @scheme[raise],
then @scheme[raise] propagates the value to the ``previous'' exception
handler (still in the dynamic extent of the call to
@scheme[raise]). The previous exception handler is the exception
handler associated with the rest of the continuation after the point
where the called exception handler was associated with the
continuation; if no previous handler is available, the
handler (still in the dynamic extent of the call to @scheme[raise],
and under the same barrier, if any). The previous exception handler is
the exception handler associated with the rest of the continuation
after the point where the called exception handler was associated with
the continuation; if no previous handler is available, the
uncaught-exception handler is used (see below). In all cases, a call
to an exception handler is @scheme[parameterize-break]ed to disable
breaks, and it is wrapped with @scheme[call-with-exception-handler] to

162
src/mzscheme/src/error.c
View File

@ -64,7 +64,7 @@ static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug);
static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug, int barrier);
static Scheme_Object *nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
@ -492,9 +492,9 @@ void scheme_init_error(Scheme_Env *env)
REGISTER_SO(scheme_raise_arity_error_proc);
scheme_add_global_constant("error",
scheme_make_prim_w_arity(error,
"error",
1, -1),
scheme_make_noncm_prim(error,
"error",
1, -1),
env);
scheme_add_global_constant("raise-user-error",
scheme_make_prim_w_arity(raise_user_error,
@ -1967,7 +1967,8 @@ static Scheme_Object *do_error(int for_user, int argc, Scheme_Object *argv[])
newargs[1] = TMP_CMARK_VALUE;
do_raise(scheme_make_struct_instance(exn_table[for_user ? MZEXN_FAIL_USER : MZEXN_FAIL].type,
2, newargs),
1);
1,
1);
return scheme_void;
#else
@ -2516,7 +2517,8 @@ scheme_raise_exn(int id, ...)
do_raise(scheme_make_struct_instance(exn_table[id].type,
c, eargs),
1);
1,
1);
#else
call_error(buffer, alen, scheme_false);
#endif
@ -2618,96 +2620,116 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
return scheme_void;
}
static Scheme_Object *
do_raise(Scheme_Object *arg, int need_debug)
static void *do_raise_inside_barrier(void)
{
Scheme_Object *arg;
Scheme_Object *v, *p[1], *h, *marks;
Scheme_Cont_Mark_Chain *chain;
Scheme_Cont_Frame_Data cframe, cframe2;
int got_chain;
if (scheme_current_thread->skip_error) {
scheme_longjmp (scheme_error_buf, 1);
}
arg = scheme_current_thread->ku.k.p1;
scheme_current_thread->ku.k.p1 = NULL;
if (need_debug) {
marks = scheme_current_continuation_marks(NULL);
((Scheme_Structure *)arg)->slots[1] = marks;
}
h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
chain = NULL;
got_chain = 0;
chain = NULL;
got_chain = 0;
while (1) {
if (!h) {
h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
chain = NULL;
got_chain = 1;
}
while (1) {
if (!h) {
h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
chain = NULL;
got_chain = 1;
}
v = scheme_make_byte_string_without_copying("exception handler");
v = scheme_make_closed_prim_w_arity(nested_exn_handler,
scheme_make_pair(v, arg),
"nested-exception-handler",
1, 1);
v = scheme_make_byte_string_without_copying("exception handler");
v = scheme_make_closed_prim_w_arity(nested_exn_handler,
scheme_make_pair(v, arg),
"nested-exception-handler",
1, 1);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
p[0] = arg;
v = _scheme_apply(h, 1, p);
p[0] = arg;
v = scheme_apply(h, 1, p);
scheme_pop_break_enable(&cframe2, 0);
scheme_pop_continuation_frame(&cframe);
scheme_pop_break_enable(&cframe2, 0);
scheme_pop_continuation_frame(&cframe);
/* Getting a value back means that we should chain to the
next exception handler; we supply the returned value to
the next exception handler (if any). */
if (!got_chain) {
marks = scheme_all_current_continuation_marks();
chain = ((Scheme_Cont_Mark_Set *)marks)->chain;
marks = NULL;
/* Init chain to position of the handler we just
called. */
while (chain->key != scheme_exn_handler_key) {
chain = chain->next;
}
got_chain = 1;
}
/* Getting a value back means that we should chain to the
next exception handler; we supply the returned value to
the next exception handler (if any). */
if (!got_chain) {
marks = scheme_all_current_continuation_marks();
chain = ((Scheme_Cont_Mark_Set *)marks)->chain;
marks = NULL;
/* Init chain to position of the handler we just
called. */
while (chain->key != scheme_exn_handler_key) {
chain = chain->next;
}
got_chain = 1;
}
if (chain) {
chain = chain->next;
while (chain && (chain->key != scheme_exn_handler_key)) {
chain = chain->next;
}
if (chain) {
chain = chain->next;
while (chain && (chain->key != scheme_exn_handler_key)) {
chain = chain->next;
}
if (!chain)
h = NULL; /* use uncaught handler */
else
h = chain->val;
arg = v;
} else {
/* return from uncaught-exception handler */
p[0] = scheme_false;
return nested_exn_handler(scheme_make_pair(scheme_false, arg), 1, p);
}
}
if (!chain)
h = NULL; /* use uncaught handler */
else
h = chain->val;
arg = v;
} else {
/* return from uncaught-exception handler */
p[0] = scheme_false;
return nested_exn_handler(scheme_make_pair(scheme_false, arg), 1, p);
}
}
return scheme_void;
}
return scheme_void;
static Scheme_Object *
do_raise(Scheme_Object *arg, int need_debug, int eb)
{
Scheme_Thread *p = scheme_current_thread;
if (p->skip_error) {
scheme_longjmp (scheme_error_buf, 1);
}
if (need_debug) {
Scheme_Object *marks;
marks = scheme_current_continuation_marks(NULL);
((Scheme_Structure *)arg)->slots[1] = marks;
}
p->ku.k.p1 = arg;
if (eb)
return (Scheme_Object *)scheme_top_level_do(do_raise_inside_barrier, 1);
else
return (Scheme_Object *)do_raise_inside_barrier();
}
static Scheme_Object *
sch_raise(int argc, Scheme_Object *argv[])
{
return do_raise(argv[0], 0);
if ((argc > 1) && SCHEME_FALSEP(argv[1]))
return do_raise(argv[0], 0, 0);
else
return do_raise(argv[0], 0, 1);
}
void scheme_raise(Scheme_Object *exn)
{
do_raise(exn, 0);
do_raise(exn, 0, 1);
}
typedef Scheme_Object (*Scheme_Struct_Field_Guard_Proc)(int argc, Scheme_Object *v);
@ -2892,7 +2914,7 @@ void scheme_init_exn(Scheme_Env *env)
scheme_add_global_constant("raise",
scheme_make_prim_w_arity(sch_raise,
"raise",
1, 1),
1, 2),
env);
scheme_init_exn_config();

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

@ -2276,7 +2276,7 @@ Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int a
if (le && SCHEME_PRIMP(le)) {
int opt;
opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK;
if (opt > SCHEME_PRIM_OPT_NONCM)
if (opt >= SCHEME_PRIM_OPT_NONCM)
*_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT);
}
@ -2711,13 +2711,25 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info)
tb = scheme_optimize_expr(tb, info);
if (!info->preserves_marks) preserves_marks = 0;
if (!info->single_result) single_result = 0;
if (!info->preserves_marks)
preserves_marks = 0;
else if (info->preserves_marks < 0)
preserves_marks = -1;
if (!info->single_result)
single_result = 0;
else if (info->single_result < 0)
single_result = -1;
fb = scheme_optimize_expr(fb, info);
if (!info->preserves_marks) preserves_marks = 0;
if (!info->single_result) single_result = 0;
if (!info->preserves_marks)
preserves_marks = 0;
else if (preserves_marks && (info->preserves_marks < 0))
preserves_marks = -1;
if (!info->single_result)
single_result = 0;
else if (single_result && (info->single_result < 0))
single_result = -1;
info->preserves_marks = preserves_marks;
info->single_result = single_result;

16
src/mzscheme/src/fun.c
View File

@ -235,14 +235,14 @@ scheme_init_fun (Scheme_Env *env)
0, -1),
env);
scheme_add_global_constant("map",
scheme_make_prim_w_arity(map,
"map",
2, -1),
scheme_make_noncm_prim(map,
"map",
2, -1),
env);
scheme_add_global_constant("for-each",
scheme_make_prim_w_arity(for_each,
"for-each",
2, -1),
scheme_make_noncm_prim(for_each,
"for-each",
2, -1),
env);
scheme_add_global_constant("andmap",
scheme_make_prim_w_arity(andmap,
@ -971,6 +971,10 @@ scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info)
else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS)
SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_PRESERVES_MARKS;
if ((info->single_result > 0) && (info->preserves_marks > 0)
&& (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE))
SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_RESULT_TENTATIVE;
data->code = code;
/* Remembers positions of used vars (and unsets usage for this level) */

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

@ -4555,6 +4555,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi
if (is_simple(obj, INIT_SIMPLE_DEPTH, 1, jitter, 0)) {
need_ends = 0;
} else {
LOG_IT(("non-tail\n"));
if (mark_pos_ends)
generate_non_tail_mark_pos_prefix(jitter);
jit_ldi_p(JIT_R2, &scheme_current_cont_mark_stack);
@ -6752,9 +6753,10 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data)
}
}
LOG_IT(("PROC: %s, %d args\n",
LOG_IT(("PROC: %s, %d args, flags: %x\n",
(data->name ? scheme_format_utf8("~s", 2, 1, &data->name, NULL) : "???"),
data->num_params));
data->num_params,
SCHEME_CLOSURE_DATA_FLAGS(data)));
FOR_LOG(jitter->log_depth++);
jitter->self_data = data;

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

@ -139,7 +139,7 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("mpair?", p, env);
p = scheme_make_prim_w_arity(cons_prim, "cons", 2, 2);
p = scheme_make_noncm_prim(cons_prim, "cons", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("cons", p, env);
@ -151,7 +151,7 @@ scheme_init_list (Scheme_Env *env)
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
scheme_add_global_constant ("cdr", p, env);
p = scheme_make_prim_w_arity(mcons_prim, "mcons", 2, 2);
p = scheme_make_noncm_prim(mcons_prim, "mcons", 2, 2);
SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
scheme_add_global_constant ("mcons", p, env);

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

@ -4324,7 +4324,8 @@ static void module_validate(Scheme_Object *data, Mz_CPort *port,
}
static int set_code_closure_flags(Scheme_Object *clones,
int set_flags, int mask_flags)
int set_flags, int mask_flags,
int just_tentative)
{
Scheme_Object *clone, *orig, *first;
Scheme_Closure_Data *data;
@ -4341,10 +4342,12 @@ static int set_code_closure_flags(Scheme_Object *clones,
orig = SCHEME_CDR(first);
data = (Scheme_Closure_Data *)orig;
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)clone;
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)clone;
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
}
clones = SCHEME_CDR(clones);
}
@ -4479,7 +4482,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
if any turn out not (i.e., approximate fix point). */
(void)set_code_closure_flags(cl_first,
CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE,
0xFFFF);
0xFFFF,
0);
while (1) {
/* Re-optimize this expression. We can optimize anything without
@ -4492,10 +4496,11 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
start_simltaneous++;
}
flags = set_code_closure_flags(cl_first, 0, 0xFFFF);
flags = set_code_closure_flags(cl_first, 0, 0xFFFF, 0);
(void)set_code_closure_flags(cl_first,
(flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)),
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE));
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE),
1);
}
cl_last = cl_first = NULL;

5
src/mzscheme/src/strops.inc
View File

@ -73,7 +73,10 @@ X(scheme_alloc, _string)(int size, Xchar fill)
str = scheme_alloc_object();
str->type = scheme_x_string_type;
s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1));
if (size < 100)
s = (Xchar *)scheme_malloc_atomic(sizeof(Xchar)*(size + 1));
else
s = (Xchar *)scheme_malloc_fail_ok(scheme_malloc_atomic, sizeof(Xchar)*(size + 1));
for (i = size; i--; ) {
s[i] = fill;
}

34
src/mzscheme/src/symbol.c
View File

@ -675,12 +675,38 @@ string_to_uninterned_symbol_prim (int argc, Scheme_Object *argv[])
static Scheme_Object *
symbol_to_string_prim (int argc, Scheme_Object *argv[])
{
if (!SCHEME_SYMBOLP(argv[0]))
Scheme_Object *sym, *str;
GC_CAN_IGNORE unsigned char *s;
GC_CAN_IGNORE mzchar *s2;
long len, i;
sym = argv[0];
if (!SCHEME_SYMBOLP(sym))
scheme_wrong_type("symbol->string", "symbol", 0, argc, argv);
return scheme_make_sized_offset_utf8_string((char *)(argv[0]),
SCHEME_SYMSTR_OFFSET(argv[0]),
SCHEME_SYM_LEN(argv[0]));
s = (unsigned char *)SCHEME_SYM_VAL(sym);
len = SCHEME_SYM_LEN(sym);
for (i = 0; i < len; i++) {
if (s[i] >= 128)
break;
}
s = NULL;
if (i == len) {
/* ASCII */
str = scheme_alloc_char_string(len, 0);
s = (unsigned char *)SCHEME_SYM_VAL(sym);
s2 = SCHEME_CHAR_STR_VAL(str);
for (i = 0; i < len; i++) {
s2[i] = s[i];
}
return str;
} else {
return scheme_make_sized_offset_utf8_string((char *)sym,
SCHEME_SYMSTR_OFFSET(sym),
SCHEME_SYM_LEN(sym));
}
}
static Scheme_Object *

29
src/mzscheme/src/syntax.c
View File

@ -2861,7 +2861,7 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start,
static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
Scheme_Compiled_Let_Value *pre_body,
Scheme_Object *clones,
int set_flags, int mask_flags)
int set_flags, int mask_flags, int just_tentative)
{
Scheme_Compiled_Let_Value *clv;
Scheme_Object *value, *first;
@ -2879,14 +2879,17 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start,
if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) {
data = (Scheme_Closure_Data *)value;
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
first = SCHEME_CAR(clones);
data = (Scheme_Closure_Data *)SCHEME_CDR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)SCHEME_CAR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) {
flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data));
first = SCHEME_CAR(clones);
data = (Scheme_Closure_Data *)SCHEME_CDR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
data = (Scheme_Closure_Data *)SCHEME_CAR(first);
SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags);
}
clones = SCHEME_CDR(clones);
}
@ -3094,7 +3097,8 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
clones = make_clones(retry_start, pre_body, body_info);
(void)set_code_flags(retry_start, pre_body, clones,
CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE,
0xFFFF);
0xFFFF,
0);
/* Re-optimize loop: */
clv = retry_start;
cl = clones;
@ -3146,11 +3150,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
clv = (Scheme_Compiled_Let_Value *)clv->body;
}
/* Check flags loop: */
flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF);
flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0);
/* Reset-flags loop: */
(void)set_code_flags(retry_start, pre_body, clones,
(flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)),
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE));
~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE),
1);
}
retry_start = NULL;
did_set_value = 0;