diff --git a/collects/r6rs/main.ss b/collects/r6rs/main.ss index a84637421d..34b821fda6 100644 --- a/collects/r6rs/main.ss +++ b/collects/r6rs/main.ss @@ -2,6 +2,7 @@ #| FIXME: + * Check that exported identifiers are defined in some phase. * Check that each identifier is imported only once across phases. |# diff --git a/collects/r6rs/private/conds.ss b/collects/r6rs/private/conds.ss new file mode 100644 index 0000000000..ba6416694b --- /dev/null +++ b/collects/r6rs/private/conds.ss @@ -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)) + diff --git a/collects/r6rs/private/io-conds.ss b/collects/r6rs/private/io-conds.ss new file mode 100644 index 0000000000..181ca7d32f --- /dev/null +++ b/collects/r6rs/private/io-conds.ss @@ -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))) diff --git a/collects/r6rs/private/readtable.ss b/collects/r6rs/private/readtable.ss index 753a5ededa..1615e6dab0 100644 --- a/collects/r6rs/private/readtable.ss +++ b/collects/r6rs/private/readtable.ss @@ -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) diff --git a/collects/r6rs/private/records-core.ss b/collects/r6rs/private/records-core.ss index 777b4edc15..a30ae39978 100644 --- a/collects/r6rs/private/records-core.ss +++ b/collects/r6rs/private/records-core.ss @@ -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)) diff --git a/collects/r6rs/private/records-explicit.ss b/collects/r6rs/private/records-explicit.ss index fab09c8c37..da13dd71c1 100644 --- a/collects/r6rs/private/records-explicit.ss +++ b/collects/r6rs/private/records-explicit.ss @@ -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) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index a08ed9d599..97cd501a00 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -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 diff --git a/collects/rnrs/conditions-6.ss b/collects/rnrs/conditions-6.ss new file mode 100644 index 0000000000..d661932339 --- /dev/null +++ b/collects/rnrs/conditions-6.ss @@ -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?) diff --git a/collects/rnrs/exceptions-6.ss b/collects/rnrs/exceptions-6.ss new file mode 100644 index 0000000000..99452ec68f --- /dev/null +++ b/collects/rnrs/exceptions-6.ss @@ -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))))) diff --git a/collects/rnrs/io/ports-6.ss b/collects/rnrs/io/ports-6.ss new file mode 100644 index 0000000000..30e9f897d5 --- /dev/null +++ b/collects/rnrs/io/ports-6.ss @@ -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))) + +;; ---------------------------------------- diff --git a/collects/rnrs/io/simple-6.ss b/collects/rnrs/io/simple-6.ss index a8ec3a44d0..513e784b6f 100644 --- a/collects/rnrs/io/simple-6.ss +++ b/collects/rnrs/io/simple-6.ss @@ -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]))) diff --git a/collects/rnrs/list-6.ss b/collects/rnrs/lists-6.ss similarity index 98% rename from collects/rnrs/list-6.ss rename to collects/rnrs/lists-6.ss index a34da61502..901698a08b 100644 --- a/collects/rnrs/list-6.ss +++ b/collects/rnrs/lists-6.ss @@ -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 diff --git a/collects/rnrs/mutable-pairs-6.ss b/collects/rnrs/mutable-pairs-6.ss new file mode 100644 index 0000000000..41af02ff1d --- /dev/null +++ b/collects/rnrs/mutable-pairs-6.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require scheme/mpair) + +(provide (rename-out [set-mcdr! set-cdr!] + [set-mcar! set-car!])) diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index 1b83f8b8a4..91c0819dcd 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -115,6 +115,9 @@ (make-precompiled-sort string (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)) diff --git a/collects/scribblings/reference/custom-ports.scrbl b/collects/scribblings/reference/custom-ports.scrbl index 7f8db36a07..cf2df8874c 100644 --- a/collects/scribblings/reference/custom-ports.scrbl +++ b/collects/scribblings/reference/custom-ports.scrbl @@ -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].} } diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index d9a6859013..91ca2765db 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -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 diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index fdbc5c8393..a484123ad4 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -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(); diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index d14bcb1aa4..5ccf06f79c 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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; diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 35b839e8f3..f6adb30869 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -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) */ diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 39724f32d7..caecb22e57 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -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; diff --git a/src/mzscheme/src/list.c b/src/mzscheme/src/list.c index 95a49dc3b4..a767f16ee0 100644 --- a/src/mzscheme/src/list.c +++ b/src/mzscheme/src/list.c @@ -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); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index ef19732c2d..55c228b046 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -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; diff --git a/src/mzscheme/src/strops.inc b/src/mzscheme/src/strops.inc index 74c668f7bb..a04eb5fb38 100644 --- a/src/mzscheme/src/strops.inc +++ b/src/mzscheme/src/strops.inc @@ -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; } diff --git a/src/mzscheme/src/symbol.c b/src/mzscheme/src/symbol.c index 2b9217e0bd..65b0d3adb7 100644 --- a/src/mzscheme/src/symbol.c +++ b/src/mzscheme/src/symbol.c @@ -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 * diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index fd337d4a07..205aa0a27e 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -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;