diff --git a/mats/record.ms b/mats/record.ms index 6fedd80bd..bb7708698 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -4099,6 +4099,9 @@ (define rtd2 (make-record-type-descriptor 'subtype rtd (get-subtype-uid) #f #f (cons 1 1))) (define val ',(read (open-string-input-port "#[#{subtype a3utgl1aoz8jzrg100-1} 0 1]"))) (record? val rtd))) + (let ([ip (open-input-string "#f")]) + ;; check that expand-primitives respects applicative order for record? + (eq? 'bailed (call/cc (lambda (k) (#3%record? (read ip) (k 'bailed)))))) ) (mat record-type-mismatch diff --git a/release_notes/release_notes.stex b/release_notes/release_notes.stex index 49f7fd4c3..be26fd325 100644 --- a/release_notes/release_notes.stex +++ b/release_notes/release_notes.stex @@ -2700,6 +2700,11 @@ in fasl files does not generally make sense. %----------------------------------------------------------------------------- \section{Bug Fixes}\label{section:bugfixes} +\subsection{Incorrect code for \scheme{record?} at optimize-level 3 (9.9.9)} + +At optimize-level 3, the \scheme{record?} predicate could short circuit without +evaluating the \var{rtd} expression. + \subsection{Incorrect result from \scheme{Sinteger64} on 32-bit platforms (9.6.4)} On 32-bit platforms, calling \scheme{Sinteger64} or \scheme{Sunsigned64} diff --git a/s/cpprim.ss b/s/cpprim.ss index c00dace8b..7af9cdc82 100644 --- a/s/cpprim.ss +++ b/s/cpprim.ss @@ -7831,7 +7831,7 @@ (vector-length (rtd-ancestry d)))] [else #f])]) ;; `t` is rtd of `e`, and it's used once - (define (compare-at-depth t known-depth) + (define (compare-at-depth e-rtd t known-depth) (cond [(eqv? known-depth (constant minimum-ancestry-vector-length)) ;; no need to check ancestry array length @@ -7865,16 +7865,16 @@ ,(%constant sfalse)))))))])) (cond [assume-record? - (compare-at-depth (%mref ,e ,(constant typed-object-type-disp)) known-depth)] + (compare-at-depth e-rtd (%mref ,e ,(constant typed-object-type-disp)) known-depth)] [else (let ([t (make-tmp 't)]) - (bind #t (e) + (bind #t (e e-rtd) ;; also bind e-rtd to maintain applicative order in case `and` short-circuits (build-and (%type-check mask-typed-object type-typed-object ,e) `(let ([,t ,(%mref ,e ,(constant typed-object-type-disp))]) ,(build-and (%type-check mask-record type-record ,t) - (compare-at-depth t known-depth))))))])))) + (compare-at-depth e-rtd t known-depth))))))])))) (define-inline 3 record? [(e) (build-record? e)] [(e e-rtd)