9228 lines
370 KiB
Scheme
9228 lines
370 KiB
Scheme
|
;;; record.ms
|
||
|
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
(define $mpf32 (min (most-positive-fixnum) (- (ash 1 29) 1)))
|
||
|
|
(define $mnf32 (max (most-negative-fixnum) (- (ash 1 29))))
|
||
|
|
|
||
|
|
(define $mpf64 (min (most-positive-fixnum) (- (ash 1 60) 1)))
|
||
|
|
(define $mnf64 (max (most-negative-fixnum) (- (ash 1 60))))
|
||
|
|
|
||
|
|
(mat record1
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((immutable double-float a)))
|
||
|
|
(andmap procedure? (list make-fudge fudge? fudge-a)))
|
||
|
|
(error? (make-fudge 3))
|
||
|
|
(error? (fudge-a 3))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record2
|
||
|
|
(begin
|
||
|
|
(define fudge (make-record-type "fudge" '((immutable double-float a))))
|
||
|
|
(record-type-descriptor? fudge))
|
||
|
|
(begin
|
||
|
|
(define make-fudge (record-constructor fudge))
|
||
|
|
(procedure? make-fudge))
|
||
|
|
(error? (make-fudge 3))
|
||
|
|
(error? ((csv7:record-field-accessor fudge 'a) 3))
|
||
|
|
(error? (make-record-type "fudge" '((immutable double-float a) . b)))
|
||
|
|
(error? (make-record-type "fudge"
|
||
|
|
(let ([x (list '(immutable a) '(immutable b) '(immutable c))])
|
||
|
|
(set-cdr! (cddr x) (cdr x))
|
||
|
|
x)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat type-descriptor
|
||
|
|
(let ()
|
||
|
|
(define-record foo ())
|
||
|
|
(record-type-descriptor? (type-descriptor foo)))
|
||
|
|
(error? (type-descriptor 3))
|
||
|
|
(error? (type-descriptor car))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record3
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((immutable a)))
|
||
|
|
(andmap procedure? (list make-fudge fudge? fudge-a)))
|
||
|
|
(begin
|
||
|
|
(define x (make-fudge 3))
|
||
|
|
(fudge? x))
|
||
|
|
(eqv? (fudge-a x) 3)
|
||
|
|
(error? (set-fudge-a! x x))
|
||
|
|
(eqv? (fudge-a x) 3)
|
||
|
|
(let ()
|
||
|
|
(define-record fudge ((immutable a)))
|
||
|
|
(and (andmap procedure? (list make-fudge fudge? fudge-a))
|
||
|
|
(let ((x (make-fudge 3)))
|
||
|
|
(and (fudge? x)
|
||
|
|
(eqv? (fudge-a x) 3)
|
||
|
|
(eqv? (fudge-a x) 3)))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record4
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((a)))
|
||
|
|
(andmap procedure? (list make-fudge fudge? fudge-a set-fudge-a!)))
|
||
|
|
(begin
|
||
|
|
(define x (make-fudge 3))
|
||
|
|
(fudge? x))
|
||
|
|
(eqv? (fudge-a x) 3)
|
||
|
|
(error? (set-fudge-a! 3 x))
|
||
|
|
(begin (set-fudge-a! x x) (eqv? (fudge-a x) x))
|
||
|
|
#;(equal? (format "~s" x) "#0=#[fudge #0#]")
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((mutable a)))
|
||
|
|
(andmap procedure? (list make-fudge fudge? fudge-a set-fudge-a!)))
|
||
|
|
(begin
|
||
|
|
(define x (make-fudge 3))
|
||
|
|
(fudge? x))
|
||
|
|
(eqv? (fudge-a x) 3)
|
||
|
|
(begin (set-fudge-a! x x) (eqv? (fudge-a x) x))
|
||
|
|
#;(equal? (format "~s" x) "#0=#[fudge #0#]")
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record5
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((mutable a) (mutable double-float b)))
|
||
|
|
(andmap procedure?
|
||
|
|
(list make-fudge fudge? fudge-a set-fudge-a! fudge-b set-fudge-b!)))
|
||
|
|
(begin
|
||
|
|
(define x (make-fudge 'a 3.4))
|
||
|
|
(fudge? x))
|
||
|
|
(eqv? (begin (set-fudge-b! x 4.4) (fudge-b x)) 4.4)
|
||
|
|
#;(equal? (format "~s" x) "#[fudge a 4.4]")
|
||
|
|
(begin
|
||
|
|
(collect (collect-maximum-generation))
|
||
|
|
(set-fudge-a! x (cons 3 4))
|
||
|
|
(let ((p (weak-cons (fudge-a x) #f)))
|
||
|
|
(collect)
|
||
|
|
(and (eq? (car p) (fudge-a x))
|
||
|
|
(begin (collect)
|
||
|
|
(eq? (car p) (fudge-a x))
|
||
|
|
(equal? (car p) '(3 . 4))))))
|
||
|
|
(error? (set-fudge-b! x 4))
|
||
|
|
(begin
|
||
|
|
(define-record fudge ((a) (double-float b)))
|
||
|
|
(andmap procedure?
|
||
|
|
(list make-fudge fudge? fudge-a set-fudge-a! fudge-b set-fudge-b!)))
|
||
|
|
(begin
|
||
|
|
(define x (make-fudge 'a 3.4))
|
||
|
|
(fudge? x))
|
||
|
|
(eqv? (begin (set-fudge-b! x 4.4) (fudge-b x)) 4.4)
|
||
|
|
#;(equal? (format "~s" x) "#[fudge a 4.4]")
|
||
|
|
(begin
|
||
|
|
(collect (collect-maximum-generation))
|
||
|
|
(set-fudge-a! x (cons 3 4))
|
||
|
|
(let ((p (weak-cons (fudge-a x) #f)))
|
||
|
|
(collect)
|
||
|
|
(and (eq? (car p) (fudge-a x))
|
||
|
|
(begin (collect)
|
||
|
|
(eq? (car p) (fudge-a x))
|
||
|
|
(equal? (car p) '(3 . 4))))))
|
||
|
|
(error? (set-fudge-b! x 4))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record6
|
||
|
|
(begin
|
||
|
|
(define-record bar ((immutable a) (immutable integer-32 b))
|
||
|
|
(((immutable c) (+ a b)) ((immutable double-float d) (+ a b c))))
|
||
|
|
(andmap procedure? (list make-bar bar? bar-a bar-b bar-c bar-d)))
|
||
|
|
(begin
|
||
|
|
(define x (make-bar 9.0 23))
|
||
|
|
(and (bar? x)
|
||
|
|
#;(equal? (format "~s" x) "#[bar 9.0 23 32.0 64.0]")))
|
||
|
|
(eqv? (bar-d x) 64.0)
|
||
|
|
(eqv? (bar-b x) 23)
|
||
|
|
(let ((y (make-bar 9.0 $mpf32)))
|
||
|
|
(eqv? (bar-b y) $mpf32))
|
||
|
|
(let ((y (make-bar 9.0 (+ $mpf32 1))))
|
||
|
|
(eqv? (bar-b y) (+ $mpf32 1)))
|
||
|
|
(let ((y (make-bar 9.0 $mnf32)))
|
||
|
|
(eqv? (bar-b y) $mnf32))
|
||
|
|
(let ((y (make-bar 9.0 (- $mnf32 1))))
|
||
|
|
(eqv? (bar-b y) (- $mnf32 1)))
|
||
|
|
(let ((y (make-bar 9.0 #x7fffffff)))
|
||
|
|
(eqv? (bar-b y) #x7fffffff))
|
||
|
|
(let ((y (make-bar 9.0 #x-80000000)))
|
||
|
|
(eqv? (bar-b y) #x-80000000))
|
||
|
|
(error? (make-bar 9.0 #x100000000))
|
||
|
|
(error? (make-bar 9.0 #x-80000001))
|
||
|
|
(error? (make-bar 9.0 23.0))
|
||
|
|
; now that we allow 2^(b-1)..2^b-1
|
||
|
|
(let ((y (make-bar 9.0 #x80000000)))
|
||
|
|
(eqv? (bar-b y) #x-80000000))
|
||
|
|
(let ((y (make-bar 9.0 #xffffffff)))
|
||
|
|
(eqv? (bar-b y) #x-1))
|
||
|
|
|
||
|
|
; make sure we can use modifiers and types as field names
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record foo ((mutable mutable) (immutable int) (immutable integer-32) integer-8))
|
||
|
|
(let ([x (make-foo 3 4 5 6)])
|
||
|
|
(set-foo-mutable! x 75)
|
||
|
|
(list ($record->vector x) (foo-mutable x) (foo-int x) (foo-integer-32 x) (foo-integer-8 x))))
|
||
|
|
'(#(foo 75 4 5 6) 75 4 5 6))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define foo (make-record-type "hello" '((mutable mutable) (immutable int) (immutable integer-32) integer-8)))
|
||
|
|
(let ([x ((record-constructor foo) 3 4 5 6)])
|
||
|
|
((csv7:record-field-mutator foo 'mutable) x 75)
|
||
|
|
(list ($record->vector x)
|
||
|
|
((csv7:record-field-accessor foo 'mutable) x)
|
||
|
|
((csv7:record-field-accessor foo 'int) x)
|
||
|
|
((csv7:record-field-accessor foo 'integer-32) x)
|
||
|
|
((csv7:record-field-accessor foo 'integer-8) x))))
|
||
|
|
'(#(hello 75 4 5 6) 75 4 5 6))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record7
|
||
|
|
(begin
|
||
|
|
(define-record bar ((immutable a) (immutable unsigned-32 b))
|
||
|
|
((c (+ a b)) ((double-float d) (+ a b c))))
|
||
|
|
(andmap procedure? (list make-bar bar? bar-a bar-b bar-c bar-d)))
|
||
|
|
(begin
|
||
|
|
(define x (make-bar 9.0 23))
|
||
|
|
(and (bar? x)
|
||
|
|
#;(equal? (format "~s" x) "#[bar 9.0 23 32.0 64.0]")))
|
||
|
|
(eqv? (bar-d x) 64.0)
|
||
|
|
(eqv? (bar-b x) 23)
|
||
|
|
(let ((y (make-bar 9.0 $mpf32)))
|
||
|
|
(eqv? (bar-b y) $mpf32))
|
||
|
|
(let ((y (make-bar 9.0 (+ $mpf32 1))))
|
||
|
|
(eqv? (bar-b y) (+ $mpf32 1)))
|
||
|
|
(let ((y (make-bar 9.0 #x7fffffff)))
|
||
|
|
(eqv? (bar-b y) #x7fffffff))
|
||
|
|
(let ((y (make-bar 9.0 #x80000000)))
|
||
|
|
(eqv? (bar-b y) #x80000000))
|
||
|
|
(let ((y (make-bar 9.0 #xffffffff)))
|
||
|
|
(eqv? (bar-b y) #xffffffff))
|
||
|
|
(error? (make-bar 9.0 #x100000000))
|
||
|
|
(error? (make-bar 9.0 #x-ffffffff))
|
||
|
|
(error? (make-bar 9.0 23.0))
|
||
|
|
; now that we allow 2^(b-1)..2^b-1
|
||
|
|
(let ([y (make-bar 9.0 $mnf32)])
|
||
|
|
(eqv? (bar-b y) (+ #x100000000 $mnf32)))
|
||
|
|
(let ([y (make-bar 9.0 (- $mnf32 1))])
|
||
|
|
(eqv? (bar-b y) (+ #x100000000 (- $mnf32 1))))
|
||
|
|
(let ([y (make-bar 9.0 -1)])
|
||
|
|
(eqv? (bar-b y) #xffffffff))
|
||
|
|
(let ([y (make-bar 9.0 #x-80000000)])
|
||
|
|
(eqv? (bar-b y) #x80000000))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record8
|
||
|
|
(let ()
|
||
|
|
(define small
|
||
|
|
(make-record-type "small"
|
||
|
|
(append '((immutable double-float x))
|
||
|
|
(map (lambda (x) (gensym)) (make-list 3))
|
||
|
|
'((mutable y)))))
|
||
|
|
(let ()
|
||
|
|
(define make-small (record-constructor small))
|
||
|
|
(define small-x (csv7:record-field-accessor small 'x))
|
||
|
|
(define small-y (csv7:record-field-accessor small 'y))
|
||
|
|
(define set-small-y! (csv7:record-field-mutator small 'y))
|
||
|
|
(record-reader 'small small)
|
||
|
|
(let ((x (apply make-small (cons 3.4 (make-list 4 'odyssey)))))
|
||
|
|
(and (eqv? (string-length (format "~s" x)) 44)
|
||
|
|
(begin
|
||
|
|
(collect (collect-maximum-generation))
|
||
|
|
(set-small-y! x (cons 3 4))
|
||
|
|
(let ((p (weak-cons (small-y x) #f)))
|
||
|
|
(collect)
|
||
|
|
(and (eq? (car p) (small-y x))
|
||
|
|
(begin
|
||
|
|
(collect)
|
||
|
|
(eq? (car p) (small-y x))))))))))
|
||
|
|
(let ()
|
||
|
|
(define huge
|
||
|
|
(make-record-type "huge"
|
||
|
|
(append '((immutable double-float x))
|
||
|
|
(map (lambda (x) (gensym)) (make-list 2000))
|
||
|
|
'(y))))
|
||
|
|
(let ()
|
||
|
|
(define make-huge (record-constructor huge))
|
||
|
|
(define huge-x (csv7:record-field-accessor huge 'x))
|
||
|
|
(define huge-y (csv7:record-field-accessor huge 'y))
|
||
|
|
(define set-huge-y! (csv7:record-field-mutator huge 'y))
|
||
|
|
(record-reader 'huge huge)
|
||
|
|
(let ((x (apply make-huge (cons 3.4 (make-list 2001 'odyssey)))))
|
||
|
|
(and (eqv? (string-length (format "~s" x)) 16019)
|
||
|
|
(begin
|
||
|
|
(collect (collect-maximum-generation))
|
||
|
|
(set-huge-y! x (cons 3 4))
|
||
|
|
(let ((p (weak-cons (huge-y x) #f)))
|
||
|
|
(collect)
|
||
|
|
(and (eq? (car p) (huge-y x))
|
||
|
|
(begin
|
||
|
|
(collect)
|
||
|
|
(eq? (car p) (huge-y x))))))))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record9
|
||
|
|
(record-type-descriptor? (make-record-type "fudge" '()))
|
||
|
|
(begin
|
||
|
|
(define fudge (make-record-type "fudge" '((mutable a))))
|
||
|
|
(define make-fudge (record-constructor fudge))
|
||
|
|
(define fudge? (record-predicate fudge))
|
||
|
|
(define fudge.a (csv7:record-field-accessor fudge 'a))
|
||
|
|
(define x (make-fudge 3))
|
||
|
|
(and (record-type-descriptor? fudge) (fudge? x)))
|
||
|
|
(eqv? (fudge.a x) 3)
|
||
|
|
(begin
|
||
|
|
(define set-fudge.a! (csv7:record-field-mutator fudge 'a))
|
||
|
|
(set-fudge.a! x x)
|
||
|
|
(eqv? (fudge.a x) x))
|
||
|
|
(begin (record-reader 'fudge fudge) #t)
|
||
|
|
(begin
|
||
|
|
(define y (read (open-input-string "#[fudge 77]")))
|
||
|
|
(and (fudge? y)
|
||
|
|
(eqv? (fudge.a y) 77)))
|
||
|
|
(eq? (record-reader 'fudge) fudge)
|
||
|
|
(eq? (record-reader fudge) 'fudge)
|
||
|
|
(begin (record-reader 'fudge #f) #t) ; pass name
|
||
|
|
(not (record-reader fudge))
|
||
|
|
(not (record-reader 'fudge))
|
||
|
|
(begin (record-reader 'fudge fudge) #t)
|
||
|
|
(eq? (record-reader 'fudge) fudge)
|
||
|
|
(eq? (record-reader fudge) 'fudge)
|
||
|
|
(error? (record-reader #f))
|
||
|
|
(error? (record-reader #f 'fudge))
|
||
|
|
(error? (record-reader fudge 'fudge))
|
||
|
|
(error? (record-reader #f #f))
|
||
|
|
(error? (record-reader 'fudge 'candy))
|
||
|
|
(error? (record-reader fudge fudge))
|
||
|
|
(begin (record-reader fudge #f) #t) ; pass rtd
|
||
|
|
(not (record-reader fudge))
|
||
|
|
(not (record-reader 'fudge))
|
||
|
|
(begin
|
||
|
|
(define fudge (make-record-type "fudge" '((a))))
|
||
|
|
(define make-fudge (record-constructor fudge))
|
||
|
|
(define fudge? (record-predicate fudge))
|
||
|
|
(define fudge.a (csv7:record-field-accessor fudge 'a))
|
||
|
|
(define x (make-fudge 3))
|
||
|
|
(and (record-type-descriptor? fudge) (fudge? x)))
|
||
|
|
(eqv? (fudge.a x) 3)
|
||
|
|
(begin
|
||
|
|
(define set-fudge.a! (csv7:record-field-mutator fudge 'a))
|
||
|
|
(set-fudge.a! x x)
|
||
|
|
(eqv? (fudge.a x) x))
|
||
|
|
(begin (record-reader 'fudge fudge) #t)
|
||
|
|
(begin
|
||
|
|
(define y (read (open-input-string "#[fudge 77]")))
|
||
|
|
(and (fudge? y)
|
||
|
|
(eqv? (fudge.a y) 77)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record10
|
||
|
|
(begin
|
||
|
|
(define bar (make-record-type "bar"
|
||
|
|
'((immutable a) (mutable b) (immutable c))))
|
||
|
|
(define make-bar (record-constructor bar))
|
||
|
|
(define bar? (record-predicate bar))
|
||
|
|
(define bar.a (csv7:record-field-accessor bar 'a))
|
||
|
|
(define bar.b (csv7:record-field-accessor bar 'b))
|
||
|
|
(define bar.c (csv7:record-field-accessor bar 'c))
|
||
|
|
(define x (make-bar 3 4 5))
|
||
|
|
(bar? x))
|
||
|
|
(eqv? (bar.b x) 4)
|
||
|
|
(begin
|
||
|
|
(define set-bar.b! (csv7:record-field-mutator bar 'b))
|
||
|
|
(procedure? set-bar.b!))
|
||
|
|
(error? (define set-bar.a! (csv7:record-field-mutator bar 'a)))
|
||
|
|
(error? (define set-bar.c! (csv7:record-field-mutator bar 'c)))
|
||
|
|
(begin (record-reader 'bar bar) #t)
|
||
|
|
(let ((x (read (open-input-string "#1=#[bar a #1# c]"))))
|
||
|
|
(and (bar? x) (eq? (bar.b x) x)))
|
||
|
|
(let ((x (read (open-input-string "#[bar #1=a b #1#]"))))
|
||
|
|
(and (bar? x)
|
||
|
|
(eq? (bar.a x) 'a)
|
||
|
|
(eq? (bar.a x) (bar.c x))
|
||
|
|
(eq? (bar.b x) 'b)))
|
||
|
|
(error? (read (open-input-string "#1=#[bar a b #1#]")))
|
||
|
|
(error? (read (open-input-string "#1=#[bar #1# b c]")))
|
||
|
|
(bar? (read (open-input-string "#[bar #1# b #1=a]")))
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(let ([pred (begin
|
||
|
|
(display "one\n")
|
||
|
|
(record-predicate
|
||
|
|
(begin
|
||
|
|
(display "two\n")
|
||
|
|
(make-record-type '#{foo bje68fdhbe06wod3-a} '(x)))))])
|
||
|
|
(printf "~s\n" (pred 17))
|
||
|
|
(printf "~s\n" (pred ((record-constructor (make-record-type '#{foo bje68fdhbe06wod3-a} '(x))) 55))))))
|
||
|
|
"one\ntwo\n#f\n#t\n")
|
||
|
|
)
|
||
|
|
|
||
|
|
#;(mat record11
|
||
|
|
(let ()
|
||
|
|
(define froz
|
||
|
|
(rec froz
|
||
|
|
(make-record-type "froz" '((immutable a) (immutable b))
|
||
|
|
(lambda (x p wr)
|
||
|
|
(define froz.a (csv7:record-field-accessor froz 'a))
|
||
|
|
(wr `(* hi john ,(froz.a x) *) p)))))
|
||
|
|
(equal? (format "~s" ((record-constructor froz) 1 2))
|
||
|
|
"(* hi john 1 *)"))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record12
|
||
|
|
(begin
|
||
|
|
(define-record $tree ((immutable left) (immutable node) (immutable right)))
|
||
|
|
(record-type-descriptor? (type-descriptor $tree)))
|
||
|
|
($tree? (make-$tree 3 4 5))
|
||
|
|
(let ((tr (make-$tree 'a 'b 'c)))
|
||
|
|
(and (eq? ($tree-left tr) 'a)
|
||
|
|
(eq? ($tree-node tr) 'b)
|
||
|
|
(eq? ($tree-right tr) 'c)))
|
||
|
|
(begin
|
||
|
|
(define-record $tree ((left) (node) (right)))
|
||
|
|
(record-type-descriptor? (type-descriptor $tree)))
|
||
|
|
($tree? (make-$tree 3 4 5))
|
||
|
|
(let ((tr (make-$tree 'a 'b 'c)))
|
||
|
|
(and (eq? ($tree-left tr) 'a)
|
||
|
|
(eq? ($tree-node tr) 'b)
|
||
|
|
(eq? ($tree-right tr) 'c)))
|
||
|
|
(begin
|
||
|
|
(define-record $tree (left node right))
|
||
|
|
(record-type-descriptor? (type-descriptor $tree)))
|
||
|
|
($tree? (make-$tree 3 4 5))
|
||
|
|
(let ((tr (make-$tree 'a 'b 'c)))
|
||
|
|
(and (eq? ($tree-left tr) 'a)
|
||
|
|
(eq? ($tree-node tr) 'b)
|
||
|
|
(eq? ($tree-right tr) 'c)))
|
||
|
|
(begin
|
||
|
|
(define-record $tree ((left) (immutable node) (right)))
|
||
|
|
(record-type-descriptor? (type-descriptor $tree)))
|
||
|
|
($tree? (make-$tree 3 4 5))
|
||
|
|
(let ((tr (make-$tree 'a 'b 'c)))
|
||
|
|
(and (eq? ($tree-left tr) 'a)
|
||
|
|
(eq? ($tree-node tr) 'b)
|
||
|
|
(eq? ($tree-right tr) 'c)))
|
||
|
|
(begin
|
||
|
|
(define-record pare ((mutable kar) kdr)
|
||
|
|
(((scheme-object original-kar) kar) ((mutable original-kdr) kdr)))
|
||
|
|
(record-type-descriptor? (type-descriptor pare)))
|
||
|
|
(andmap procedure?
|
||
|
|
(list make-pare
|
||
|
|
pare?
|
||
|
|
pare-kar
|
||
|
|
pare-kdr
|
||
|
|
pare-original-kar
|
||
|
|
pare-original-kdr
|
||
|
|
set-pare-kar!
|
||
|
|
set-pare-kdr!
|
||
|
|
set-pare-original-kar!
|
||
|
|
set-pare-original-kdr!))
|
||
|
|
(pare? (make-pare 3 4))
|
||
|
|
(eq? (pare-kar (make-pare 'a 'b)) 'a)
|
||
|
|
(eq? (pare-kdr (make-pare 'a 'b)) 'b)
|
||
|
|
(eq? (pare-original-kar (make-pare 'a 'b)) 'a)
|
||
|
|
(eq? (pare-original-kdr (make-pare 'a 'b)) 'b)
|
||
|
|
(let ((p (make-pare 'a 'b)))
|
||
|
|
(set-pare-kar! p 'c)
|
||
|
|
(set-pare-kdr! p 'd)
|
||
|
|
(and (eq? (pare-kar p) 'c)
|
||
|
|
(eq? (pare-kdr p) 'd)
|
||
|
|
(eq? (pare-original-kar p) 'a)
|
||
|
|
(eq? (pare-original-kdr p) 'b)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record13
|
||
|
|
(begin
|
||
|
|
(define-record stretch-string ((integer-32 length) (fill))
|
||
|
|
([(string) (make-string length fill)]))
|
||
|
|
(define stretch-string-ref
|
||
|
|
(lambda (s i)
|
||
|
|
(let ([n (stretch-string-length s)])
|
||
|
|
(when (>= i n) (stretch-stretch-string! s (+ i 1) n))
|
||
|
|
(string-ref (stretch-string-string s) i))))
|
||
|
|
(define stretch-string-set!
|
||
|
|
(lambda (s i c)
|
||
|
|
(let ([n (stretch-string-length s)])
|
||
|
|
(when (>= i n) (stretch-stretch-string! s (+ i 1) n))
|
||
|
|
(string-set! (stretch-string-string s) i c))))
|
||
|
|
(define stretch-string-fill!
|
||
|
|
(lambda (s c)
|
||
|
|
(string-fill! (stretch-string-string s) c)
|
||
|
|
(set-stretch-string-fill! s c)))
|
||
|
|
(define stretch-stretch-string!
|
||
|
|
(lambda (s i n)
|
||
|
|
(set-stretch-string-length! s i)
|
||
|
|
(let ([str (stretch-string-string s)]
|
||
|
|
[fill (stretch-string-fill s)])
|
||
|
|
(let ([xtra (make-string (- i n) fill)])
|
||
|
|
(set-stretch-string-string! s
|
||
|
|
(string-append str xtra))))))
|
||
|
|
(define ss (make-stretch-string 2 #\X))
|
||
|
|
(stretch-string? ss))
|
||
|
|
|
||
|
|
(equal? (stretch-string-string ss) "XX")
|
||
|
|
(eqv? (stretch-string-ref ss 3) #\X)
|
||
|
|
(eqv? (stretch-string-length ss) 4)
|
||
|
|
(equal? (stretch-string-string ss) "XXXX")
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(stretch-string-fill! ss #\@)
|
||
|
|
(equal? (stretch-string-string ss) "@@@@"))
|
||
|
|
(eqv? (stretch-string-ref ss 5) #\@)
|
||
|
|
(equal? (stretch-string-string ss) "@@@@@@")
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(stretch-string-set! ss 7 #\=)
|
||
|
|
(eqv? (stretch-string-length ss) 8))
|
||
|
|
(equal? (stretch-string-string ss) "@@@@@@@=")
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record14
|
||
|
|
(begin
|
||
|
|
(define-record froz
|
||
|
|
((immutable a) (immutable b))
|
||
|
|
(((immutable c) (+ a b)))
|
||
|
|
(#;(print-method
|
||
|
|
(lambda (x p wr)
|
||
|
|
(wr `(* hi john ,(froz-c x) *) p)))))
|
||
|
|
(froz? (make-froz 17 23)))
|
||
|
|
#;(equal? (format "~s" (make-froz 17 23)) "(* hi john 40 *)")
|
||
|
|
(eqv? (froz-a (make-froz 17 23)) 17)
|
||
|
|
(let ()
|
||
|
|
(define-record pair ((mutable car) (immutable cdr))
|
||
|
|
()
|
||
|
|
(#;(print-method
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "(" p) ; )
|
||
|
|
(wr (car x) p)
|
||
|
|
(display " . " p)
|
||
|
|
(wr (cdr x) p) ; (
|
||
|
|
(display ")" p)))
|
||
|
|
(constructor cons)
|
||
|
|
(prefix "")))
|
||
|
|
(and (pair? (cons 3 4))
|
||
|
|
(not (pair? '(3 . 4)))
|
||
|
|
(eq? (car (cons 3 4)) 3)
|
||
|
|
(eq? (cdr (cons 3 4)) 4)
|
||
|
|
#;(equal? (format "~s" (cons 3 (cons 4 '()))) "(3 . (4 . ()))")
|
||
|
|
#;(let ((x (cons 3 4)))
|
||
|
|
(set-car! x x)
|
||
|
|
(equal? (format "~s" x) "#0=(#0# . 4)"))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record15
|
||
|
|
(equal? (let ()
|
||
|
|
(define-record foo ((mutable a)))
|
||
|
|
(let ((x (make-foo '*)))
|
||
|
|
(record-reader 'foo (record-rtd x))
|
||
|
|
(set-foo-a! x x)
|
||
|
|
(parameterize ((print-graph #t))
|
||
|
|
(let ((p (open-output-string)))
|
||
|
|
(pretty-print x p)
|
||
|
|
(get-output-string p)))))
|
||
|
|
(format "#0=#[foo #0#]~%"))
|
||
|
|
(equal? (let ((* "*"))
|
||
|
|
(define-record foo (a))
|
||
|
|
(let ((x (make-foo *)) (y (make-foo *)))
|
||
|
|
(record-reader 'foo (record-rtd x))
|
||
|
|
(parameterize ((print-graph #t))
|
||
|
|
(format "~s" (list x y)))))
|
||
|
|
"(#[foo #0=\"*\"] #[foo #0#])")
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record16
|
||
|
|
(begin
|
||
|
|
(define-record bazar ((immutable a) (mutable b) (immutable c))
|
||
|
|
()
|
||
|
|
((prefix "bazar.") #;(reader-name "bazar")))
|
||
|
|
(define x (make-bazar 3 4 5))
|
||
|
|
(bazar? x))
|
||
|
|
(eqv? (bazar.b x) 4)
|
||
|
|
(procedure? set-bazar.b!)
|
||
|
|
(eqv? (record-reader 'bazar (record-rtd x)) (void))
|
||
|
|
(let ((x (read (open-input-string "#1=#[bazar a #1# c]"))))
|
||
|
|
(and (bazar? x) (eq? (bazar.b x) x)))
|
||
|
|
(let ((x (read (open-input-string "#[bazar #1=a b #1#]"))))
|
||
|
|
(and (bazar? x)
|
||
|
|
(eq? (bazar.a x) 'a)
|
||
|
|
(eq? (bazar.a x) (bazar.c x))
|
||
|
|
(eq? (bazar.b x) 'b)))
|
||
|
|
(error? (read (open-input-string "#1=#[bazar a b #1#]")))
|
||
|
|
(error? (read (open-input-string "#1=#[bazar #1# b c]")))
|
||
|
|
(bazar? (read (open-input-string "#[bazar #1# b #1=a]")))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record17
|
||
|
|
(let ()
|
||
|
|
(define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
|
||
|
|
(let ()
|
||
|
|
(define r (make-f 1 2 3))
|
||
|
|
(and (f? r) (equal? '(3 2 1) (list (f-z r) (f-y r) (f-x r))))))
|
||
|
|
(let ()
|
||
|
|
(define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
|
||
|
|
(let ()
|
||
|
|
(define r (make-f 1 2 3))
|
||
|
|
(set-f-x! r 72)
|
||
|
|
(set-f-y! r 73)
|
||
|
|
(set-f-z! r 74)
|
||
|
|
(and (f? r) (equal? '(74 73 72) (list (f-z r) (f-y r) (f-x r))))))
|
||
|
|
(let ()
|
||
|
|
(define-record f ((integer-8 x) (integer-8 y) (integer-32 z)))
|
||
|
|
(let ()
|
||
|
|
(define r (make-f 1 2 3))
|
||
|
|
(set-f-x! r -72)
|
||
|
|
(set-f-y! r -73)
|
||
|
|
(set-f-z! r -74)
|
||
|
|
(and (f? r) (equal? '(-74 -73 -72) (list (f-z r) (f-y r) (f-x r))))))
|
||
|
|
(begin
|
||
|
|
(define-record $froz
|
||
|
|
((unsigned-8 x) (double-float y) (single-float z) (unsigned-16 w)))
|
||
|
|
(procedure? make-$froz))
|
||
|
|
(error? (make-$froz 256 2.5 3.5 0))
|
||
|
|
(let ([y (make-$froz -1 2.5 3.5 0)])
|
||
|
|
(eqv? ($froz-x y) (+ #x100 -1)))
|
||
|
|
(error? (make-$froz -129 2.5 3.5 0))
|
||
|
|
(error? (make-$froz 0 2.5 3.5 #x10000))
|
||
|
|
(let ([y (make-$froz 0 2.5 3.5 -1)])
|
||
|
|
(eqv? ($froz-w y) (+ #x10000 -1)))
|
||
|
|
(error? (make-$froz 0 2.5 3.5 #x-8001))
|
||
|
|
(error? (make-$froz 0 2 3.5 0))
|
||
|
|
(error? (make-$froz 0 2.5 3 0))
|
||
|
|
(begin (define $rfroz (make-$froz 1 2.5 3.5 4)) ($froz? $rfroz))
|
||
|
|
(eqv? ($froz-x $rfroz) 1)
|
||
|
|
(eqv? ($froz-y $rfroz) 2.5)
|
||
|
|
(eqv? ($froz-z $rfroz) 3.5)
|
||
|
|
(eqv? ($froz-w $rfroz) 4)
|
||
|
|
(eqv? (set-$froz-x! $rfroz 2) (void))
|
||
|
|
(eqv? (set-$froz-y! $rfroz 2.75) (void))
|
||
|
|
(eqv? (set-$froz-z! $rfroz 3.75) (void))
|
||
|
|
(eqv? (set-$froz-w! $rfroz 5) (void))
|
||
|
|
(eqv? ($froz-x $rfroz) 2)
|
||
|
|
(eqv? ($froz-y $rfroz) 2.75)
|
||
|
|
(eqv? ($froz-z $rfroz) 3.75)
|
||
|
|
(eqv? ($froz-w $rfroz) 5)
|
||
|
|
(eqv? (set-$froz-z! $rfroz #b11e111111111) (void))
|
||
|
|
(eqv? ($froz-z $rfroz) +inf.0)
|
||
|
|
(eqv? (set-$froz-z! $rfroz #b11e-111111111) (void))
|
||
|
|
(eqv? ($froz-z $rfroz) 0.0)
|
||
|
|
(begin
|
||
|
|
(set-$froz-x! $rfroz -1)
|
||
|
|
(eqv? ($froz-x $rfroz) (+ #x100 -1)))
|
||
|
|
(error? (set-$froz-x! $rfroz 256))
|
||
|
|
(error? (set-$froz-x! $rfroz #x-81))
|
||
|
|
(error? (set-$froz-y! $rfroz 2))
|
||
|
|
(error? (set-$froz-z! $rfroz 2))
|
||
|
|
(error? (set-$froz-w! $rfroz #x-8001))
|
||
|
|
(begin
|
||
|
|
(set-$froz-w! $rfroz -1)
|
||
|
|
(eqv? ($froz-w $rfroz) (+ #x10000 -1)))
|
||
|
|
(error? (set-$froz-w! $rfroz #x10000))
|
||
|
|
(begin
|
||
|
|
(define-record $froz ((integer-8 x) (integer-16 w)))
|
||
|
|
(procedure? make-$froz))
|
||
|
|
(error? (make-$froz 256 0))
|
||
|
|
(let ([y (make-$froz #x80 #x8000)])
|
||
|
|
(and (eqv? ($froz-x y) #x-80)
|
||
|
|
(eqv? ($froz-w y) #x-8000)))
|
||
|
|
(error? (make-$froz -129 0))
|
||
|
|
(error? (make-$froz 0 #x10000))
|
||
|
|
(error? (make-$froz 0 #x-8001))
|
||
|
|
(begin (define $rfroz (make-$froz 1 4)) ($froz? $rfroz))
|
||
|
|
(eqv? ($froz-x $rfroz) 1)
|
||
|
|
(eqv? ($froz-w $rfroz) 4)
|
||
|
|
(eqv? (set-$froz-x! $rfroz 2) (void))
|
||
|
|
(eqv? (set-$froz-w! $rfroz 5) (void))
|
||
|
|
(eqv? ($froz-x $rfroz) 2)
|
||
|
|
(eqv? ($froz-w $rfroz) 5)
|
||
|
|
(begin (set-$froz-x! $rfroz #xff)
|
||
|
|
(set-$froz-w! $rfroz #xffff)
|
||
|
|
(eqv? ($froz-x $rfroz) -1)
|
||
|
|
(eqv? ($froz-w $rfroz) -1))
|
||
|
|
(error? (set-$froz-x! $rfroz 256))
|
||
|
|
(error? (set-$froz-x! $rfroz -129))
|
||
|
|
(error? (set-$froz-w! $rfroz #x10000))
|
||
|
|
(error? (set-$froz-w! $rfroz #x-8001))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record18
|
||
|
|
(let* ([size 200]
|
||
|
|
[ls (map (lambda (x)
|
||
|
|
(let ([name (gensym)])
|
||
|
|
(case (random 6)
|
||
|
|
[(0) `(immutable ,name)]
|
||
|
|
[(1) `(mutable ,name)]
|
||
|
|
[(2) `(integer-32 ,name)]
|
||
|
|
[(3) `(double-float ,name)]
|
||
|
|
[(4) `(single-float ,name)]
|
||
|
|
[(5) `(immutable unsigned-16 ,name)])))
|
||
|
|
(make-list size))])
|
||
|
|
(define another
|
||
|
|
(lambda (type)
|
||
|
|
(case type
|
||
|
|
[(scheme-object) (substring "xxlovelyxx" 2 8)]
|
||
|
|
[(integer-32)
|
||
|
|
(case (random 10)
|
||
|
|
[(0) 0]
|
||
|
|
[(1) 1]
|
||
|
|
[(2) -1]
|
||
|
|
[(3) $mpf32]
|
||
|
|
[(4) $mnf32]
|
||
|
|
[(5) (+ $mpf32 1)]
|
||
|
|
[(6) (- $mnf32 1)]
|
||
|
|
[(7) #x7fffffff]
|
||
|
|
[(8) #x-80000000]
|
||
|
|
[(9) (- (random #x100000000) #x80000000)])]
|
||
|
|
[(unsigned-16)
|
||
|
|
(case (random 6)
|
||
|
|
[(0) 0]
|
||
|
|
[(1) 1]
|
||
|
|
[(2) #x7fff]
|
||
|
|
[(3) #x8000]
|
||
|
|
[(4) #xffff]
|
||
|
|
[(5) (random #x10000)])]
|
||
|
|
[(double-float) (if (zero? (random 1)) (random 1e15) (- (random 1e15)))]
|
||
|
|
[(single-float) (inexact (random #e1e7))]
|
||
|
|
[else (errorf #f "unexpected type ~s" type)])))
|
||
|
|
(let ([rtd (make-record-type "big" ls)])
|
||
|
|
(let ([accessors (map (lambda (x) (csv7:record-field-accessor rtd x))
|
||
|
|
(csv7:record-type-field-names rtd))]
|
||
|
|
[mutators (map (lambda (x)
|
||
|
|
(and (csv7:record-field-mutable? rtd x)
|
||
|
|
(csv7:record-field-mutator rtd x)))
|
||
|
|
(csv7:record-type-field-names rtd))]
|
||
|
|
[vals (map another (map cadr (csv7:record-type-field-decls rtd)))])
|
||
|
|
(let ([inst (apply (record-constructor rtd) vals)])
|
||
|
|
(let f ((n 2000) (vals vals))
|
||
|
|
(unless (= n 0)
|
||
|
|
(if (= (modulo n 20) 0) (collect))
|
||
|
|
(f (- n 1)
|
||
|
|
(map (lambda (acc mut! val type)
|
||
|
|
(let ([ival (acc inst)])
|
||
|
|
(unless (and (eqv? ival val)
|
||
|
|
(or (not (string? ival))
|
||
|
|
(string=? ival "lovely")))
|
||
|
|
(errorf #f "unexpected value ~s; should have been ~s"
|
||
|
|
ival val)))
|
||
|
|
(if (and mut! (= (random 10) 3))
|
||
|
|
(let ([nval (another type)])
|
||
|
|
(mut! inst nval)
|
||
|
|
nval)
|
||
|
|
val))
|
||
|
|
accessors
|
||
|
|
mutators
|
||
|
|
vals
|
||
|
|
(map cadr (csv7:record-type-field-decls rtd)))))))))
|
||
|
|
#t)
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat foreign-data
|
||
|
|
(begin
|
||
|
|
(module ($fd-unaligned-integers $fd-unaligned-floats)
|
||
|
|
(define-syntax define-constant
|
||
|
|
(syntax-rules (machine-type)
|
||
|
|
[(_ machine-type y) (begin)]
|
||
|
|
[(_ x y) (define x y)]))
|
||
|
|
(define-syntax features
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ x ...) (begin)]))
|
||
|
|
(define-syntax constant
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ x) x]))
|
||
|
|
(define-syntax constant-case
|
||
|
|
(syntax-rules (else)
|
||
|
|
[(_ const [(k ...) e1 e2 ...] ... [else ee1 ee2 ...])
|
||
|
|
(meta-cond
|
||
|
|
[(memv (constant const) '(k ...)) e1 e2 ...]
|
||
|
|
...
|
||
|
|
[else ee1 ee2 ...])]
|
||
|
|
[(_ const [(k ...) e1 e2 ...] ...)
|
||
|
|
(meta-cond
|
||
|
|
[(memv (constant const) '(k ...)) e1 e2 ...]
|
||
|
|
...
|
||
|
|
[else (syntax-error const
|
||
|
|
(format "unhandled value ~s" (constant const)))])]))
|
||
|
|
(define-syntax include-from-s
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(k ?path)
|
||
|
|
(string? (datum ?path))
|
||
|
|
(let ([s-path (format "~a/../s/~a" *mats-dir* (datum ?path))])
|
||
|
|
(datum->syntax #'k `(include ,s-path)))])))
|
||
|
|
(include-from-s "machine.def")
|
||
|
|
; all this work for two constants:
|
||
|
|
(define $fd-unaligned-integers (constant unaligned-integers))
|
||
|
|
(define $fd-unaligned-floats (constant unaligned-floats)))
|
||
|
|
(define ($fd-make-min bytes) (- (ash (expt 256 bytes) -1)))
|
||
|
|
(define ($fd-make-max bytes) (- (expt 256 bytes) 1))
|
||
|
|
(define $fd-addr-min ($fd-make-min (foreign-sizeof 'void*)))
|
||
|
|
(define $fd-addr-max ($fd-make-max (foreign-sizeof 'void*)))
|
||
|
|
(define $fd-int-min ($fd-make-min (foreign-sizeof 'int)))
|
||
|
|
(define $fd-int-max ($fd-make-max (foreign-sizeof 'int)))
|
||
|
|
(define $fd-short-min ($fd-make-min (foreign-sizeof 'short)))
|
||
|
|
(define $fd-short-max ($fd-make-max (foreign-sizeof 'short)))
|
||
|
|
(define $fd-long-min ($fd-make-min (foreign-sizeof 'long)))
|
||
|
|
(define $fd-long-max ($fd-make-max (foreign-sizeof 'long)))
|
||
|
|
(define $fd-long-long-min ($fd-make-min (foreign-sizeof 'long-long)))
|
||
|
|
(define $fd-long-long-max ($fd-make-max (foreign-sizeof 'long-long)))
|
||
|
|
(define $fd-char-max ($fd-make-max 1))
|
||
|
|
(define $fd-wchar-max (min ($fd-make-max (foreign-sizeof 'wchar)) #x10ffff))
|
||
|
|
(define $fd-i8-min ($fd-make-min 1))
|
||
|
|
(define $fd-i8-max ($fd-make-max 1))
|
||
|
|
(define $fd-i16-min ($fd-make-min 2))
|
||
|
|
(define $fd-i16-max ($fd-make-max 2))
|
||
|
|
(define $fd-i32-min ($fd-make-min 4))
|
||
|
|
(define $fd-i32-max ($fd-make-max 4))
|
||
|
|
(define $fd-i64-min ($fd-make-min 8))
|
||
|
|
(define $fd-i64-max ($fd-make-max 8))
|
||
|
|
#t)
|
||
|
|
; foreign-alloc
|
||
|
|
(error? ; not a positive fixnum
|
||
|
|
(foreign-alloc 0))
|
||
|
|
(error? ; not a positive fixnum
|
||
|
|
(foreign-alloc (+ (most-positive-fixnum) 1)))
|
||
|
|
(error? ; not a positive fixnum
|
||
|
|
(foreign-alloc -5))
|
||
|
|
(error? ; not a positive fixnum
|
||
|
|
(foreign-alloc 17.0))
|
||
|
|
; foreign-free
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-free 17.0))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-free (- $fd-addr-min 1)))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-free (+ $fd-addr-max 1)))
|
||
|
|
(equal?
|
||
|
|
(let ([x (foreign-alloc 16)])
|
||
|
|
(list
|
||
|
|
(<= 0 x $fd-addr-max)
|
||
|
|
(foreign-free x)))
|
||
|
|
(list #t (void)))
|
||
|
|
; foreign-ref
|
||
|
|
(begin
|
||
|
|
(define $max-uptr+1
|
||
|
|
(cond
|
||
|
|
[(fx= (fixnum-width) 30) #x100000000]
|
||
|
|
[(fx= (fixnum-width) 61) #x10000000000000000]
|
||
|
|
[else ($oops '$raw-fd-a "unexpected fixnum-width ~s" (fixnum-width))]))
|
||
|
|
#t)
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-ref 'integer-32 $max-uptr+1 0))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-ref 'integer-32 (- $max-uptr+1) 100))
|
||
|
|
(error? ; invalid offset
|
||
|
|
(foreign-ref 'integer-32 0 (+ (most-positive-fixnum) 1)))
|
||
|
|
(error? ; invalid addr + offset
|
||
|
|
(foreign-ref 'integer-32 (- $max-uptr+1 4) 4))
|
||
|
|
(error? ; invalid addr + offset for 4-byte type
|
||
|
|
(foreign-ref 'integer-32 (- $max-uptr+1 8) 6))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-set! 'integer-32 $max-uptr+1 0 7))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-set! 'integer-32 (- $max-uptr+1) 100 7))
|
||
|
|
(error? ; invalid offset
|
||
|
|
(foreign-set! 'integer-32 0 (+ (most-positive-fixnum) 1) 7))
|
||
|
|
(error? ; invalid addr + offset
|
||
|
|
(foreign-set! 'integer-32 (- $max-uptr+1 4) 4 7))
|
||
|
|
(error? ; invalid addr + offset for 4-byte type
|
||
|
|
(foreign-set! 'integer-32 (- $max-uptr+1 8) 6 7))
|
||
|
|
(meta-cond
|
||
|
|
[(fx= (fixnum-width) 30)
|
||
|
|
(define $real-fd-a (foreign-alloc (+ 40 7)))
|
||
|
|
(define $fd-a (logand (+ $real-fd-a 7) -8))
|
||
|
|
(define $raw-fd-a (ash (if (>= $fd-a (expt 2 31)) (- $fd-a (expt 2 32)) $fd-a) -2))
|
||
|
|
(and
|
||
|
|
(<= 0 $fd-a $fd-addr-max)
|
||
|
|
(fixnum? $raw-fd-a))]
|
||
|
|
[(fx= (fixnum-width) 61)
|
||
|
|
(define $real-fd-a (foreign-alloc (+ 40 7)))
|
||
|
|
(define $fd-a (logand (+ $real-fd-a 7) -8))
|
||
|
|
(define $raw-fd-a (ash (if (>= $fd-a (expt 2 63)) (- $fd-a (expt 2 64)) $fd-a) -3))
|
||
|
|
(and
|
||
|
|
(<= 0 $fd-a $fd-addr-max)
|
||
|
|
(fixnum? $raw-fd-a))]
|
||
|
|
[else ($oops '$raw-fd-a "unexpected fixnum-width ~s" (fixnum-width))])
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-ref 'aint $fd-a 0))
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-ref 'ptr $fd-a 0))
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-ref 'scheme-object $fd-a 0))
|
||
|
|
(begin
|
||
|
|
(define $fd-f (lambda () (foreign-ref 'ptr $fd-a 0)))
|
||
|
|
(procedure? $fd-f))
|
||
|
|
(error? ; invalid type
|
||
|
|
($fd-f))
|
||
|
|
(begin
|
||
|
|
(define $fd-f (lambda (x) (foreign-ref x $fd-a 0)))
|
||
|
|
(procedure? $fd-f))
|
||
|
|
(error? ; invalid type
|
||
|
|
($fd-f 'ptr))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-ref 'int 7.5 0))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-ref 'int (- $fd-addr-min 1) 0))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-ref 'int (+ $fd-addr-max 1) 0))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-ref 'int $fd-a 0.0))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-ref 'int $fd-a (+ (most-positive-fixnum) 1)))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-ref 'int $fd-a (- (most-negative-fixnum) 1)))
|
||
|
|
; foreign-set!
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-set! 'aint $fd-a 0 17))
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-set! 'ptr $fd-a 0 17))
|
||
|
|
(error? ; invalid type
|
||
|
|
(foreign-set! 'scheme-object $fd-a 0 17))
|
||
|
|
(begin
|
||
|
|
(define $fd-f (lambda () (foreign-set! 'ptr $fd-a 0 17)))
|
||
|
|
(procedure? $fd-f))
|
||
|
|
(error? ; invalid type
|
||
|
|
($fd-f))
|
||
|
|
(begin
|
||
|
|
(define $fd-f (lambda (x) (foreign-set! x $fd-a 0 17)))
|
||
|
|
(procedure? $fd-f))
|
||
|
|
(error? ; invalid type
|
||
|
|
($fd-f 'ptr))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-set! 'int 7.5 0 17))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-set! 'int (- $fd-addr-min 1) 0 17))
|
||
|
|
(error? ; invalid address
|
||
|
|
(foreign-set! 'int (+ $fd-addr-max 1) 0 17))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-set! 'int $fd-a 0.0 17))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-set! 'int $fd-a (+ (most-positive-fixnum) 1) 17))
|
||
|
|
(error? ; not a fixnum
|
||
|
|
(foreign-set! 'int $fd-a (- (most-negative-fixnum) 1) 17))
|
||
|
|
; integer-8/unsigned-8
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-8 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-8 $fd-a 0 (- $fd-i8-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-8 $fd-a 0 (+ $fd-i8-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 0 (- $fd-i8-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 0 (+ $fd-i8-max 1)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-8 $fd-a 3 255)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)))
|
||
|
|
'(-1 255))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 5 -5)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 5)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 5)))
|
||
|
|
'(-5 251))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-8 $fd-a 0 #x-80)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 1 0)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 2 #x7f)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 3 #x80)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 4 #xff)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 1)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 1)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 0 #x-80)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 1 0)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 2 #x7f)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 3 #x80)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 4 #xff)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 1)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 1)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
; integer-16/unsigned-16
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-16 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-16 $fd-a 0 (- $fd-i16-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-16 $fd-a 0 (+ $fd-i16-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 0 (- $fd-i16-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 0 (+ $fd-i16-max 1)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-16 $fd-a 2 #xabcd)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 2 -5321)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-16 $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 2 0)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 6)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 2 0)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 6)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
; integer-32/unsigned-32
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-32 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-32 $fd-a 0 (- $fd-i32-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-32 $fd-a 0 (+ $fd-i32-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 0 (- $fd-i32-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 0 (+ $fd-i32-max 1)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-32 $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 4 0)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 4 0)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-32 $fd-a 12 #xabcd1234)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000) #xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 12 #x-765321ab)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000)))
|
||
|
|
; integer-64/unsigned-64
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-64 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-64 $fd-a 0 (- $fd-i64-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'integer-64 $fd-a 0 (+ $fd-i64-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 0 (- $fd-i64-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 0 (+ $fd-i64-max 1)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 8 0)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 24)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 8 0)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 24)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
; iptr/uptr
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'iptr $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'iptr $fd-a 0 (- $fd-addr-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'iptr $fd-a 0 (+ $fd-addr-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'uptr $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'uptr $fd-a 0 (- $fd-addr-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'uptr $fd-a 0 (+ $fd-addr-max 1)))
|
||
|
|
(case $fd-addr-max
|
||
|
|
[(#xffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'iptr $fd-a 12 #xabcd1234)
|
||
|
|
(list (foreign-ref 'iptr $fd-a 12)
|
||
|
|
(foreign-ref 'uptr $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234
|
||
|
|
,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'uptr $fd-a 12 #x-765321ab)
|
||
|
|
(list (foreign-ref 'iptr $fd-a 12)
|
||
|
|
(foreign-ref 'uptr $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000)
|
||
|
|
#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000))))]
|
||
|
|
[(#xffffffffffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'iptr $fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'iptr $fd-a 16)
|
||
|
|
(foreign-ref 'uptr $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'uptr $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'iptr $fd-a 16)
|
||
|
|
(foreign-ref 'uptr $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'void* $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'iptr $fd-a 16)
|
||
|
|
(foreign-ref 'void* $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-addr-max ~s" $fd-addr-max)])
|
||
|
|
; int/unsigned
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'int $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'int $fd-a 0 (- $fd-int-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'int $fd-a 0 (+ $fd-int-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned $fd-a 0 (- $fd-int-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned $fd-a 0 (+ $fd-int-max 1)))
|
||
|
|
(case $fd-int-max
|
||
|
|
[(#xffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'int $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'int $fd-a 4 0)
|
||
|
|
(foreign-set! 'int $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'int $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'int $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'int $fd-a 0)
|
||
|
|
(foreign-ref 'int $fd-a 4)
|
||
|
|
(foreign-ref 'int $fd-a 8)
|
||
|
|
(foreign-ref 'int $fd-a 12)
|
||
|
|
(foreign-ref 'int $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'unsigned $fd-a 4 0)
|
||
|
|
(foreign-set! 'unsigned $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'unsigned $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'unsigned $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'int $fd-a 0)
|
||
|
|
(foreign-ref 'int $fd-a 4)
|
||
|
|
(foreign-ref 'int $fd-a 8)
|
||
|
|
(foreign-ref 'int $fd-a 12)
|
||
|
|
(foreign-ref 'int $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-int $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'unsigned-int $fd-a 4 0)
|
||
|
|
(foreign-set! 'unsigned-int $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'unsigned-int $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'unsigned-int $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'int $fd-a 0)
|
||
|
|
(foreign-ref 'int $fd-a 4)
|
||
|
|
(foreign-ref 'int $fd-a 8)
|
||
|
|
(foreign-ref 'int $fd-a 12)
|
||
|
|
(foreign-ref 'int $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-int $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-int $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-int $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-int $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-int $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'int $fd-a 12 #xabcd1234)
|
||
|
|
(list (foreign-ref 'int $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234
|
||
|
|
,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned $fd-a 12 #x-765321ab)
|
||
|
|
(list (foreign-ref 'int $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000)
|
||
|
|
#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-int-max ~s" $fd-int-max)])
|
||
|
|
; short/unsigned-short
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'short $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'short $fd-a 0 (- $fd-short-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'short $fd-a 0 (+ $fd-short-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 0 (- $fd-short-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 0 (+ $fd-short-max 1)))
|
||
|
|
(case $fd-short-max
|
||
|
|
[(#xffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'short $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'short $fd-a 2 0)
|
||
|
|
(foreign-set! 'short $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'short $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'short $fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'short $fd-a 0)
|
||
|
|
(foreign-ref 'short $fd-a 2)
|
||
|
|
(foreign-ref 'short $fd-a 4)
|
||
|
|
(foreign-ref 'short $fd-a 6)
|
||
|
|
(foreign-ref 'short $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 2 0)
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'short $fd-a 0)
|
||
|
|
(foreign-ref 'short $fd-a 2)
|
||
|
|
(foreign-ref 'short $fd-a 4)
|
||
|
|
(foreign-ref 'short $fd-a 6)
|
||
|
|
(foreign-ref 'short $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'short $fd-a 2 #xabcd)
|
||
|
|
(list (foreign-ref 'short $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 2 -5321)
|
||
|
|
(list (foreign-ref 'short $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)])
|
||
|
|
; long/unsigned-long
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long $fd-a 0 (- $fd-long-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long $fd-a 0 (+ $fd-long-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 0 (- $fd-long-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 0 (+ $fd-long-max 1)))
|
||
|
|
(case $fd-long-max
|
||
|
|
[(#xffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'long $fd-a 4 0)
|
||
|
|
(foreign-set! 'long $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'long $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'long $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'long $fd-a 0)
|
||
|
|
(foreign-ref 'long $fd-a 4)
|
||
|
|
(foreign-ref 'long $fd-a 8)
|
||
|
|
(foreign-ref 'long $fd-a 12)
|
||
|
|
(foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 4 0)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'long $fd-a 0)
|
||
|
|
(foreign-ref 'long $fd-a 4)
|
||
|
|
(foreign-ref 'long $fd-a 8)
|
||
|
|
(foreign-ref 'long $fd-a 12)
|
||
|
|
(foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long $fd-a 12 #xabcd1234)
|
||
|
|
(list (foreign-ref 'long $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234
|
||
|
|
,(- #xabcd1234 #x100000000)
|
||
|
|
#xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 12 #x-765321ab)
|
||
|
|
(list (foreign-ref 'long $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000)
|
||
|
|
#x-765321ab
|
||
|
|
,(+ #x-765321ab #x100000000))))]
|
||
|
|
[(#xffffffffffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'long $fd-a 8 0)
|
||
|
|
(foreign-set! 'long $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'long $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'long $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'long $fd-a 0)
|
||
|
|
(foreign-ref 'long $fd-a 8)
|
||
|
|
(foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'long $fd-a 24)
|
||
|
|
(foreign-ref 'long $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 8 0)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'long $fd-a 0)
|
||
|
|
(foreign-ref 'long $fd-a 8)
|
||
|
|
(foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'long $fd-a 24)
|
||
|
|
(foreign-ref 'long $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long $fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-long-max ~s" $fd-long-max)])
|
||
|
|
; long-long/unsigned-long-long
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long-long $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long-long $fd-a 0 (- $fd-long-long-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'long-long $fd-a 0 (+ $fd-long-long-max 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 0 17.0))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 0 (- $fd-long-long-min 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 0 (+ $fd-long-long-max 1)))
|
||
|
|
(case $fd-long-long-max
|
||
|
|
[(#xffffffffffffffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long-long $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'long-long $fd-a 8 0)
|
||
|
|
(foreign-set! 'long-long $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'long-long $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'long-long $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'long-long $fd-a 0)
|
||
|
|
(foreign-ref 'long-long $fd-a 8)
|
||
|
|
(foreign-ref 'long-long $fd-a 16)
|
||
|
|
(foreign-ref 'long-long $fd-a 24)
|
||
|
|
(foreign-ref 'long-long $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 8 0)
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'long-long $fd-a 0)
|
||
|
|
(foreign-ref 'long-long $fd-a 8)
|
||
|
|
(foreign-ref 'long-long $fd-a 16)
|
||
|
|
(foreign-ref 'long-long $fd-a 24)
|
||
|
|
(foreign-ref 'long-long $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'long-long $fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'long-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-long-long $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'long-long $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-long-long $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-long-long-max ~s" $fd-long-long-max)])
|
||
|
|
; char
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'char $fd-a 0 17))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'char $fd-a 0 (integer->char (+ $fd-char-max 1))))
|
||
|
|
(case $fd-char-max
|
||
|
|
[(#xff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'char $fd-a 2 #\xed)
|
||
|
|
(list (foreign-ref 'char $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 2)))
|
||
|
|
`(#\xed #xed))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'char $fd-a 3 (integer->char 0))
|
||
|
|
(list (foreign-ref 'char $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)))
|
||
|
|
`(#\nul 0))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'char $fd-a 3 (integer->char $fd-char-max))
|
||
|
|
(list (foreign-ref 'char $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)))
|
||
|
|
`(,(integer->char $fd-char-max) ,$fd-char-max)))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-char-max ~s" $fd-char-max)])
|
||
|
|
; wchar
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'wchar $fd-a 0 17))
|
||
|
|
(or (= $fd-wchar-max #x10ffff)
|
||
|
|
(guard (c [#t])
|
||
|
|
(foreign-set! 'wchar $fd-a 0 (integer->char (+ $fd-wchar-max 1)))
|
||
|
|
#f))
|
||
|
|
(case $fd-wchar-max
|
||
|
|
[(#xffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 2 #\xedac)
|
||
|
|
(list (foreign-ref 'wchar $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(#\xedac #xedac))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 2 (integer->char 0))
|
||
|
|
(list (foreign-ref 'wchar $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(#\nul 0))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 2 (integer->char $fd-wchar-max))
|
||
|
|
(list (foreign-ref 'wchar $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(,(integer->char $fd-wchar-max) ,$fd-wchar-max)))]
|
||
|
|
[(#x10ffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 4 #\x10edac)
|
||
|
|
(list (foreign-ref 'wchar $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)))
|
||
|
|
`(#\x10edac #x10edac))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 4 (integer->char 0))
|
||
|
|
(list (foreign-ref 'wchar $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)))
|
||
|
|
`(#\nul 0))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'wchar $fd-a 4 (integer->char $fd-wchar-max))
|
||
|
|
(list (foreign-ref 'wchar $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)))
|
||
|
|
`(,(integer->char $fd-wchar-max) ,$fd-wchar-max)))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-wchar-max ~s" $fd-wchar-max)])
|
||
|
|
; boolean
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'boolean $fd-a 0 #t)
|
||
|
|
(foreign-set! 'boolean $fd-a 8 #f)
|
||
|
|
(foreign-set! 'boolean $fd-a 16 0)
|
||
|
|
(foreign-set! 'int $fd-a 24 64)
|
||
|
|
(list
|
||
|
|
(foreign-ref 'boolean $fd-a 0)
|
||
|
|
(foreign-ref 'boolean $fd-a 8)
|
||
|
|
(foreign-ref 'boolean $fd-a 16)
|
||
|
|
(foreign-ref 'boolean $fd-a 24)
|
||
|
|
(foreign-ref 'int $fd-a 0)
|
||
|
|
(foreign-ref 'int $fd-a 8)
|
||
|
|
(foreign-ref 'int $fd-a 16)
|
||
|
|
(foreign-ref 'int $fd-a 24)))
|
||
|
|
'(#t #f #t #t 1 0 1 64))
|
||
|
|
; fixnum
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'fixnum $fd-a 0 2/3))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'fixnum $fd-a 0 (+ (greatest-fixnum) 1)))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'fixnum $fd-a 0 (- (least-fixnum) 1)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'fixnum $fd-a 0 (greatest-fixnum))
|
||
|
|
(foreign-set! 'fixnum $fd-a 8 (least-fixnum))
|
||
|
|
(foreign-set! 'fixnum $fd-a 16 0)
|
||
|
|
(foreign-set! 'fixnum $fd-a 24 (quotient (greatest-fixnum) 2))
|
||
|
|
(list
|
||
|
|
(foreign-ref 'fixnum $fd-a 0)
|
||
|
|
(foreign-ref 'fixnum $fd-a 8)
|
||
|
|
(foreign-ref 'fixnum $fd-a 16)
|
||
|
|
(foreign-ref 'fixnum $fd-a 24)))
|
||
|
|
`(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
|
||
|
|
; float / single-float
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'float $fd-a 0 17))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'single-float $fd-a 0 17))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'float $fd-a 12 7.5)
|
||
|
|
(list (foreign-ref 'float $fd-a 12)
|
||
|
|
(foreign-ref 'single-float $fd-a 12)))
|
||
|
|
'(7.5 7.5))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'single-float $fd-a 12 7.5)
|
||
|
|
(list (foreign-ref 'float $fd-a 12)
|
||
|
|
(foreign-ref 'single-float $fd-a 12)))
|
||
|
|
'(7.5 7.5))
|
||
|
|
; double / double-float
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'double $fd-a 0 17))
|
||
|
|
(error? ; invalid value for type
|
||
|
|
(foreign-set! 'double-float $fd-a 0 17))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'double $fd-a 8 -5.4)
|
||
|
|
(list (foreign-ref 'double $fd-a 8)
|
||
|
|
(foreign-ref 'double-float $fd-a 8)))
|
||
|
|
'(-5.4 -5.4))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'double-float $fd-a 8 -5.4)
|
||
|
|
(list (foreign-ref 'double $fd-a 8)
|
||
|
|
(foreign-ref 'double-float $fd-a 8)))
|
||
|
|
'(-5.4 -5.4))
|
||
|
|
; spot check unaligned ref/set
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 13 #x-765321ab)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 13)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 13)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000))))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 17 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 17)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 17)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 17)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 21)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 17) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 17)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 21)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 17) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765)))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(case $fd-short-max
|
||
|
|
[(#xffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'short $fd-a 3 #xabcd)
|
||
|
|
(list (foreign-ref 'short $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 3)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 3)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 3 -5321)
|
||
|
|
(list (foreign-ref 'short $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 3)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 3)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'float $fd-a 6 7.5)
|
||
|
|
(list (foreign-ref 'float $fd-a 6)
|
||
|
|
(foreign-ref 'single-float $fd-a 6)))
|
||
|
|
'(7.5 7.5)))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'double-float $fd-a 5 -5.4)
|
||
|
|
(list (foreign-ref 'double $fd-a 5)
|
||
|
|
(foreign-ref 'double-float $fd-a 5)))
|
||
|
|
'(-5.4 -5.4)))
|
||
|
|
; $object-ref
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-8 $fd-a 3 255)
|
||
|
|
(list (#%$object-ref 'integer-8 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 3)))
|
||
|
|
'(-1 255))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 5 -5)
|
||
|
|
(list (#%$object-ref 'integer-8 $raw-fd-a 5)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 5)))
|
||
|
|
'(-5 251))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-8 $fd-a 0 #x-80)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 1 0)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 2 #x7f)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 3 #x80)
|
||
|
|
(foreign-set! 'integer-8 $fd-a 4 #xff)
|
||
|
|
(list (#%$object-ref 'integer-8 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 1)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 1)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 0 #x-80)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 1 0)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 2 #x7f)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 3 #x80)
|
||
|
|
(foreign-set! 'unsigned-8 $fd-a 4 #xff)
|
||
|
|
(list (#%$object-ref 'integer-8 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 1)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'integer-8 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 1)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-8 $raw-fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
; integer-16/unsigned-16
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-16 $fd-a 2 #xabcd)
|
||
|
|
(list (#%$object-ref 'integer-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 2)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 2 -5321)
|
||
|
|
(list (#%$object-ref 'integer-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 2)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-16 $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 2 0)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'integer-16 $fd-a 8 #xffff)
|
||
|
|
(list (#%$object-ref 'integer-16 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 6)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 6)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 0 #x-8000)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 2 0)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 4 #x7fff)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 6 #x8000)
|
||
|
|
(foreign-set! 'unsigned-16 $fd-a 8 #xffff)
|
||
|
|
(list (#%$object-ref 'integer-16 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 6)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 2)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 6)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
; integer-32/unsigned-32
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-32 $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 4 0)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'integer-32 $fd-a 16 #xffffffff)
|
||
|
|
(list (#%$object-ref 'integer-32 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 0 #x-80000000)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 4 0)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 8 #x7fffffff)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 12 #x80000000)
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 16 #xffffffff)
|
||
|
|
(list (#%$object-ref 'integer-32 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'integer-32 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 4)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-32 $fd-a 12 #xabcd1234)
|
||
|
|
(list (#%$object-ref 'integer-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000) #xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 12 #x-765321ab)
|
||
|
|
(list (#%$object-ref 'integer-32 $raw-fd-a 12)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 12)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000)))
|
||
|
|
; integer-64/unsigned-64
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (#%$object-ref 'integer-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 20)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 20)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (#%$object-ref 'integer-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 20)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 16)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 20)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 8 0)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'integer-64 $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (#%$object-ref 'integer-64 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 24)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 32)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 24)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 0 #x-8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 8 0)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 16 #x7fffffffffffffff)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 24 #x8000000000000000)
|
||
|
|
(foreign-set! 'unsigned-64 $fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (#%$object-ref 'integer-64 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 24)
|
||
|
|
(#%$object-ref 'integer-64 $raw-fd-a 32)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 24)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
; fixnum
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'fixnum $fd-a 0 (greatest-fixnum))
|
||
|
|
(foreign-set! 'fixnum $fd-a 8 (least-fixnum))
|
||
|
|
(foreign-set! 'fixnum $fd-a 16 0)
|
||
|
|
(foreign-set! 'fixnum $fd-a 24 (quotient (greatest-fixnum) 2))
|
||
|
|
(list
|
||
|
|
(#%$object-ref 'fixnum $raw-fd-a 0)
|
||
|
|
(#%$object-ref 'fixnum $raw-fd-a 8)
|
||
|
|
(#%$object-ref 'fixnum $raw-fd-a 16)
|
||
|
|
(#%$object-ref 'fixnum $raw-fd-a 24)))
|
||
|
|
`(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
|
||
|
|
; single-float
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'single-float $fd-a 12 7.5)
|
||
|
|
(#%$object-ref 'single-float $raw-fd-a 12))
|
||
|
|
7.5)
|
||
|
|
; double-float
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'double-float $fd-a 8 -5.4)
|
||
|
|
(#%$object-ref 'double-float $raw-fd-a 8))
|
||
|
|
-5.4)
|
||
|
|
; spot check unaligned ref/set
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-32 $fd-a 13 #x-765321ab)
|
||
|
|
(list (#%$object-ref 'integer-32 $raw-fd-a 13)
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 13)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000))))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'integer-64 $fd-a 17 #xabcd1234ffee8765)
|
||
|
|
(list (#%$object-ref 'integer-64 $raw-fd-a 17)
|
||
|
|
(#%$object-ref 'unsigned-64 $raw-fd-a 17)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 17)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 21)
|
||
|
|
(ash (#%$object-ref 'integer-32 $raw-fd-a 17) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 17)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(#%$object-ref 'unsigned-32 $raw-fd-a 21)
|
||
|
|
(ash (#%$object-ref 'unsigned-32 $raw-fd-a 17) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765)))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(case $fd-short-max
|
||
|
|
[(#xffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'short $fd-a 3 #xabcd)
|
||
|
|
(list (#%$object-ref 'short $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-short $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 3)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'unsigned-short $fd-a 3 -5321)
|
||
|
|
(list (#%$object-ref 'short $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-short $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'integer-16 $raw-fd-a 3)
|
||
|
|
(#%$object-ref 'unsigned-16 $raw-fd-a 3)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'single-float $fd-a 6 7.5)
|
||
|
|
(#%$object-ref 'single-float $raw-fd-a 6))
|
||
|
|
7.5))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(foreign-set! 'double-float $fd-a 5 -5.4)
|
||
|
|
(#%$object-ref 'double-float $raw-fd-a 5))
|
||
|
|
-5.4))
|
||
|
|
|
||
|
|
; $object-set!
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 3 255)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)))
|
||
|
|
'(-1 255))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 5 -5)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 5)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 5)))
|
||
|
|
'(-5 251))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 0 #x-80)
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 1 0)
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 2 #x7f)
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 3 #x80)
|
||
|
|
(#%$object-set! 'integer-8 $raw-fd-a 4 #xff)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 1)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 1)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 0 #x-80)
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 1 0)
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 2 #x7f)
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 3 #x80)
|
||
|
|
(#%$object-set! 'unsigned-8 $raw-fd-a 4 #xff)
|
||
|
|
(list (foreign-ref 'integer-8 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 1)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 3)
|
||
|
|
(foreign-ref 'integer-8 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 1)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-8 $fd-a 4)))
|
||
|
|
`(#x-80 0 #x7f #x-80 -1
|
||
|
|
#x80 0 #x7f #x80 #xff))
|
||
|
|
; integer-16/unsigned-16
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 2 #xabcd)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 2 -5321)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 0 #x-8000)
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 2 0)
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 4 #x7fff)
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 6 #x8000)
|
||
|
|
(#%$object-set! 'integer-16 $raw-fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 6)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 0 #x-8000)
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 2 0)
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 4 #x7fff)
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 6 #x8000)
|
||
|
|
(#%$object-set! 'unsigned-16 $raw-fd-a 8 #xffff)
|
||
|
|
(list (foreign-ref 'integer-16 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 2)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 6)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 2)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 6)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 8)))
|
||
|
|
`(#x-8000 0 #x7fff #x-8000 -1
|
||
|
|
#x8000 0 #x7fff #x8000 #xffff))
|
||
|
|
; integer-32/unsigned-32
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 0 #x-80000000)
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 4 0)
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 8 #x7fffffff)
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 12 #x80000000)
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 0 #x-80000000)
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 4 0)
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 8 #x7fffffff)
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 12 #x80000000)
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 16 #xffffffff)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 4)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'integer-32 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 4)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)))
|
||
|
|
`(#x-80000000 0 #x7fffffff #x-80000000 -1
|
||
|
|
#x80000000 0 #x7fffffff #x80000000 #xffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-32 $raw-fd-a 12 #xabcd1234)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(,(- #xabcd1234 #x100000000) #xabcd1234))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 12 #x-765321ab)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 12)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 12)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000)))
|
||
|
|
; integer-64/unsigned-64
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 16 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 16 #x-765321ab4c8e9de1)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 16) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 16)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 20) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 20)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 16) 32)))))
|
||
|
|
`(#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)
|
||
|
|
#x-765321ab4c8e9de1
|
||
|
|
,(+ #x-765321ab4c8e9de1 #x10000000000000000)))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 0 #x-8000000000000000)
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 8 0)
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 16 #x7fffffffffffffff)
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 24 #x8000000000000000)
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 24)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 0 #x-8000000000000000)
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 8 0)
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 16 #x7fffffffffffffff)
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 24 #x8000000000000000)
|
||
|
|
(#%$object-set! 'unsigned-64 $raw-fd-a 32 #xffffffffffffffff)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 0)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 8)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 16)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 24)
|
||
|
|
(foreign-ref 'integer-64 $fd-a 32)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 0)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 8)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 16)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 24)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 32)))
|
||
|
|
`(#x-8000000000000000 0 #x7fffffffffffffff #x-8000000000000000 -1
|
||
|
|
#x8000000000000000 0 #x7fffffffffffffff #x8000000000000000 #xffffffffffffffff))
|
||
|
|
; fixnum
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'fixnum $raw-fd-a 0 (greatest-fixnum))
|
||
|
|
(#%$object-set! 'fixnum $raw-fd-a 8 (least-fixnum))
|
||
|
|
(#%$object-set! 'fixnum $raw-fd-a 16 0)
|
||
|
|
(#%$object-set! 'fixnum $raw-fd-a 24 (quotient (greatest-fixnum) 2))
|
||
|
|
(list
|
||
|
|
(foreign-ref 'fixnum $fd-a 0)
|
||
|
|
(foreign-ref 'fixnum $fd-a 8)
|
||
|
|
(foreign-ref 'fixnum $fd-a 16)
|
||
|
|
(foreign-ref 'fixnum $fd-a 24)))
|
||
|
|
`(,(greatest-fixnum) ,(least-fixnum) 0 ,(quotient (greatest-fixnum) 2)))
|
||
|
|
; single-float
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'single-float $raw-fd-a 12 7.5)
|
||
|
|
(foreign-ref 'single-float $fd-a 12))
|
||
|
|
7.5)
|
||
|
|
; double-float
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'double-float $raw-fd-a 8 -5.4)
|
||
|
|
(foreign-ref 'double-float $fd-a 8))
|
||
|
|
-5.4)
|
||
|
|
; spot check unaligned ref/set
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-32 $raw-fd-a 13 #x-765321ab)
|
||
|
|
(list (foreign-ref 'integer-32 $fd-a 13)
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 13)))
|
||
|
|
`(#x-765321ab ,(+ #x-765321ab #x100000000))))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'integer-64 $raw-fd-a 17 #xabcd1234ffee8765)
|
||
|
|
(list (foreign-ref 'integer-64 $fd-a 17)
|
||
|
|
(foreign-ref 'unsigned-64 $fd-a 17)
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 17)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 21)
|
||
|
|
(ash (foreign-ref 'integer-32 $fd-a 17) 32)))
|
||
|
|
(if (eq? (native-endianness) 'little)
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 17)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 21) 32))
|
||
|
|
(logor
|
||
|
|
(foreign-ref 'unsigned-32 $fd-a 21)
|
||
|
|
(ash (foreign-ref 'unsigned-32 $fd-a 17) 32)))))
|
||
|
|
`(,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765
|
||
|
|
,(- #xabcd1234ffee8765 #x10000000000000000)
|
||
|
|
#xabcd1234ffee8765)))
|
||
|
|
(or (not $fd-unaligned-integers)
|
||
|
|
(case $fd-short-max
|
||
|
|
[(#xffff)
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'short $raw-fd-a 3 #xabcd)
|
||
|
|
(list (foreign-ref 'short $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 3)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 3)))
|
||
|
|
`(,(- #xabcd #x10000) #xabcd ,(- #xabcd #x10000) #xabcd))
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'unsigned-short $raw-fd-a 3 -5321)
|
||
|
|
(list (foreign-ref 'short $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-short $fd-a 3)
|
||
|
|
(foreign-ref 'integer-16 $fd-a 3)
|
||
|
|
(foreign-ref 'unsigned-16 $fd-a 3)))
|
||
|
|
`(-5321 ,(+ -5321 #x10000) -5321 ,(+ -5321 #x10000))))]
|
||
|
|
[else (error 'foreign-data-mat "unexpected $fd-short-max ~s" $fd-short-max)]))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'single-float $raw-fd-a 6 7.5)
|
||
|
|
(foreign-ref 'single-float $fd-a 6))
|
||
|
|
7.5))
|
||
|
|
(or (not $fd-unaligned-floats)
|
||
|
|
(equal?
|
||
|
|
(begin
|
||
|
|
(#%$object-set! 'double-float $raw-fd-a 5 -5.4)
|
||
|
|
(foreign-ref 'double-float $fd-a 5))
|
||
|
|
-5.4))
|
||
|
|
|
||
|
|
; this needs to be done last
|
||
|
|
(begin
|
||
|
|
(set! $raw-fd-a #f)
|
||
|
|
(set! $fd-a #f)
|
||
|
|
(foreign-free $real-fd-a)
|
||
|
|
(set! $real-fd-a #f)
|
||
|
|
#t)
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat $integer-xxx?
|
||
|
|
(not (#%$integer-8? 'a))
|
||
|
|
(not (#%$integer-16? '3.4))
|
||
|
|
(not (#%$integer-32? '3/4))
|
||
|
|
(not (#%$integer-64? '4+3i))
|
||
|
|
(not (#%$integer-8? #x-10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-8? #x-81))
|
||
|
|
(#%$integer-8? #x-80)
|
||
|
|
(#%$integer-8? #x-1)
|
||
|
|
(#%$integer-8? #x7f)
|
||
|
|
(#%$integer-8? #x80)
|
||
|
|
(#%$integer-8? #xff)
|
||
|
|
(not (#%$integer-8? #x100))
|
||
|
|
(not (#%$integer-8? #x+10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-16? #x-10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-16? #x-8001))
|
||
|
|
(#%$integer-16? #x-8000)
|
||
|
|
(#%$integer-16? #x-1)
|
||
|
|
(#%$integer-16? #x7fff)
|
||
|
|
(#%$integer-16? #x8000)
|
||
|
|
(#%$integer-16? #xffff)
|
||
|
|
(not (#%$integer-16? #x10000))
|
||
|
|
(not (#%$integer-16? #x+10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-32? #x-10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-32? #x-80000001))
|
||
|
|
(#%$integer-32? #x-80000000)
|
||
|
|
(#%$integer-32? #x-1)
|
||
|
|
(#%$integer-32? #x7fffffff)
|
||
|
|
(#%$integer-32? #x80000000)
|
||
|
|
(#%$integer-32? #xffffffff)
|
||
|
|
(not (#%$integer-32? #x100000000))
|
||
|
|
(not (#%$integer-32? #x+10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-64? #x-10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
(not (#%$integer-64? #x-8000000000000001))
|
||
|
|
(#%$integer-64? #x-8000000000000000)
|
||
|
|
(#%$integer-64? #x-1)
|
||
|
|
(#%$integer-64? #x7fffffffffffffff)
|
||
|
|
(#%$integer-64? #x8000000000000000)
|
||
|
|
(#%$integer-64? #xffffffffffffffff)
|
||
|
|
(not (#%$integer-64? #x10000000000000000))
|
||
|
|
(not (#%$integer-64? #x+10000000000000000000000000000000000000000000000000000000000000000))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat object-address
|
||
|
|
(equal?
|
||
|
|
(with-interrupts-disabled ; or lock r
|
||
|
|
(let ()
|
||
|
|
(import $system)
|
||
|
|
(define-syntax record-field-address
|
||
|
|
(lambda (x)
|
||
|
|
(define-syntax datum
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ x) (syntax-object->datum #'x)]))
|
||
|
|
(define rtd-flds
|
||
|
|
(csv7:record-field-accessor
|
||
|
|
(record-rtd (make-record-type "foo" '()))
|
||
|
|
'flds))
|
||
|
|
; fld structure is vector: #5(fld name mutable type offset)
|
||
|
|
(define fld-check
|
||
|
|
(lambda (who x)
|
||
|
|
(unless (and (vector? x)
|
||
|
|
(= (vector-length x) 5)
|
||
|
|
(eq? (vector-ref x 0) 'fld))
|
||
|
|
(errorf who "~s is not a fld" x))))
|
||
|
|
(define fld-name
|
||
|
|
(lambda (x) (fld-check 'fld-name x) (vector-ref x 1)))
|
||
|
|
(define fld-mutable?
|
||
|
|
(lambda (x) (fld-check 'fld-mutable? x) (vector-ref x 2)))
|
||
|
|
(define fld-type
|
||
|
|
(lambda (x) (fld-check 'fld-type x) (vector-ref x 3)))
|
||
|
|
(define fld-byte
|
||
|
|
(lambda (x) (fld-check 'fld-byte x) (vector-ref x 4)))
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ recid record field-name)
|
||
|
|
(and (identifier? #'recid) (identifier? #'field-name))
|
||
|
|
(lambda (r)
|
||
|
|
(let ([rinfo (r #'recid)])
|
||
|
|
(unless (and (pair? rinfo)
|
||
|
|
(eq? (car rinfo) '#{record val9xfsq6oa12q4-a})
|
||
|
|
(record-type-descriptor? (cadr rinfo)))
|
||
|
|
(syntax-error #'recid "unrecognized record"))
|
||
|
|
(let ([rtd (cadr rinfo)])
|
||
|
|
(with-syntax ([offset
|
||
|
|
(or (let ([field-name (datum field-name)])
|
||
|
|
(ormap
|
||
|
|
(lambda (fld)
|
||
|
|
(and (eq? (fld-name fld) field-name)
|
||
|
|
(fld-byte fld)))
|
||
|
|
(rtd-flds rtd)))
|
||
|
|
(syntax-error
|
||
|
|
"unrecognized field name"
|
||
|
|
#'field-name))])
|
||
|
|
#'($object-address record offset)))))])))
|
||
|
|
(define-record foo ((integer-32 x) (double-float y)))
|
||
|
|
(let* ([r (make-foo 666 66.6)]
|
||
|
|
[x (record-field-address foo r x)]
|
||
|
|
[y (record-field-address foo r y)])
|
||
|
|
(let ([t1 (foreign-ref 'integer-32 x 0)]
|
||
|
|
[t2 (foreign-ref 'double-float y 0)])
|
||
|
|
(foreign-set! 'integer-32 x 0 -1)
|
||
|
|
(foreign-set! 'double-float y 0 .25)
|
||
|
|
(list t1 t2 (foo-x r) (foo-y r))))))
|
||
|
|
'(666 66.6 -1 .25))
|
||
|
|
(#%$address-in-heap? (#%$object-address cons 0))
|
||
|
|
(not (#%$address-in-heap? 0))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record-inheritance
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record soy ([double-float milk]))
|
||
|
|
(define-record toast soy (y))
|
||
|
|
(let ([x (make-toast #0=3.4 #1="hello")])
|
||
|
|
(list (soy-milk x) (toast-y x))))
|
||
|
|
'(#0# #1#))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record soy ([double-float milk]))
|
||
|
|
(define-record toast soy (y))
|
||
|
|
(let ([x (make-toast 3.4 "hello")])
|
||
|
|
(list (soy-milk x) (toast-y x))))))
|
||
|
|
`(let ([x (let ([y (#3%$record ',record-type-descriptor? . ,list?)])
|
||
|
|
(#3%$object-set! 'double-float y ,fixnum? 3.4)
|
||
|
|
y)])
|
||
|
|
(#2%list
|
||
|
|
(#3%$object-ref 'double-float x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record soy ([double-float milk]))
|
||
|
|
(define-record toast soy (y))
|
||
|
|
(let ([x (make-toast 3.4 "hello")])
|
||
|
|
(list (soy-milk x) (toast-y x))))))
|
||
|
|
`(let ([x (let ([y (#3%$record ',record-type-descriptor? . ,list?)])
|
||
|
|
(#3%$object-set! 'double-float y ,fixnum? 3.4)
|
||
|
|
y)])
|
||
|
|
(#3%list
|
||
|
|
(#3%$object-ref 'double-float x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?))))
|
||
|
|
(let ()
|
||
|
|
(define-record p (x))
|
||
|
|
(define-record c p (x))
|
||
|
|
(let ()
|
||
|
|
(define prtd (record-rtd (make-p 1)))
|
||
|
|
(define crtd (record-rtd (make-c 1 2)))
|
||
|
|
(let ()
|
||
|
|
(define px1a (csv7:record-field-accessor prtd 'x))
|
||
|
|
(define px1b (csv7:record-field-accessor prtd 0))
|
||
|
|
(define cx1b (csv7:record-field-accessor crtd 0))
|
||
|
|
(define cx2a (csv7:record-field-accessor crtd 'x))
|
||
|
|
(define cx2b (csv7:record-field-accessor crtd 1))
|
||
|
|
(define d1 (cons 1 2))
|
||
|
|
(define d2 (cons 3 4))
|
||
|
|
(let ()
|
||
|
|
(define r (make-c d1 d2))
|
||
|
|
(and (eq? (p-x r) d1)
|
||
|
|
(eq? (px1a r) (p-x r))
|
||
|
|
(eq? (px1b r) (p-x r))
|
||
|
|
(eq? (cx1b r) (p-x r))
|
||
|
|
(eq? (c-x r) d2)
|
||
|
|
(eq? (cx2a r) (c-x r))
|
||
|
|
(eq? (cx2b r) (c-x r)))))))
|
||
|
|
(let ()
|
||
|
|
(define-record p (x))
|
||
|
|
(define-record c p (x))
|
||
|
|
(record-reader 'c (record-rtd (make-c 1 2)))
|
||
|
|
(let ([r1 (read (open-input-string "#[c #0=(a b) #0#]"))]
|
||
|
|
[r2 (read (open-input-string "#0=#[c #0# 0]"))]
|
||
|
|
[r3 (read (open-input-string "#0=#[c 0 #0#]"))]
|
||
|
|
[r4 (read (open-input-string "#0=#[c #0# #0#]"))])
|
||
|
|
(and (eq? (p-x r1) (c-x r1))
|
||
|
|
(eq? (p-x r2) r2)
|
||
|
|
(eq? (c-x r2) 0)
|
||
|
|
(eq? (p-x r3) 0)
|
||
|
|
(eq? (c-x r3) r3)
|
||
|
|
(eq? (p-x r4) r4)
|
||
|
|
(eq? (c-x r4) r4))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record p (x))
|
||
|
|
(define-record c p (x))
|
||
|
|
(record-reader 'c (record-rtd (make-c 1 2)))
|
||
|
|
(let ([r1 (read (open-input-string "#[c #0=(a b) #0#]"))]
|
||
|
|
[r2 (read (open-input-string "#0=#[c #0# 0]"))]
|
||
|
|
[r3 (read (open-input-string "#0=#[c 0 #0#]"))]
|
||
|
|
[r4 (read (open-input-string "#0=#[c #0# #0#]"))])
|
||
|
|
(and (eq? (p-x r1) (c-x r1))
|
||
|
|
(eq? (p-x r2) r2)
|
||
|
|
(eq? (c-x r2) 0)
|
||
|
|
(eq? (p-x r3) 0)
|
||
|
|
(eq? (c-x r3) r3)
|
||
|
|
(eq? (p-x r4) r4)
|
||
|
|
(eq? (c-x r4) r4))))))
|
||
|
|
`(begin
|
||
|
|
(#3%record-reader 'c ',record-type-descriptor?)
|
||
|
|
(let ([r1 (#3%read (#3%open-input-string "#[c #0=(a b) #0#]"))]
|
||
|
|
[r2 (#3%read (#3%open-input-string "#0=#[c #0# 0]"))]
|
||
|
|
[r3 (#3%read (#3%open-input-string "#0=#[c 0 #0#]"))]
|
||
|
|
[r4 (#3%read (#3%open-input-string "#0=#[c #0# #0#]"))])
|
||
|
|
(if (#3%eq?
|
||
|
|
(#3%$object-ref 'scheme-object r1 ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object r1 ,fixnum?))
|
||
|
|
(if (#3%eq? (#3%$object-ref 'scheme-object r2 ,fixnum?) r2)
|
||
|
|
(if (#3%eq? (#3%$object-ref 'scheme-object r2 ,fixnum?) 0)
|
||
|
|
(if (#3%eq? (#3%$object-ref 'scheme-object r3 ,fixnum?) 0)
|
||
|
|
(if (#3%eq? (#3%$object-ref 'scheme-object r3 ,fixnum?) r3)
|
||
|
|
(if (#3%eq? (#3%$object-ref 'scheme-object r4 ,fixnum?) r4)
|
||
|
|
(#3%eq? (#3%$object-ref 'scheme-object r4 ,fixnum?) r4)
|
||
|
|
#f)
|
||
|
|
#f)
|
||
|
|
#f)
|
||
|
|
#f)
|
||
|
|
#f)
|
||
|
|
#f))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record-writer
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type sp (fields lat))
|
||
|
|
(record-writer (type-descriptor sp)
|
||
|
|
(lambda (x p w) (w (sp-lat x) p)))
|
||
|
|
(pretty-print (list (make-sp 'ugh)))))
|
||
|
|
"(ugh)\n")
|
||
|
|
(error? ; 'sp is not an rtd
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type sp (fields lat))
|
||
|
|
(record-writer 'sp
|
||
|
|
(lambda (x p w) (w (sp-lat x) p))))))
|
||
|
|
(error? ; "oops" is not a procedure
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type sp (fields lat))
|
||
|
|
(record-writer (type-descriptor sp) "oops"))))
|
||
|
|
(error? ; ugh is not a textual output port
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type sp (fields lat))
|
||
|
|
(record-writer (type-descriptor sp)
|
||
|
|
(lambda (x p w) (w p (sp-lat x))))
|
||
|
|
(pretty-print (list (make-sp 'ugh))))))
|
||
|
|
(error? ; procedure not a textual output port
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type sp (fields lat))
|
||
|
|
(record-writer (type-descriptor sp)
|
||
|
|
(lambda (x p w) (w (sp-lat x) w)))
|
||
|
|
(pretty-print (list (make-sp 'ugh))))))
|
||
|
|
(begin
|
||
|
|
(define-record $froz (a b) ([c (+ a b)]))
|
||
|
|
(define-record $fruz $froz (d))
|
||
|
|
(define-record $friz $fruz ())
|
||
|
|
(define-record $fraz $friz ())
|
||
|
|
(record-writer (type-descriptor $fraz)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "<fraz>" p)))
|
||
|
|
(record-writer (type-descriptor $froz)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(wr `(* hi john ,($froz-c x) *) p)))
|
||
|
|
(and (equal? (format "~s" (make-$froz 17 23)) "(* hi john 40 *)")
|
||
|
|
(equal? (format "~s" (make-$fruz 17 24 37)) "(* hi john 41 *)")
|
||
|
|
(equal? (format "~s" (make-$friz 17 25 38)) "(* hi john 42 *)")
|
||
|
|
(equal? (format "~s" (make-$fraz 17 26 39)) "<fraz>")))
|
||
|
|
(begin
|
||
|
|
(record-writer (type-descriptor $froz)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(fprintf p "<$froz c=~s>" ($froz-c x))))
|
||
|
|
(and (equal? (format "~s" (make-$froz 18 23)) "<$froz c=41>")
|
||
|
|
(equal? (format "~s" (make-$fruz 18 24 37)) "<$froz c=42>")
|
||
|
|
(equal? (format "~s" (make-$friz 18 25 38)) "<$froz c=43>")
|
||
|
|
(equal? (format "~s" (make-$fraz 18 26 39)) "<fraz>")))
|
||
|
|
(begin
|
||
|
|
(record-writer (type-descriptor $fruz)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(fprintf p "<$fruz d=~s>" ($fruz-d x))))
|
||
|
|
(and (equal? (format "~s" (make-$froz 19 23)) "<$froz c=42>")
|
||
|
|
(equal? (format "~s" (make-$fruz 19 24 37)) "<$fruz d=37>")
|
||
|
|
(equal? (format "~s" (make-$friz 19 25 38)) "<$fruz d=38>")
|
||
|
|
(equal? (format "~s" (make-$fraz 18 26 39)) "<fraz>")))
|
||
|
|
(let ()
|
||
|
|
(define-record pair ((mutable car) (immutable cdr))
|
||
|
|
()
|
||
|
|
((constructor cons) (prefix "")))
|
||
|
|
(record-writer (type-descriptor pair)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "(" p) ; )
|
||
|
|
(wr (car x) p)
|
||
|
|
(display " . " p)
|
||
|
|
(wr (cdr x) p) ; (
|
||
|
|
(display ")" p)))
|
||
|
|
(and (pair? (cons 3 4))
|
||
|
|
(not (pair? '(3 . 4)))
|
||
|
|
(eq? (car (cons 3 4)) 3)
|
||
|
|
(eq? (cdr (cons 3 4)) 4)
|
||
|
|
(equal? (format "~s" (cons 3 (cons 4 '()))) "(3 . (4 . ()))")
|
||
|
|
(let ((x (cons 3 4)))
|
||
|
|
(set-car! x x)
|
||
|
|
(equal? (format "~s" x) "#0=(#0# . 4)"))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record-equal/hash
|
||
|
|
(begin
|
||
|
|
(define (equiv? v1 v2)
|
||
|
|
(and (equal? v1 v2)
|
||
|
|
(= (equal-hash v1) (equal-hash v2))
|
||
|
|
(let ([ht (make-hashtable equal-hash equal?)])
|
||
|
|
(hashtable-set! ht v1 "yes")
|
||
|
|
(equal? "yes" (hashtable-ref ht v2 "no")))))
|
||
|
|
|
||
|
|
(define (not-equiv? v1 v2)
|
||
|
|
(and (not (equal? v1 v2))
|
||
|
|
(let ([ht (make-hashtable equal-hash equal?)])
|
||
|
|
(hashtable-set! ht v1 "yes")
|
||
|
|
(equal? "no" (hashtable-ref ht v2 "no")))))
|
||
|
|
|
||
|
|
(define-record-type E+H$a
|
||
|
|
(fields (mutable x)
|
||
|
|
(immutable y)))
|
||
|
|
|
||
|
|
(define-record-type E+H$a+
|
||
|
|
(parent E+H$a)
|
||
|
|
(fields (mutable z)))
|
||
|
|
|
||
|
|
(define-record-type E+H$b
|
||
|
|
(fields (immutable x)
|
||
|
|
(mutable y))
|
||
|
|
(opaque #t))
|
||
|
|
|
||
|
|
(define-record-type E+H$b+
|
||
|
|
(parent E+H$b)
|
||
|
|
(fields (mutable z))
|
||
|
|
(opaque #t))
|
||
|
|
|
||
|
|
(define (E+H$a-equal? a1 a2 eql?)
|
||
|
|
(eql? (E+H$a-x a1) (E+H$a-x a2)))
|
||
|
|
(define (E+H$a-hash a hc)
|
||
|
|
(hc (E+H$a-x a)))
|
||
|
|
|
||
|
|
(define (E+H$b-equal? b1 b2 eql?)
|
||
|
|
(eql? (E+H$b-y b1) (E+H$b-y b2)))
|
||
|
|
(define (E+H$b-hash b hc)
|
||
|
|
(hc (E+H$b-y b)))
|
||
|
|
|
||
|
|
(define cyclic-E+H$a1 (make-E+H$a 1 2))
|
||
|
|
(E+H$a-x-set! cyclic-E+H$a1 cyclic-E+H$a1)
|
||
|
|
(define cyclic-E+H$a2 (make-E+H$a 1 2))
|
||
|
|
(E+H$a-x-set! cyclic-E+H$a2 cyclic-E+H$a2)
|
||
|
|
|
||
|
|
(define cyclic-E+H$b+1 (make-E+H$b+ 1 2 3))
|
||
|
|
(define cyclic-E+H$b+2 (make-E+H$b+ 1 2 3))
|
||
|
|
(E+H$b-y-set! cyclic-E+H$b+1 (list 1 2 3 (box cyclic-E+H$b+2)))
|
||
|
|
(E+H$b-y-set! cyclic-E+H$b+2 (list 1 2 3 (box cyclic-E+H$b+1)))
|
||
|
|
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(not-equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
|
||
|
|
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
|
||
|
|
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$a)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$a)))
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$b)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$b)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
|
||
|
|
(eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a 1 2)) E+H$a-equal?)
|
||
|
|
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
|
||
|
|
(eq? (record-equal-procedure (make-E+H$a 1 2) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
|
||
|
|
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a+ 1 3 5)) E+H$a-equal?)
|
||
|
|
(eq? (record-hash-procedure (make-E+H$a 1 2)) E+H$a-hash)
|
||
|
|
(eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
|
||
|
|
(equiv? (make-E+H$a 1 2) (make-E+H$a 1 2))
|
||
|
|
(equiv? (make-E+H$a 1 2) (make-E+H$a 1 3))
|
||
|
|
|
||
|
|
(equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
|
||
|
|
(equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
|
||
|
|
|
||
|
|
(not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a 1 2))
|
||
|
|
(not-equiv? (make-E+H$a+ 2 3 5) (make-E+H$a+ 1 2 4))
|
||
|
|
|
||
|
|
(not (equiv? (make-E+H$a 1 2) (make-E+H$b 1 2)))
|
||
|
|
|
||
|
|
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
|
||
|
|
(not-equiv? (make-E+H$b+ 1 2 3) (make-E+H$b+ 1 2 3))
|
||
|
|
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$b+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$b+)))
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$b)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$b)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$b+) E+H$b-equal?)
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$b+) E+H$b-hash)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(not-equiv? (make-E+H$b 1 2) (make-E+H$b 1 2))
|
||
|
|
(equiv? (make-E+H$b+ 0 2 4) (make-E+H$b+ 1 2 3))
|
||
|
|
|
||
|
|
(equiv? cyclic-E+H$a1 cyclic-E+H$a2)
|
||
|
|
(equiv? cyclic-E+H$a1 (make-E+H$a cyclic-E+H$a2 3))
|
||
|
|
|
||
|
|
(equiv? cyclic-E+H$b+1 cyclic-E+H$b+2)
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$a+) E+H$a-equal?)
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$a+) E+H$a-hash)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(eq? (record-type-equal-procedure (record-type-descriptor E+H$a)) E+H$a-equal?)
|
||
|
|
(eq? (record-type-hash-procedure (record-type-descriptor E+H$a)) E+H$a-hash)
|
||
|
|
|
||
|
|
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
|
||
|
|
(not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
|
||
|
|
(not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$a) E+H$a-equal?)
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$a) E+H$a-hash)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(not (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)))
|
||
|
|
|
||
|
|
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
|
||
|
|
(not-equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
|
||
|
|
(not-equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$a+) #f)
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$a+) #f)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor E+H$a+)))
|
||
|
|
|
||
|
|
(eq? (record-equal-procedure (make-E+H$a+ 1 3 5) (make-E+H$a 1 2)) E+H$a-equal?)
|
||
|
|
(eq? (record-hash-procedure (make-E+H$a+ 1 3 5)) E+H$a-hash)
|
||
|
|
|
||
|
|
(equiv? (make-E+H$a+ 1 3 5) (make-E+H$a 1 2))
|
||
|
|
(equiv? (make-E+H$a 1 2) (make-E+H$a+ 1 3 5))
|
||
|
|
(equiv? (make-E+H$a+ 1 2 4) (make-E+H$a+ 1 3 5))
|
||
|
|
|
||
|
|
(error? ; not an rtd
|
||
|
|
(record-type-equal-procedure 7))
|
||
|
|
(error? ; not an rtd
|
||
|
|
(record-type-equal-procedure 7 (lambda (x y e?) #f)))
|
||
|
|
(error? ; not a procedure or #f
|
||
|
|
(record-type-equal-procedure (record-type-descriptor E+H$a+) 7))
|
||
|
|
(error? ; not an rtd
|
||
|
|
(record-type-hash-procedure 7))
|
||
|
|
(error? ; not an rtd
|
||
|
|
(record-type-hash-procedure 7 (lambda (x y e?) #f)))
|
||
|
|
(error? ; not a procedure or #f
|
||
|
|
(record-type-hash-procedure (record-type-descriptor E+H$a+) 7))
|
||
|
|
(error? ; not a record
|
||
|
|
(record-equal-procedure 7 (make-E+H$a 1 2)))
|
||
|
|
(error? ; not a record
|
||
|
|
(record-equal-procedure (make-E+H$a 1 2) 7))
|
||
|
|
(error? ; not a record
|
||
|
|
(record-hash-procedure 7))
|
||
|
|
|
||
|
|
; csug examples
|
||
|
|
(begin
|
||
|
|
(define-record marble (color quality))
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor marble)))
|
||
|
|
(not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'medium)))
|
||
|
|
(not (equal? (make-marble 'blue 'medium) (make-marble 'blue 'high)))
|
||
|
|
|
||
|
|
; Treat marbles as equal when they have the same color
|
||
|
|
(begin
|
||
|
|
(record-type-equal-procedure (record-type-descriptor marble)
|
||
|
|
(lambda (m1 m2 eql?)
|
||
|
|
(eql? (marble-color m1) (marble-color m2))))
|
||
|
|
(record-type-hash-procedure (record-type-descriptor marble)
|
||
|
|
(lambda (m hash)
|
||
|
|
(hash (marble-color m))))
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(equal? (make-marble 'blue 'medium) (make-marble 'blue 'high))
|
||
|
|
(not (equal? (make-marble 'red 'high) (make-marble 'blue 'high)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define ht (make-hashtable equal-hash equal?))
|
||
|
|
(hashtable-set! ht (make-marble 'blue 'medium) "glass")
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(equal? (hashtable-ref ht (make-marble 'blue 'high) #f) "glass")
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record shooter marble (size))
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(equal? (make-marble 'blue 'medium) (make-shooter 'blue 'large 17)) ;=> #t
|
||
|
|
(equal? (make-shooter 'blue 'large 17) (make-marble 'blue 'medium)) ;=> #t
|
||
|
|
(equal? (hashtable-ref ht (make-shooter 'blue 'high 17) #f) "glass")
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type node
|
||
|
|
(nongenerative)
|
||
|
|
(fields (mutable left) (mutable right)))
|
||
|
|
(record-type-equal-procedure (record-type-descriptor node)
|
||
|
|
(lambda (x y e?)
|
||
|
|
(and
|
||
|
|
(e? (node-left x) (node-left y))
|
||
|
|
(e? (node-right x) (node-right y)))))
|
||
|
|
(record-type-hash-procedure (record-type-descriptor marble)
|
||
|
|
(lambda (x hash)
|
||
|
|
(+ (hash (node-left x)) (hash (node-right x)) 23)))
|
||
|
|
(define graph1
|
||
|
|
(let ([x (make-node "a" (make-node #f "b"))])
|
||
|
|
(node-left-set! (node-right x) x)
|
||
|
|
x))
|
||
|
|
(define graph2
|
||
|
|
(let ([x (make-node "a" (make-node (make-node "a" #f) "b"))])
|
||
|
|
(node-right-set! (node-left (node-right x)) (node-right x))
|
||
|
|
x))
|
||
|
|
(define graph3
|
||
|
|
(let ([x (make-node "a" (make-node #f "c"))])
|
||
|
|
(node-left-set! (node-right x) x)
|
||
|
|
x))
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(equal? graph1 graph2)
|
||
|
|
(not (equal? graph1 graph3))
|
||
|
|
(not (equal? graph2 graph3))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define h (make-hashtable equal-hash equal?))
|
||
|
|
(hashtable-set! h graph1 #t)
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(hashtable-ref h graph1 #f)
|
||
|
|
(hashtable-ref h graph2 #f)
|
||
|
|
(not (hashtable-ref h graph3 #f))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define record-hash
|
||
|
|
(lambda (x hash)
|
||
|
|
(let ([rtd (record-rtd x)])
|
||
|
|
(do ([field-name* (csv7:record-type-field-names rtd) (cdr field-name*)]
|
||
|
|
[i 0 (fx+ i 1)]
|
||
|
|
[h 0 (+ h (hash ((csv7:record-field-accessor rtd i) x)))])
|
||
|
|
((null? field-name*) h)))))
|
||
|
|
(define record-equal?
|
||
|
|
(lambda (x y e?)
|
||
|
|
(let ([rtd (record-rtd x)])
|
||
|
|
(and (eq? (record-rtd y) rtd)
|
||
|
|
(let f ([field-name* (csv7:record-type-field-names rtd)] [i 0])
|
||
|
|
(or (null? field-name*)
|
||
|
|
(and (let ([accessor (csv7:record-field-accessor rtd i)])
|
||
|
|
(e? (accessor x) (accessor y)))
|
||
|
|
(f (cdr field-name*) (fx+ i 1)))))))))
|
||
|
|
(define equiv?
|
||
|
|
(lambda (x y)
|
||
|
|
(parameterize ([default-record-equal-procedure record-equal?])
|
||
|
|
(equal? x y))))
|
||
|
|
(define equiv-hash
|
||
|
|
(lambda (x)
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash])
|
||
|
|
(equal-hash x))))
|
||
|
|
(define-record-type frob (fields (mutable q)))
|
||
|
|
(define-record-type frub (fields (mutable x) y z))
|
||
|
|
(define frob-hash
|
||
|
|
(lambda (x hash)
|
||
|
|
(raise 'frob-hash)))
|
||
|
|
(define frob-equal?
|
||
|
|
(lambda (x y e?)
|
||
|
|
#f))
|
||
|
|
(define rthp
|
||
|
|
(lambda (rtd)
|
||
|
|
(case-lambda
|
||
|
|
[() (record-type-hash-procedure rtd)]
|
||
|
|
[(x) (record-type-hash-procedure rtd x)])))
|
||
|
|
(define rtep
|
||
|
|
(lambda (rtd)
|
||
|
|
(case-lambda
|
||
|
|
[() (record-type-equal-procedure rtd)]
|
||
|
|
[(x) (record-type-equal-procedure rtd x)])))
|
||
|
|
#t)
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor frob)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor frob)))
|
||
|
|
(not (record-type-equal-procedure (record-type-descriptor frub)))
|
||
|
|
(not (record-type-hash-procedure (record-type-descriptor frub)))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([(rthp (record-type-descriptor frob)) record-hash])
|
||
|
|
(list
|
||
|
|
(record-hash-procedure (make-frob #\q))
|
||
|
|
(record-hash-procedure (make-frub 1 2 3))))
|
||
|
|
(list record-hash #f))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([(rtep (record-type-descriptor frob)) record-equal?])
|
||
|
|
(list
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
|
||
|
|
(list #f #f #f record-equal?))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash])
|
||
|
|
(list
|
||
|
|
(record-hash-procedure (make-frob #\q))
|
||
|
|
(record-hash-procedure (make-frub 1 2 3))))
|
||
|
|
(list record-hash record-hash))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([default-record-equal-procedure record-equal?])
|
||
|
|
(list
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
|
||
|
|
(list record-equal? record-equal? record-equal? record-equal?))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash]
|
||
|
|
[(rthp (record-type-descriptor frob)) frob-hash])
|
||
|
|
(list
|
||
|
|
(record-hash-procedure (make-frob #\q))
|
||
|
|
(record-hash-procedure (make-frub 1 2 3))))
|
||
|
|
(list frob-hash record-hash))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([default-record-equal-procedure record-equal?]
|
||
|
|
[(rtep (record-type-descriptor frob)) frob-equal?])
|
||
|
|
(list
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frub 1 2 3) (make-frob #\q))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frub 1 2 3))
|
||
|
|
(record-equal-procedure (make-frob #\q) (make-frob #\q))))
|
||
|
|
(list record-equal? #f #f frob-equal?))
|
||
|
|
((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash])
|
||
|
|
(equal-hash (vector 1 2 (make-frub 1 2 3) 5 (make-frob #\q) 7))))
|
||
|
|
(eq?
|
||
|
|
(guard (c [(eq? c 'frob-hash) 'yup] [else (raise c)])
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash]
|
||
|
|
[(rthp (record-type-descriptor frob)) frob-hash])
|
||
|
|
(equal-hash (list "hello" (make-frob #\q)))))
|
||
|
|
'yup)
|
||
|
|
((lambda (x) (and (integer? x) (exact? x) (nonnegative? x)))
|
||
|
|
(parameterize ([default-record-hash-procedure record-hash]
|
||
|
|
[(rthp (record-type-descriptor frob)) frob-hash])
|
||
|
|
(equal-hash (vector 1 2 (make-frub 1 2 3) 5 6))))
|
||
|
|
(equiv? (make-frob #\q) (make-frob #\q))
|
||
|
|
(equiv? (make-frub 1 2 3) (make-frub 1 2 3))
|
||
|
|
(not (parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
|
||
|
|
(equiv? (make-frob #\q) (make-frob #\q))))
|
||
|
|
(parameterize ([(rtep (record-type-descriptor frob)) frob-equal?])
|
||
|
|
(equiv? (make-frub 1 2 3) (make-frub 1 2 3)))
|
||
|
|
(equal?
|
||
|
|
(let ([ht (make-hashtable equiv-hash equiv?)])
|
||
|
|
(hashtable-set! ht (make-frob #\q) 'one)
|
||
|
|
(hashtable-set! ht (make-frub 1 2 3) 'two)
|
||
|
|
(hashtable-set! ht (make-frub 'a 'b 'c) 'three)
|
||
|
|
(list
|
||
|
|
(hashtable-ref ht (make-frob #\q) #f)
|
||
|
|
(hashtable-ref ht (make-frub 1 2 3) #f)
|
||
|
|
(hashtable-ref ht (make-frub 'a 'b 'c) #f)
|
||
|
|
(hashtable-ref ht (make-frub 'x 'y 'z) #f)))
|
||
|
|
'(one two three #f))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record19
|
||
|
|
; test ellipses in init expressions
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record foo ()
|
||
|
|
([a (let ()
|
||
|
|
(define-syntax f
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ b ...) (list 'b ...)]))
|
||
|
|
(f 1 2 3))]))
|
||
|
|
(foo-a (make-foo)))
|
||
|
|
'(1 2 3))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record20
|
||
|
|
; test argument-name handing in generated record constructors
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define foo
|
||
|
|
(make-record-type "foo"
|
||
|
|
'((integer-32 fixnum?)
|
||
|
|
(double-float flonum?)
|
||
|
|
unless
|
||
|
|
unless)))
|
||
|
|
(let ()
|
||
|
|
(define make-foo (record-constructor foo))
|
||
|
|
(define foo? (record-predicate foo))
|
||
|
|
(define foo.0 (csv7:record-field-accessor foo 'fixnum?))
|
||
|
|
(define foo.1 (csv7:record-field-accessor foo 'flonum?))
|
||
|
|
(define foo.2 (csv7:record-field-accessor foo 2))
|
||
|
|
(define foo.3 (csv7:record-field-accessor foo 3))
|
||
|
|
(let ([x (make-foo 1 3.0 'a 'b)])
|
||
|
|
(list (foo? x)
|
||
|
|
(foo.0 x)
|
||
|
|
(foo.1 x)
|
||
|
|
(foo.2 x)
|
||
|
|
(foo.3 x)))))
|
||
|
|
'(#t 1 3.0 a b))
|
||
|
|
(equal?
|
||
|
|
(let ([foo (make-record-type "foo" '(a a a))])
|
||
|
|
(define make-foo (record-constructor foo))
|
||
|
|
(define foo? (record-predicate foo))
|
||
|
|
(define foo.0 (csv7:record-field-accessor foo 0))
|
||
|
|
(define foo.1 (csv7:record-field-accessor foo 1))
|
||
|
|
(define foo.2 (csv7:record-field-accessor foo 2))
|
||
|
|
(let ([x (make-foo 'a 'b 'c)])
|
||
|
|
(list (foo? x)
|
||
|
|
(foo.0 x)
|
||
|
|
(foo.1 x)
|
||
|
|
(foo.2 x))))
|
||
|
|
'(#t a b c))
|
||
|
|
(equal?
|
||
|
|
(let* ([names '(a a a a a a a a a a a a)]
|
||
|
|
[foo (make-record-type "foo" names)])
|
||
|
|
(define make-foo (record-constructor foo))
|
||
|
|
(define foo? (record-predicate foo))
|
||
|
|
(define foos (let ([n (length names)])
|
||
|
|
(let f ([i 0])
|
||
|
|
(if (= i n)
|
||
|
|
'()
|
||
|
|
(cons (csv7:record-field-accessor foo i)
|
||
|
|
(f (+ i 1)))))))
|
||
|
|
(let ([x (make-foo 1 2 3 4 5 6 7 8 9 10 11 12)])
|
||
|
|
(cons (foo? x) (map (lambda (p) (p x)) foos))))
|
||
|
|
'(#t 1 2 3 4 5 6 7 8 9 10 11 12))
|
||
|
|
(equal?
|
||
|
|
(let* ([foo (make-record-type "foo" '((integer-32 a)))]
|
||
|
|
[bar (make-record-type foo "bar" '((double-float a)))])
|
||
|
|
(define make-bar (record-constructor bar))
|
||
|
|
(define bar? (record-predicate bar))
|
||
|
|
(define bar.0 (csv7:record-field-accessor bar 0))
|
||
|
|
(define bar.1 (csv7:record-field-accessor bar 1))
|
||
|
|
(let ([x (make-bar 17 23.5)])
|
||
|
|
(list (bar? x) (bar.0 x) (bar.1 x))))
|
||
|
|
'(#t 17 23.5))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let* ([foo (make-record-type "foo" '((integer-32 a)))]
|
||
|
|
[bar (make-record-type foo "bar" '((double-float a)))])
|
||
|
|
(define make-bar (record-constructor bar))
|
||
|
|
(define bar? (record-predicate bar))
|
||
|
|
(define bar.0 (csv7:record-field-accessor bar 0))
|
||
|
|
(define bar.1 (csv7:record-field-accessor bar 1))
|
||
|
|
(let ([x (make-bar 17 23.5)])
|
||
|
|
(list (bar? x) (bar.0 x) (bar.1 x))))))
|
||
|
|
`(let ([x (let ([y (#3%$record (#2%make-record-type (#2%make-record-type "foo" '((integer-32 a))) "bar" '((double-float a))) . ,list?)])
|
||
|
|
(#3%$object-set! 'double-float y ,fixnum? 23.5)
|
||
|
|
(#3%$object-set! 'integer-32 y ,fixnum? 17)
|
||
|
|
y)])
|
||
|
|
(#2%list
|
||
|
|
#t
|
||
|
|
(#3%$object-ref 'integer-32 x ,fixnum?)
|
||
|
|
(#3%$object-ref 'double-float x ,fixnum?))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let* ([foo (make-record-type "foo" '((integer-32 a)))]
|
||
|
|
[bar (make-record-type foo "bar" '((double-float a)))])
|
||
|
|
(define make-bar (record-constructor bar))
|
||
|
|
(define bar? (record-predicate bar))
|
||
|
|
(define bar.0 (csv7:record-field-accessor bar 0))
|
||
|
|
(define bar.1 (csv7:record-field-accessor bar 1))
|
||
|
|
(let ([x (make-bar 17 23.5)])
|
||
|
|
(list (bar? x) (bar.0 x) (bar.1 x))))))
|
||
|
|
`(let ([x (let ([y (#3%$record (#3%make-record-type (#3%make-record-type "foo" '((integer-32 a))) "bar" '((double-float a))) . ,list?)])
|
||
|
|
(#3%$object-set! 'double-float y ,fixnum? 23.5)
|
||
|
|
(#3%$object-set! 'integer-32 y ,fixnum? 17)
|
||
|
|
y)])
|
||
|
|
(#3%list
|
||
|
|
#t
|
||
|
|
(#3%$object-ref 'integer-32 x ,fixnum?)
|
||
|
|
(#3%$object-ref 'double-float x ,fixnum?))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record21 ; duplicate field names and invalid field syntax
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo (x x)))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo (x (mutable x))))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo (x) ([x 3])))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo (x) ([(immutable x) 3])))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo () ([x 4] [x 3])))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
(define-record foo () ([x 4] [(immutable x) 3])))
|
||
|
|
(error? ; invalid field syntax
|
||
|
|
(define-record foo ([x 4])))
|
||
|
|
(error? ; invalid field syntax
|
||
|
|
(define-record foo ([(mutable foo) 3])))
|
||
|
|
(error? ; duplicate field name
|
||
|
|
; would be okay if we used field name rather than record name as template
|
||
|
|
; for generated accessor and mutator identifiers
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-syntax a
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ name fld get)
|
||
|
|
(begin
|
||
|
|
(define-record name (fld x) () ([prefix ""]))
|
||
|
|
(define get x))]))
|
||
|
|
(a rt x g)
|
||
|
|
(let ([r (make-rt 3 4)])
|
||
|
|
(list (x r) (g r))))
|
||
|
|
'(3 4)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record22 ; make sure inlined record routines make proper checks
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'q))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 0) x)))
|
||
|
|
'hello)
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((immutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'q))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 0) x))))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((immutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'q))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 0) x))))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'q))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 'z) x))))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'q))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 'z) x))))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'z))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 0) x))))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(define q! (csv7:record-field-mutator ty 'z))
|
||
|
|
(let ([x ((record-constructor ty) 3)])
|
||
|
|
(q! x 'hello)
|
||
|
|
((csv7:record-field-accessor ty 0) x))))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(csv7:record-field-accessible? ty 3)))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(csv7:record-field-accessible? ty 3)))
|
||
|
|
(equal?
|
||
|
|
(let ([n 0])
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(let ([b (csv7:record-field-accessible? (begin (set! n (+ n 5)) ty) (begin (set! n (+ n 12)) 0))])
|
||
|
|
(cons b n)))
|
||
|
|
'(#t . 17))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(csv7:record-field-mutable? ty 'notq)))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable q))))
|
||
|
|
(csv7:record-field-mutable? ty 'notq)))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable creepy q))))
|
||
|
|
(csv7:record-field-mutable? ty 'notq)))
|
||
|
|
(procedure?
|
||
|
|
(lambda ()
|
||
|
|
(define ty (make-record-type "bar" '((mutable creepy q))))
|
||
|
|
(csv7:record-field-mutable? ty 'notq)))
|
||
|
|
(error?
|
||
|
|
(let ()
|
||
|
|
(define-record bar ((immutable creepy q)))
|
||
|
|
(make-bar 3)))
|
||
|
|
(error?
|
||
|
|
(lambda ()
|
||
|
|
(define-record bar ((immutable creepy q)))
|
||
|
|
(make-bar 3)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record23 ; test general make-record-type interface
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define enum-base-rtd
|
||
|
|
(make-record-type ; not sealed, not opaque
|
||
|
|
#!base-rtd ; undocumented $base-rtd
|
||
|
|
'#{enum b9s78zmm79qs7j22-a} ; make enum-base-rtd type nongenerative
|
||
|
|
'((immutable sym->index) (immutable index->sym))))
|
||
|
|
(define get-sym->index
|
||
|
|
(csv7:record-field-accessor enum-base-rtd 'sym->index))
|
||
|
|
(define get-index->sym
|
||
|
|
(csv7:record-field-accessor enum-base-rtd 'index->sym))
|
||
|
|
(define enum-parent-rtd ; not sealed, not opaque
|
||
|
|
(make-record-type "enum-parent" '((immutable members))))
|
||
|
|
(define get-members (csv7:record-field-accessor enum-parent-rtd 'members))
|
||
|
|
|
||
|
|
(let ([this-enum-rtd
|
||
|
|
(#%$make-record-type enum-base-rtd enum-parent-rtd "enum"
|
||
|
|
'() ; no fields to add
|
||
|
|
#t ; sealed
|
||
|
|
#f ; not opaque
|
||
|
|
'*sym->index* ; extras (tacked onto end of rtd)
|
||
|
|
'*index->sym*)]) ; i.e., static (per enumeration type) fields
|
||
|
|
(let ([make-this-enum (record-constructor this-enum-rtd)])
|
||
|
|
|
||
|
|
(let ([enum (make-this-enum '*members*)])
|
||
|
|
(let ([rtd (record-rtd enum)])
|
||
|
|
(list
|
||
|
|
(get-members enum)
|
||
|
|
(get-sym->index rtd)
|
||
|
|
(get-index->sym rtd)))))))
|
||
|
|
'(*members* *sym->index* *index->sym*))
|
||
|
|
(error? ; cannot extend sealed record type
|
||
|
|
(let ([rtd1 (#%$make-record-type #!base-rtd #f "foo" '() #t #f '())])
|
||
|
|
(#%$make-record-type #!base-rtd rtd1 "bar" '() #f #f '())))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record25
|
||
|
|
; test generic C aliases for specific types
|
||
|
|
(begin
|
||
|
|
(define-record r25-bar ((int a) (unsigned b) (unsigned-int c)
|
||
|
|
(short d) (unsigned-short e)
|
||
|
|
(long f) (unsigned-long g)
|
||
|
|
(iptr h) (uptr i)
|
||
|
|
(float j) (double k)
|
||
|
|
(ptr l) (char m) (wchar n) (fixnum o)
|
||
|
|
(void* p) (boolean q)
|
||
|
|
(long-long r) (unsigned-long-long s)))
|
||
|
|
#t)
|
||
|
|
(error? (make-r25-bar 1.0 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2.0 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 'three 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 1/4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 "five" 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 '(6) 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 '#(a b c d e f g) 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 'ate 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 #\9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0+0.0i 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12.0 13))
|
||
|
|
(error? (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13.0))
|
||
|
|
(begin
|
||
|
|
(define r25-x (make-r25-bar 1 2 3 4 5 6 7 8 9 10.0 11.0 'blue #\a #\x3bb 75 #xc7c7c7c7 'a 12 13))
|
||
|
|
(and (r25-bar? r25-x) (not (r25-bar? '(foo)))))
|
||
|
|
(error? (set-r25-bar-a! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-a! r25-x (+ (r25-bar-a r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-b! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-b! r25-x (+ (r25-bar-b r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-c! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-c! r25-x (+ (r25-bar-c r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-d! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-d! r25-x (+ (r25-bar-d r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-e! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-e! r25-x (+ (r25-bar-e r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-f! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-f! r25-x (- (r25-bar-f r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-g! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-g! r25-x (+ (r25-bar-g r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-h! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-h! r25-x (+ (r25-bar-h r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-i! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-i! r25-x (+ (r25-bar-i r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-j! r25-x 3))
|
||
|
|
(eq? (set-r25-bar-j! r25-x (+ (r25-bar-j r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-k! r25-x 3))
|
||
|
|
(eq? (set-r25-bar-k! r25-x (+ (r25-bar-k r25-x) 73)) (void))
|
||
|
|
(eq? (set-r25-bar-l! r25-x (cons (r25-bar-l r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-m! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-m! r25-x (integer->char (+ (char->integer (r25-bar-m r25-x)) 1))) (void))
|
||
|
|
(error? (set-r25-bar-n! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-n! r25-x (integer->char (+ (char->integer (r25-bar-n r25-x)) 1))) (void))
|
||
|
|
(error? (set-r25-bar-o! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-o! r25-x (+ (r25-bar-o r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-p! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-p! r25-x (+ (r25-bar-p r25-x) 73)) (void))
|
||
|
|
(eq? (set-r25-bar-q! r25-x (not (r25-bar-q r25-x))) (void))
|
||
|
|
(error? (set-r25-bar-r! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-r! r25-x (- (r25-bar-r r25-x) 73)) (void))
|
||
|
|
(error? (set-r25-bar-s! r25-x 3.0))
|
||
|
|
(eq? (set-r25-bar-s! r25-x (+ (r25-bar-s r25-x) 73)) (void))
|
||
|
|
(equal?
|
||
|
|
(list
|
||
|
|
(r25-bar-a r25-x)
|
||
|
|
(r25-bar-b r25-x)
|
||
|
|
(r25-bar-c r25-x)
|
||
|
|
(r25-bar-d r25-x)
|
||
|
|
(r25-bar-e r25-x)
|
||
|
|
(r25-bar-f r25-x)
|
||
|
|
(r25-bar-g r25-x)
|
||
|
|
(r25-bar-h r25-x)
|
||
|
|
(r25-bar-i r25-x)
|
||
|
|
(r25-bar-j r25-x)
|
||
|
|
(r25-bar-k r25-x)
|
||
|
|
(r25-bar-l r25-x)
|
||
|
|
(r25-bar-m r25-x)
|
||
|
|
(r25-bar-n r25-x)
|
||
|
|
(r25-bar-o r25-x)
|
||
|
|
(r25-bar-p r25-x)
|
||
|
|
(r25-bar-q r25-x)
|
||
|
|
(r25-bar-r r25-x)
|
||
|
|
(r25-bar-s r25-x))
|
||
|
|
'(74 75 76 77 78 -67 80 81 82 83.0 84.0 (blue . 73) #\b #\x3bc 148 #xc7c7c810 #f -61 86))
|
||
|
|
(error? (set-r25-bar-a! r25-x (expt 256 (foreign-sizeof 'int))))
|
||
|
|
(error? (set-r25-bar-a! r25-x (- -1 (ash (expt 256 (foreign-sizeof 'int)) -1))))
|
||
|
|
(begin
|
||
|
|
(define ($test-int x size get put)
|
||
|
|
(let* ([n10000 (expt 256 size)]
|
||
|
|
[nffff (- n10000 1)]
|
||
|
|
[n8000 (ash n10000 -1)]
|
||
|
|
[n7fff (- n8000 1)]
|
||
|
|
[n-8000 (- n8000)]
|
||
|
|
[n-8001 (- n-8000 1)])
|
||
|
|
(and
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n10000) #f))
|
||
|
|
(eq? (put x nffff) (void))
|
||
|
|
(eqv? (get x) -1)
|
||
|
|
(eq? (put x n8000) (void))
|
||
|
|
(eqv? (get x) n-8000)
|
||
|
|
(eq? (put x n7fff) (void))
|
||
|
|
(eqv? (get x) n7fff)
|
||
|
|
(eq? (put x 0) (void))
|
||
|
|
(eqv? (get x) 0)
|
||
|
|
(eq? (put x -1) (void))
|
||
|
|
(eqv? (get x) -1)
|
||
|
|
(eq? (put x n-8000) (void))
|
||
|
|
(eqv? (get x) n-8000)
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
|
||
|
|
(eqv? (get x) n-8000))))
|
||
|
|
(define ($test-uint x size get put)
|
||
|
|
(let* ([n10000 (expt 256 size)]
|
||
|
|
[nffff (- n10000 1)]
|
||
|
|
[n8000 (ash n10000 -1)]
|
||
|
|
[n7fff (- n8000 1)]
|
||
|
|
[n-8000 (- n8000)]
|
||
|
|
[n-8001 (- n-8000 1)])
|
||
|
|
(and
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n10000) #f))
|
||
|
|
(eq? (put x nffff) (void))
|
||
|
|
(eqv? (get x) nffff)
|
||
|
|
(eq? (put x n8000) (void))
|
||
|
|
(eqv? (get x) n8000)
|
||
|
|
(eq? (put x n7fff) (void))
|
||
|
|
(eqv? (get x) n7fff)
|
||
|
|
(eq? (put x 0) (void))
|
||
|
|
(eqv? (get x) 0)
|
||
|
|
(eq? (put x -1) (void))
|
||
|
|
(eqv? (get x) nffff)
|
||
|
|
(eq? (put x n-8000) (void))
|
||
|
|
(eqv? (get x) n8000)
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
|
||
|
|
(eqv? (get x) n8000))))
|
||
|
|
(define ($test-fixnum x get put)
|
||
|
|
(let ([n8000 (+ (greatest-fixnum) 1)]
|
||
|
|
[n7fff (greatest-fixnum)]
|
||
|
|
[n-8000 (least-fixnum)]
|
||
|
|
[n-8001 (- (least-fixnum) 1)])
|
||
|
|
(and
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n8000) #f))
|
||
|
|
(eq? (put x n7fff) (void))
|
||
|
|
(eqv? (get x) n7fff)
|
||
|
|
(eq? (put x 0) (void))
|
||
|
|
(eqv? (get x) 0)
|
||
|
|
(eq? (put x -1) (void))
|
||
|
|
(eqv? (get x) -1)
|
||
|
|
(eq? (put x n-8000) (void))
|
||
|
|
(eqv? (get x) n-8000)
|
||
|
|
(or (= (optimize-level) 3) (guard (c [#t]) (put x n-8001) #f))
|
||
|
|
(eqv? (get x) n-8000))))
|
||
|
|
#t)
|
||
|
|
($test-int r25-x (foreign-sizeof 'int) r25-bar-a set-r25-bar-a!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'unsigned) r25-bar-b set-r25-bar-b!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'unsigned-int) r25-bar-c set-r25-bar-c!)
|
||
|
|
($test-int r25-x (foreign-sizeof 'short) r25-bar-d set-r25-bar-d!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'unsigned-short) r25-bar-e set-r25-bar-e!)
|
||
|
|
($test-int r25-x (foreign-sizeof 'long) r25-bar-f set-r25-bar-f!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'unsigned-long) r25-bar-g set-r25-bar-g!)
|
||
|
|
($test-int r25-x (foreign-sizeof 'long-long) r25-bar-r set-r25-bar-r!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'unsigned-long-long) r25-bar-s set-r25-bar-s!)
|
||
|
|
($test-int r25-x (foreign-sizeof 'iptr) r25-bar-h set-r25-bar-h!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'uptr) r25-bar-i set-r25-bar-i!)
|
||
|
|
($test-fixnum r25-x r25-bar-o set-r25-bar-o!)
|
||
|
|
($test-uint r25-x (foreign-sizeof 'void*) r25-bar-p set-r25-bar-p!)
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat fasl-records
|
||
|
|
; make sure we can fasl out cyclic record type descriptors
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-a
|
||
|
|
(let ()
|
||
|
|
(define-syntax a
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
|
||
|
|
"rtd1" '((mutable q)) #f #f)]
|
||
|
|
[rtd2 (#%$make-record-type rtd1 #!base-rtd
|
||
|
|
"rtd2" '() #f #f #f)])
|
||
|
|
((record-mutator rtd1 0) rtd2 rtd2)
|
||
|
|
#`(quote #,rtd2))))
|
||
|
|
a))))
|
||
|
|
'replace)
|
||
|
|
(load "testfile.ss")
|
||
|
|
#t)
|
||
|
|
(eq?
|
||
|
|
((record-accessor (record-rtd $fsr-a) 0) $fsr-a)
|
||
|
|
$fsr-a)
|
||
|
|
(begin
|
||
|
|
(separate-compile "testfile")
|
||
|
|
(load "testfile.so")
|
||
|
|
#t)
|
||
|
|
(eq?
|
||
|
|
((record-accessor (record-rtd $fsr-a) 0) $fsr-a)
|
||
|
|
$fsr-a)
|
||
|
|
; ... even when cycle involves the record's base rtd
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-b
|
||
|
|
(let ()
|
||
|
|
(define-syntax a
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
|
||
|
|
"rtd1" '((mutable q)) #f #f)]
|
||
|
|
[rtd2 (#%$make-record-type rtd1 #!base-rtd
|
||
|
|
"rtd2" '() #f #f #f)]
|
||
|
|
[rtd3 (#%$make-record-type rtd2 #!base-rtd
|
||
|
|
"rtd3" '() #f #f)])
|
||
|
|
((record-mutator rtd1 0) rtd2 rtd3)
|
||
|
|
#`(quote #,rtd3))))
|
||
|
|
a))))
|
||
|
|
'replace)
|
||
|
|
(load "testfile.ss")
|
||
|
|
#t)
|
||
|
|
(eq?
|
||
|
|
((record-accessor (record-rtd (record-rtd $fsr-b)) 0) (record-rtd $fsr-b))
|
||
|
|
$fsr-b)
|
||
|
|
(begin
|
||
|
|
(separate-compile "testfile")
|
||
|
|
(load "testfile.so")
|
||
|
|
#t)
|
||
|
|
(eq?
|
||
|
|
((record-accessor (record-rtd (record-rtd $fsr-b)) 0) (record-rtd $fsr-b))
|
||
|
|
$fsr-b)
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-c
|
||
|
|
(let ()
|
||
|
|
(define-syntax a
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([rtd1 (#%$make-record-type #!base-rtd #!base-rtd
|
||
|
|
"rtd1" '((mutable q)) #f #f)]
|
||
|
|
[rtd2 (#%$make-record-type rtd1 #!base-rtd
|
||
|
|
"rtd2" '() #f #f #f)]
|
||
|
|
[rtd3 (#%$make-record-type rtd2 #f
|
||
|
|
"rtd3" '((immutable a)) #f #f)])
|
||
|
|
((record-mutator rtd1 0) rtd2 ((record-constructor rtd3) 23))
|
||
|
|
#`(quote #,rtd3))))
|
||
|
|
a))))
|
||
|
|
'replace)
|
||
|
|
(load "testfile.ss")
|
||
|
|
#t)
|
||
|
|
(record?
|
||
|
|
((record-accessor (record-rtd (record-rtd $fsr-c)) 0) (record-rtd $fsr-c))
|
||
|
|
$fsr-c)
|
||
|
|
(begin
|
||
|
|
(separate-compile "testfile")
|
||
|
|
(load "testfile.so")
|
||
|
|
#t)
|
||
|
|
(record?
|
||
|
|
((record-accessor (record-rtd (record-rtd $fsr-c)) 0) (record-rtd $fsr-c))
|
||
|
|
$fsr-c)
|
||
|
|
; fasl out typed fields
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-d-inst
|
||
|
|
(let ()
|
||
|
|
(define-syntax a
|
||
|
|
(lambda (x)
|
||
|
|
(define-record $fsr-d ((immutable integer-32 a) (mutable unsigned-40 b)))
|
||
|
|
#`(quote #,(make-$fsr-d #x1234abcd #xfedcba6543))))
|
||
|
|
a))))
|
||
|
|
'replace)
|
||
|
|
(load "testfile.ss")
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
((record-accessor (record-rtd $fsr-d-inst) 0) $fsr-d-inst)
|
||
|
|
#x1234abcd)
|
||
|
|
(eqv?
|
||
|
|
((record-accessor (record-rtd $fsr-d-inst) 1) $fsr-d-inst)
|
||
|
|
#xfedcba6543)
|
||
|
|
(begin
|
||
|
|
(separate-compile "testfile")
|
||
|
|
(load "testfile.so")
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
((record-accessor (record-rtd $fsr-d-inst) 0) $fsr-d-inst)
|
||
|
|
#x1234abcd)
|
||
|
|
(eqv?
|
||
|
|
((record-accessor (record-rtd $fsr-d-inst) 1) $fsr-d-inst)
|
||
|
|
#xfedcba6543)
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(eval-when (compile load)
|
||
|
|
(define-record $fsr-e
|
||
|
|
((immutable integer-8 i8)
|
||
|
|
(immutable integer-16 i16)
|
||
|
|
(immutable integer-24 i24)
|
||
|
|
(immutable integer-32 i32)
|
||
|
|
(immutable integer-40 i40)
|
||
|
|
(immutable integer-48 i48)
|
||
|
|
(immutable integer-56 i56)
|
||
|
|
(immutable integer-64 i64)
|
||
|
|
(immutable unsigned-8 u8)
|
||
|
|
(immutable unsigned-16 u16)
|
||
|
|
(immutable unsigned-24 u24)
|
||
|
|
(immutable unsigned-32 u32)
|
||
|
|
(immutable unsigned-40 u40)
|
||
|
|
(immutable unsigned-48 u48)
|
||
|
|
(immutable unsigned-56 u56)
|
||
|
|
(immutable unsigned-64 u64)
|
||
|
|
(immutable char c)
|
||
|
|
(immutable single-float sf)
|
||
|
|
(immutable wchar wc)
|
||
|
|
(immutable double-float df)
|
||
|
|
(immutable fixnum f)))))
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-e-inst1
|
||
|
|
(let-syntax ([a (lambda (x)
|
||
|
|
#`'#,(make-$fsr-e 0 -1 0 -1 0 -1 0 -1
|
||
|
|
0 #xffff 0 #xffffffff 0 #xffffffffffff
|
||
|
|
0 #xffffffffffffffff
|
||
|
|
#\nul 3.14 #\x3bc -3.14 0))])
|
||
|
|
a)))
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-e-inst2
|
||
|
|
(let-syntax ([a (lambda (x)
|
||
|
|
#`'#,(make-$fsr-e -1 0 -1 0 -1 0 -1 0
|
||
|
|
#xff 0 #xffffff 0 #xffffffffff 0
|
||
|
|
#xffffffffffffff 0
|
||
|
|
#\a -3.14 #\nul 3.14 -1))])
|
||
|
|
a)))
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-e-inst3
|
||
|
|
(let-syntax ([a (lambda (x)
|
||
|
|
#`'#,(make-$fsr-e
|
||
|
|
#x7f #x-8000 #x7fffff #x-80000000
|
||
|
|
#x7fffffffff #x-800000000000
|
||
|
|
#x7fffffffffffff #x-8000000000000000
|
||
|
|
#x7f #x8000 #x7fffff #x80000000
|
||
|
|
#x7fffffffff #x800000000000
|
||
|
|
#x7fffffffffffff #x8000000000000000
|
||
|
|
#\a +inf.0 #\nul -0.0 -1))])
|
||
|
|
a)))
|
||
|
|
(pretty-print
|
||
|
|
'(define $fsr-e-inst4
|
||
|
|
(let-syntax ([a (lambda (x)
|
||
|
|
#`'#,(make-$fsr-e
|
||
|
|
#x-80 #x7fff #x-800000 #x7fffffff
|
||
|
|
#x-8000000000 #x7fffffffffff
|
||
|
|
#x-80000000000000 #x7fffffffffffffff
|
||
|
|
#x80 #x7fff #x800000 #x7fffffff
|
||
|
|
#x8000000000 #x7fffffffffff
|
||
|
|
#x80000000000000 #x7fffffffffffffff
|
||
|
|
#\a +0.0 #\nul +inf.0 -1))])
|
||
|
|
a))))
|
||
|
|
'replace)
|
||
|
|
#t)
|
||
|
|
(begin
|
||
|
|
(separate-compile "testfile")
|
||
|
|
(load "testfile.so")
|
||
|
|
#t)
|
||
|
|
($fsr-e? $fsr-e-inst1)
|
||
|
|
($fsr-e? $fsr-e-inst2)
|
||
|
|
($fsr-e? $fsr-e-inst3)
|
||
|
|
($fsr-e? $fsr-e-inst4)
|
||
|
|
(equal?
|
||
|
|
($record->vector $fsr-e-inst1)
|
||
|
|
($record->vector
|
||
|
|
(make-$fsr-e 0 -1 0 -1 0 -1 0 -1
|
||
|
|
0 #xffff 0 #xffffffff 0 #xffffffffffff
|
||
|
|
0 #xffffffffffffffff
|
||
|
|
#\nul 3.14 #\x3bc -3.14 0)))
|
||
|
|
(equal?
|
||
|
|
($record->vector $fsr-e-inst2)
|
||
|
|
($record->vector
|
||
|
|
(make-$fsr-e -1 0 -1 0 -1 0 -1 0
|
||
|
|
#xff 0 #xffffff 0 #xffffffffff 0
|
||
|
|
#xffffffffffffff 0
|
||
|
|
#\a -3.14 #\nul 3.14 -1)))
|
||
|
|
(equal?
|
||
|
|
($record->vector $fsr-e-inst3)
|
||
|
|
($record->vector
|
||
|
|
(make-$fsr-e
|
||
|
|
#x7f #x-8000 #x7fffff #x-80000000
|
||
|
|
#x7fffffffff #x-800000000000
|
||
|
|
#x7fffffffffffff #x-8000000000000000
|
||
|
|
#x7f #x8000 #x7fffff #x80000000
|
||
|
|
#x7fffffffff #x800000000000
|
||
|
|
#x7fffffffffffff #x8000000000000000
|
||
|
|
#\a +inf.0 #\nul -0.0 -1)))
|
||
|
|
(equal?
|
||
|
|
($record->vector $fsr-e-inst4)
|
||
|
|
($record->vector
|
||
|
|
(make-$fsr-e
|
||
|
|
#x-80 #x7fff #x-800000 #x7fffffff
|
||
|
|
#x-8000000000 #x7fffffffffff
|
||
|
|
#x-80000000000000 #x7fffffffffffffff
|
||
|
|
#x80 #x7fff #x800000 #x7fffffff
|
||
|
|
#x8000000000 #x7fffffffffff
|
||
|
|
#x80000000000000 #x7fffffffffffffff
|
||
|
|
#\a +0.0 #\nul +inf.0 -1)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record?
|
||
|
|
(eq? (record? 3) #f)
|
||
|
|
(eq? (record? 'a) #f)
|
||
|
|
(eq? (record? '#(1 2 3)) #f)
|
||
|
|
(eq? (record? (make-record-type "foo" '())) #t)
|
||
|
|
(eq? (record? ((record-constructor (make-record-type "foo" '())))) #t)
|
||
|
|
(equal?
|
||
|
|
(let ([rtd1 (make-record-type "foo" '())]
|
||
|
|
[rtd2 (make-record-type "bar" '())])
|
||
|
|
(let ([rtd3 (make-record-type rtd1 "xfoo" '())])
|
||
|
|
(list (record? ((record-constructor rtd1)) rtd1)
|
||
|
|
(record? ((record-constructor rtd1)) rtd2)
|
||
|
|
(record? ((record-constructor rtd1)) rtd3)
|
||
|
|
(record? ((record-constructor rtd3)) rtd1)
|
||
|
|
(record? ((record-constructor rtd3)) rtd2)
|
||
|
|
(record? ((record-constructor rtd3)) rtd3))))
|
||
|
|
'(#t #f #f #t #f #t))
|
||
|
|
(error? (record? 3 4))
|
||
|
|
(error? (record? ((record-constructor (make-record-type "foo" '()))) 'a))
|
||
|
|
(error? (record? ((record-constructor (make-record-type "foo" '()))) '#(1)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type A)
|
||
|
|
(define-record-type B (parent A))
|
||
|
|
(define-record-type C (parent B))
|
||
|
|
(define-record-type D (parent C) (sealed #t))
|
||
|
|
(define-record-type E (parent C) (opaque #t))
|
||
|
|
(define a (make-A))
|
||
|
|
(define b (make-B))
|
||
|
|
(define c (make-C))
|
||
|
|
(define d (make-D))
|
||
|
|
(define e (make-E))
|
||
|
|
(define Atd (record-type-descriptor A))
|
||
|
|
(define Btd (record-type-descriptor B))
|
||
|
|
(define Ctd (record-type-descriptor C))
|
||
|
|
(define Dtd (record-type-descriptor D))
|
||
|
|
(define Etd (record-type-descriptor E))
|
||
|
|
(and
|
||
|
|
(equal?
|
||
|
|
(list (record? 3) (record? a) (record? b) (record? c) (record? d) (record? e))
|
||
|
|
'(#f #t #t #t #t #f))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(import (rnrs))
|
||
|
|
(list (record? 3) (record? a) (record? b) (record? c) (record? d) (record? e)))
|
||
|
|
'(#f #t #t #t #t #f))
|
||
|
|
(equal?
|
||
|
|
(list (record? 3 Atd) (record? a Atd) (record? b Atd) (record? c Atd) (record? d Atd) (record? e Atd))
|
||
|
|
'(#f #t #t #t #t #t))
|
||
|
|
(equal?
|
||
|
|
(list (record? 3 Btd) (record? a Btd) (record? b Btd) (record? c Btd) (record? d Btd) (record? e Btd))
|
||
|
|
'(#f #f #t #t #t #t))
|
||
|
|
(equal?
|
||
|
|
(list (record? 3 Ctd) (record? a Ctd) (record? b Ctd) (record? c Ctd) (record? d Ctd) (record? e Ctd))
|
||
|
|
'(#f #f #f #t #t #t))
|
||
|
|
(equal?
|
||
|
|
(list (record? 3 Dtd) (record? a Dtd) (record? b Dtd) (record? c Dtd) (record? d Dtd) (record? e Dtd))
|
||
|
|
'(#f #f #f #f #t #f))
|
||
|
|
(equal?
|
||
|
|
(list (record? 3 Etd) (record? a Etd) (record? b Etd) (record? c Etd) (record? d Etd) (record? e Etd))
|
||
|
|
'(#f #f #f #f #f #t))
|
||
|
|
(equal?
|
||
|
|
(let ([record? #%$sealed-record?])
|
||
|
|
(list (record? 3 Dtd) (record? a Dtd) (record? b Dtd) (record? c Dtd) (record? d Dtd) (record? e Dtd)))
|
||
|
|
'(#f #f #f #f #t #f))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat record-type-mismatch
|
||
|
|
(begin
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(fields x y))
|
||
|
|
#t)
|
||
|
|
(record-type-descriptor?
|
||
|
|
(make-record-type '#{flotsam flotsam} '((immutable x) (immutable y))))
|
||
|
|
(error? ; different parent
|
||
|
|
(begin
|
||
|
|
(define-record-type pflotsam (nongenerative pflotsam))
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(parent pflotsam)
|
||
|
|
(fields x y))))
|
||
|
|
(error? ; different fields
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(fields x y z)))
|
||
|
|
(error? ; different fields
|
||
|
|
(make-record-type '#{flotsam flotsam} '((int x) y)))
|
||
|
|
(error? ; different mutability
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(fields (mutable x) y)))
|
||
|
|
(error? ; different flags
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(sealed #t)
|
||
|
|
(fields x y)))
|
||
|
|
(error? ; different flags
|
||
|
|
(define-record-type flotsam
|
||
|
|
(nongenerative #{flotsam flotsam})
|
||
|
|
(opaque #t)
|
||
|
|
(fields x y)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat r6rs-records-procedural
|
||
|
|
((lambda (x)
|
||
|
|
(and (list? x)
|
||
|
|
(record? (car x))
|
||
|
|
(equal?
|
||
|
|
(cdr x)
|
||
|
|
'(765 45 25 #t #t #f #f #t #t #f foo bar #1(x) #2(y z) #f #t
|
||
|
|
(#t #f) (#f #f) (#f #t) #t pluto))))
|
||
|
|
(let ()
|
||
|
|
(define prtd
|
||
|
|
(make-record-type-descriptor 'foo #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define rtd
|
||
|
|
(make-record-type-descriptor 'bar prtd 'pluto #t #f
|
||
|
|
'#((mutable y) (immutable z))))
|
||
|
|
(define rcd (make-record-constructor-descriptor rtd #f #f))
|
||
|
|
(define rc (r6rs:record-constructor rcd))
|
||
|
|
(define foo-x (record-accessor prtd 0))
|
||
|
|
(define foo-x! (record-mutator prtd 0))
|
||
|
|
(define bar-y (record-accessor rtd 0))
|
||
|
|
(define bar-y! (record-mutator rtd 0))
|
||
|
|
(define bar-z (record-accessor rtd 1))
|
||
|
|
(define x (rc 17 20 25))
|
||
|
|
(bar-y! x (+ (bar-y x) (bar-z x)))
|
||
|
|
(foo-x! x (* (bar-y x) (foo-x x)))
|
||
|
|
(list x (foo-x x) (bar-y x) (bar-z x)
|
||
|
|
(record-type-descriptor? rtd)
|
||
|
|
(record-constructor-descriptor? rcd)
|
||
|
|
(record-type-descriptor? rcd)
|
||
|
|
(record-constructor-descriptor? rtd)
|
||
|
|
(record-field-mutable? prtd 0)
|
||
|
|
(record-field-mutable? rtd 0)
|
||
|
|
(record-field-mutable? rtd 1)
|
||
|
|
(record-type-name prtd)
|
||
|
|
(record-type-name rtd)
|
||
|
|
(record-type-field-names prtd)
|
||
|
|
(record-type-field-names rtd)
|
||
|
|
(eq? (record-rtd x) prtd)
|
||
|
|
(eq? (record-rtd x) rtd)
|
||
|
|
(list (record-type-generative? prtd) (record-type-generative? rtd))
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))
|
||
|
|
(gensym? (record-type-uid prtd))
|
||
|
|
(record-type-uid rtd))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(parameterize ([current-output-port (open-output-string)])
|
||
|
|
(define a-rtd (make-record-type-descriptor 'a #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
|
||
|
|
'#((immutable x) (mutable y))))
|
||
|
|
(define a? (record-predicate a-rtd))
|
||
|
|
(define b? (record-predicate b-rtd))
|
||
|
|
(define a-x (record-accessor a-rtd 0))
|
||
|
|
(define a-x! (record-mutator a-rtd 0))
|
||
|
|
(define b-x (record-accessor b-rtd 0))
|
||
|
|
(define b-y (record-accessor b-rtd 1))
|
||
|
|
(define b-y! (record-mutator b-rtd 1))
|
||
|
|
(define (a->list b)
|
||
|
|
(if (b? b)
|
||
|
|
(list (a-x b) (b-x b) (b-y b))
|
||
|
|
(list (a-x b))))
|
||
|
|
(define a-rcd0 (make-record-constructor-descriptor a-rtd #f #f))
|
||
|
|
(define b-rcd0 (make-record-constructor-descriptor b-rtd #f #f))
|
||
|
|
#;(define make-a0 (r6rs:record-constructor a-rcd0))
|
||
|
|
#;(define make-b0 (r6rs:record-constructor b-rcd0))
|
||
|
|
(define make-a0 (record-constructor a-rcd0)) ; should handle rcd too
|
||
|
|
(define make-b0 (record-constructor b-rcd0)) ; should handle rcd too
|
||
|
|
(define b-rcd1 (make-record-constructor-descriptor b-rtd a-rcd0 #f))
|
||
|
|
(define make-b1 (r6rs:record-constructor b-rcd1))
|
||
|
|
(define a-rcd2
|
||
|
|
(make-record-constructor-descriptor a-rtd #f
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (x y)
|
||
|
|
(let ([r (p (- x y))])
|
||
|
|
(printf "make-a2: ~s\n" (a->list r))
|
||
|
|
(a-x r)
|
||
|
|
r)))))
|
||
|
|
(define make-a2 (r6rs:record-constructor a-rcd2))
|
||
|
|
(let ([ls (map a->list (list
|
||
|
|
(make-a0 3)
|
||
|
|
(make-b0 4 5 6)
|
||
|
|
(make-b1 7 8 9)
|
||
|
|
(make-a2 10 11)))])
|
||
|
|
(cons (get-output-string (current-output-port)) ls)))
|
||
|
|
'("make-a2: (-1)\n" (3) (4 5 6) (7 8 9) (-1)))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(parameterize ([current-output-port (open-output-string)])
|
||
|
|
(define a-rtd (make-record-type-descriptor 'a #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define a? (record-predicate a-rtd))
|
||
|
|
(define a-x (record-accessor a-rtd 0))
|
||
|
|
(define (a->list b) (list (a-x b)))
|
||
|
|
(define-syntax echo
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ s e) (begin (printf "~a in\n" s)
|
||
|
|
(let ([x e])
|
||
|
|
(printf "~a out: ~s\n" s (record? x))
|
||
|
|
x))]))
|
||
|
|
(define a-rcd
|
||
|
|
(make-record-constructor-descriptor a-rtd #f
|
||
|
|
(lambda (m) (lambda (q t) (echo "A" (m (* q t)))))))
|
||
|
|
(define make-a (r6rs:record-constructor a-rcd))
|
||
|
|
(let ([ls (map a->list (list (make-a 3 4)))])
|
||
|
|
(cons (get-output-string (current-output-port)) ls)))
|
||
|
|
'("A in\nA out: #t\n" (12)))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(parameterize ([current-output-port (open-output-string)])
|
||
|
|
(define a-rtd (make-record-type-descriptor 'a #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
|
||
|
|
'#((immutable x) (mutable y))))
|
||
|
|
(define a? (record-predicate a-rtd))
|
||
|
|
(define b? (record-predicate b-rtd))
|
||
|
|
(define a-x (record-accessor a-rtd 0))
|
||
|
|
(define a-x! (record-mutator a-rtd 0))
|
||
|
|
(define b-x (record-accessor b-rtd 0))
|
||
|
|
(define b-y (record-accessor b-rtd 1))
|
||
|
|
(define b-y! (record-mutator b-rtd 1))
|
||
|
|
(define (a->list b)
|
||
|
|
(if (b? b)
|
||
|
|
(list (a-x b) (b-x b) (b-y b))
|
||
|
|
(list (a-x b))))
|
||
|
|
(define-syntax echo
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ s e) (begin (printf "~a in\n" s)
|
||
|
|
(let ([x e])
|
||
|
|
(printf "~a out: ~s\n" s (record? x))
|
||
|
|
x))]))
|
||
|
|
(define a-rcd
|
||
|
|
(make-record-constructor-descriptor a-rtd #f
|
||
|
|
(lambda (m) (lambda (q) (echo "A" (m (* q q)))))))
|
||
|
|
(define b-rcd
|
||
|
|
(make-record-constructor-descriptor b-rtd a-rcd
|
||
|
|
(lambda (m) (lambda (q) (echo "B" ((m q) (- q) (/ q)))))))
|
||
|
|
(define make-b (r6rs:record-constructor b-rcd))
|
||
|
|
(let ([ls (map a->list (list (make-b 3)))])
|
||
|
|
(cons (get-output-string (current-output-port)) ls)))
|
||
|
|
'("B in\nA in\nA out: #t\nB out: #t\n" (9 -3 1/3)))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(parameterize ([current-output-port (open-output-string)])
|
||
|
|
(define a-rtd (make-record-type-descriptor 'a #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define b-rtd (make-record-type-descriptor 'b a-rtd #f #f #f
|
||
|
|
'#((immutable x) (mutable y))))
|
||
|
|
(define c-rtd (make-record-type-descriptor 'c b-rtd #f #f #f
|
||
|
|
'#((immutable z) (mutable w))))
|
||
|
|
(define a? (record-predicate a-rtd))
|
||
|
|
(define b? (record-predicate b-rtd))
|
||
|
|
(define c? (record-predicate c-rtd))
|
||
|
|
(define a-x (record-accessor a-rtd 0))
|
||
|
|
(define a-x! (record-mutator a-rtd 0))
|
||
|
|
(define b-x (record-accessor b-rtd 0))
|
||
|
|
(define b-y (record-accessor b-rtd 1))
|
||
|
|
(define b-y! (record-mutator b-rtd 1))
|
||
|
|
(define c-z (record-accessor c-rtd 0))
|
||
|
|
(define c-w (record-accessor c-rtd 1))
|
||
|
|
(define c-w! (record-mutator c-rtd 1))
|
||
|
|
(define (a->list b)
|
||
|
|
(if (c? b)
|
||
|
|
(list (a-x b) (b-x b) (b-y b) (c-z b) (c-w b))
|
||
|
|
(if (b? b)
|
||
|
|
(list (a-x b) (b-x b) (b-y b))
|
||
|
|
(list (a-x b)))))
|
||
|
|
(define-syntax echo
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ s e) (begin (printf "~a in\n" s)
|
||
|
|
(let ([x e])
|
||
|
|
(printf "~a out: ~s\n" s (record? x))
|
||
|
|
x))]))
|
||
|
|
(define a-rcd
|
||
|
|
(make-record-constructor-descriptor a-rtd #f
|
||
|
|
(lambda (m) (lambda (q) (echo "A" (m (* q q)))))))
|
||
|
|
(define b-rcd
|
||
|
|
(make-record-constructor-descriptor b-rtd a-rcd
|
||
|
|
(lambda (m) (lambda (q) (echo "B" ((m q) (- q) (/ q)))))))
|
||
|
|
(define c-rcd
|
||
|
|
(make-record-constructor-descriptor c-rtd b-rcd
|
||
|
|
(lambda (m)
|
||
|
|
(lambda (q t)
|
||
|
|
(echo "C" ((m (+ q t)) (* q t) (cons q t)))))))
|
||
|
|
(define make-c (r6rs:record-constructor c-rcd))
|
||
|
|
(let ([ls (map a->list (list (make-c 3 4)))])
|
||
|
|
(cons (get-output-string (current-output-port)) ls)))
|
||
|
|
'("C in\nB in\nA in\nA out: #t\nB out: #t\nC out: #t\n"
|
||
|
|
(49 -7 1/7 12 (3 . 4))))
|
||
|
|
(error? ; rtd/rcd mismatch
|
||
|
|
(let ()
|
||
|
|
(define-syntax rtd1 (lambda (x) #`'#,(make-record-type "foo" '(x))))
|
||
|
|
(define-syntax rtd2 (lambda (x) #`'#,(make-record-type rtd1 "bar" '(y))))
|
||
|
|
(define-syntax rtd3 (lambda (x) #`'#,(make-record-type "foo2" '(a b))))
|
||
|
|
(define-syntax rtd4 (lambda (x) #`'#,(make-record-type rtd3 "bar2" '(c d))))
|
||
|
|
(define rcd1
|
||
|
|
(make-record-constructor-descriptor rtd1 #f
|
||
|
|
(lambda (n) (lambda (q) (n (* q q))))))
|
||
|
|
(define rcd3
|
||
|
|
(make-record-constructor-descriptor rtd3 rcd1
|
||
|
|
(lambda (p) (lambda (t u v) ((p t u) v 0)))))
|
||
|
|
(define cons3 (r6rs:record-constructor rcd3))
|
||
|
|
(cons3 1 2 3)))
|
||
|
|
|
||
|
|
; make sure appropriate error checking is done for protocols
|
||
|
|
(error? ; not a procedure (parent protocol)
|
||
|
|
(let ([pprot (cons 'ugly 'ducking)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 0 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; not a procedure (child protocol)
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot 'flimflam])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; not a procedure (returned from parent protocol)
|
||
|
|
(let ([pprot (lambda (n) 'not-a-procedure)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; not a procedure (returned from child protocol)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) 'spam)])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to parent protocol)
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 0 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to parent protocol)
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to parent protocol)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17 'xtra) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to parent protocol)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to child constructor)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1))))
|
||
|
|
(error? ; wrong number of arguments (to child constructor)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3))))
|
||
|
|
(error? ; wrong number of arguments (to parent "new" procedure)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w "what?")))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
(error? ; wrong number of arguments (to child "new" procedure)
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 17) y '#(oops))))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
|
||
|
|
; make sure we can use modifiers and types as field names
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define foo (make-record-type-descriptor 'umph #f #f #f #f '#((mutable mutable) (immutable int) (immutable integer-32))))
|
||
|
|
(let ([x ((r6rs:record-constructor (make-record-constructor-descriptor foo #f #f)) 3 4 5)])
|
||
|
|
((record-mutator foo 0) x 75)
|
||
|
|
(list ($record->vector x)
|
||
|
|
((record-accessor foo 0) x)
|
||
|
|
((record-accessor foo 1) x)
|
||
|
|
((record-accessor foo 2) x))))
|
||
|
|
'(#(umph 75 4 5) 75 4 5))
|
||
|
|
|
||
|
|
; optimization tests---observe with expand/optimize
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3))))
|
||
|
|
'(#(parent 1 2) #(child 1 2 3)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
; same as set above except with r6rs:record-constructor
|
||
|
|
; replaced by record:constructor, which should handle rcds
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (record-constructor prcd))
|
||
|
|
(define ccons (record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3))))
|
||
|
|
'(#(parent 1 2) #(child 1 2 3)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (record-constructor prcd))
|
||
|
|
(define ccons (record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd #f #f))
|
||
|
|
(define pcons (record-constructor prcd))
|
||
|
|
(define ccons (record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing except supplying prcd in place of #f, which should
|
||
|
|
; result in the same residual code
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3))))
|
||
|
|
'(#(parent 1 2) #(child 1 2 3)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f #f))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd #f))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2 3)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 2 3)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; test with variables bound to protocol lambda expressions
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 1 2) #(child 1 0 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 0 2)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x 0) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 0 2)))))
|
||
|
|
(begin (define $global 'worldwide) #t)
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same but with a global variable in place of the constant 0
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 1 2) #(child 1 worldwide 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 $global 2)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x $global) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 $global 2)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same but with a outer lexical variable in place of the constant 0
|
||
|
|
(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(#(parent 1 2) #(child 1 worldwide 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 lex 2))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) n)]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 lex 2))))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same but slightly more complicated parent protocol
|
||
|
|
(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(#(parent 8 2) #(child 8 worldwide 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 lex 2))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) w)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 lex 2))))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same but ignore one of the parent args
|
||
|
|
(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd (make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(#(parent 8 53) #(child 8 53 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(begin $global
|
||
|
|
(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 53)
|
||
|
|
(#3%$record crtd 8 53 2))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ([lex $global])
|
||
|
|
(let ([pprot (lambda (n) (lambda (z w) (n (+ z 7) 53)))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x lex) y)))])
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 53)
|
||
|
|
(#3%$record crtd 8 53 2)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing except pprot and cprot lambda expressions
|
||
|
|
; appear directly in the calls to m-r-c-d
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) n)))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x 0) y)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 1 2) #(child 1 0 2)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f (lambda (n) n)))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x 0) y)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 0 2)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f (lambda (n) n)))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x 0) y)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 1 2)
|
||
|
|
(#3%$record crtd 1 0 2)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing except with slightly more complicated parent protocol
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing but ignore one of the parent args
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) 53)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 53) #(child 8 53 0)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) 53)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 53)
|
||
|
|
(#3%$record crtd 8 53 0)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) 53)))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 53)
|
||
|
|
(#3%$record crtd 8 53 0)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing except don't give a name to the child rcd
|
||
|
|
; surprisingly, this folds up because the call to r6rs:record-constructor
|
||
|
|
; (as with any primitive call) gets pushed into the letrec produced by
|
||
|
|
; make-record-constructor-descriptor
|
||
|
|
; > (print-gensym #f)
|
||
|
|
; > (new-cafe expand/optimize)
|
||
|
|
; >> (#%r6rs:record-constructor (letrec ((x (lambda (n) n))) (foo x)))
|
||
|
|
; (letrec ([x (lambda (n) n)]) (#2%r6rs:record-constructor (foo x)))
|
||
|
|
; >> (#%car (letrec ((x (lambda (n) n))) (foo x)))
|
||
|
|
; (letrec ([x (lambda (n) n)]) (#2%car (foo x)))
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; same thing except give pprot a name
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
|
||
|
|
(define prcd (make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pprot (lambda (n) (lambda (z w) (n (+ z 7) w))))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f pprot))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; push our luck: don't give a name to parent rcd either.
|
||
|
|
; this one doesn't fold up. to fix it, we'd need to (a)
|
||
|
|
; pull the inner m-r-c-d call and outer protocol expr into a
|
||
|
|
; let or letrec wrapping the outer m-r-c-d call, and (b)
|
||
|
|
; pull the bindings for both outside of the r6rs:r-c call ...
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pcons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))))
|
||
|
|
(define ccons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; ... like this (at optimize-level 3, anyway)
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pcons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))))
|
||
|
|
(define ccons
|
||
|
|
(let ([prcd (make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pcons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))))
|
||
|
|
(define ccons
|
||
|
|
(let ([prcd (make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
; this is now as good as it gets at optimize-level 2
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pcons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))))
|
||
|
|
(define ccons
|
||
|
|
(let ([prcd (make-record-constructor-descriptor
|
||
|
|
prtd
|
||
|
|
#f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))]
|
||
|
|
[cprot (lambda (p) (lambda (x y) ((p x y) 0)))])
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor crtd prcd cprot))))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 0)))))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; ... this isn't good enough
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define pcons
|
||
|
|
(r6rs:record-constructor
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))))
|
||
|
|
(define ccons
|
||
|
|
(let ([tmp (make-record-constructor-descriptor crtd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(lambda (n) (lambda (z w) (n (+ z 7) w))))
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) 0))))])
|
||
|
|
(r6rs:record-constructor tmp)))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 0)))
|
||
|
|
(equal?
|
||
|
|
(map $record->vector
|
||
|
|
; try some with inlining
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define (make-prcd f) (make-record-constructor-descriptor prtd #f f))
|
||
|
|
(define prcd (make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define (make-crcd z)
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) z)))))
|
||
|
|
(define crcd (make-crcd -17))
|
||
|
|
(define (make-pcons) (r6rs:record-constructor prcd))
|
||
|
|
(define pcons (make-pcons))
|
||
|
|
(define (make-ccons x) (r6rs:record-constructor x))
|
||
|
|
(define ccons (make-ccons crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2))))
|
||
|
|
'(#(parent 8 2) #(child 8 2 -17)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define (make-prcd f)
|
||
|
|
(make-record-constructor-descriptor prtd #f f))
|
||
|
|
(define prcd
|
||
|
|
(make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define (make-crcd z)
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) z)))))
|
||
|
|
(define crcd (make-crcd -17))
|
||
|
|
(define (make-pcons) (r6rs:record-constructor prcd))
|
||
|
|
(define pcons (make-pcons))
|
||
|
|
(define (make-ccons x) (r6rs:record-constructor x))
|
||
|
|
(define ccons (make-ccons crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 -17)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define (make-prcd f)
|
||
|
|
(make-record-constructor-descriptor prtd #f f))
|
||
|
|
(define prcd
|
||
|
|
(make-prcd (lambda (n) (lambda (z w) (n (+ z 7) w)))))
|
||
|
|
(define (make-crcd z)
|
||
|
|
(make-record-constructor-descriptor
|
||
|
|
crtd
|
||
|
|
prcd
|
||
|
|
(lambda (p) (lambda (x y) ((p x y) z)))))
|
||
|
|
(define crcd (make-crcd -17))
|
||
|
|
(define (make-pcons) (r6rs:record-constructor prcd))
|
||
|
|
(define pcons (make-pcons))
|
||
|
|
(define (make-ccons x) (r6rs:record-constructor x))
|
||
|
|
(define ccons (make-ccons crcd))
|
||
|
|
(list (pcons 1 2) (ccons 1 2)))))
|
||
|
|
'(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%list
|
||
|
|
(#3%$record prtd 8 2)
|
||
|
|
(#3%$record crtd 8 2 -17)))))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([print-vector-length #f])
|
||
|
|
(with-output-to-string
|
||
|
|
; more elaborate test with side effects
|
||
|
|
(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4))))))
|
||
|
|
"(parent #(parent 1 5))\n#(parent 1 5)\n(parent #(child 2 7 1))\n(child #(child 2 7 1))\n#(child 2 7 1)\n")
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(#2%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (#3%$record prtd 1 5)])
|
||
|
|
(#2%pretty-print (#2%list 'parent ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#2%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (#3%$record crtd 2 7 1)])
|
||
|
|
(#2%pretty-print (#2%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#2%pretty-print (#2%list 'child ($record->vector r)))
|
||
|
|
r)))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(#3%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (#3%$record prtd 1 5)])
|
||
|
|
(#3%pretty-print (#3%list 'parent ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#3%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (#3%$record crtd 2 7 1)])
|
||
|
|
(#3%pretty-print (#3%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#3%pretty-print (#3%list 'child ($record->vector r)))
|
||
|
|
r)))))))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([print-vector-length #f])
|
||
|
|
(with-output-to-string
|
||
|
|
; adding a grandchild
|
||
|
|
(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define gcrtd (make-record-type crtd "grand-child" '(w)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define gcrcd
|
||
|
|
(make-record-constructor-descriptor gcrtd crcd
|
||
|
|
(rec gcprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (w x q z)
|
||
|
|
(let ([r ((p z x q 7) (* w 3))])
|
||
|
|
(pretty-print `(grand-child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(define gccons (r6rs:record-constructor gcrcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4)))
|
||
|
|
(pretty-print ($record->vector (gccons 1 2 3 4))))))
|
||
|
|
(format "~
|
||
|
|
(parent #(parent 1 5))\n~
|
||
|
|
#(parent 1 5)\n~
|
||
|
|
(parent #(child 2 7 1))\n~
|
||
|
|
(child #(child 2 7 1))\n~
|
||
|
|
#(child 2 7 1)\n~
|
||
|
|
(parent #(grand-child 2 10 4 3))\n~
|
||
|
|
(child #(grand-child 2 10 4 3))\n~
|
||
|
|
(grand-child #(grand-child 2 10 4 3))\n~
|
||
|
|
#(grand-child 2 10 4 3)\n"))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define gcrtd (make-record-type crtd "grand-child" '(w)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define gcrcd
|
||
|
|
(make-record-constructor-descriptor gcrtd crcd
|
||
|
|
(rec gcprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (w x q z)
|
||
|
|
(let ([r ((p z x q 7) (* w 3))])
|
||
|
|
(pretty-print `(grand-child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(define gccons (r6rs:record-constructor gcrcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4)))
|
||
|
|
(pretty-print ($record->vector (gccons 1 2 3 4))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([prtd (#2%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#2%make-record-type prtd "child" '(z))])
|
||
|
|
(let ([gcrtd (#2%make-record-type crtd "grand-child" '(w))])
|
||
|
|
(#2%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (#3%$record prtd 1 5)])
|
||
|
|
(#2%pretty-print (#2%list 'parent ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#2%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (#3%$record crtd 2 7 1)])
|
||
|
|
(#2%pretty-print (#2%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#2%pretty-print (#2%list 'child ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#2%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)])
|
||
|
|
(#2%pretty-print (#2%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#2%pretty-print (#2%list 'child ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#2%pretty-print (#2%list 'grand-child ($record->vector r)))
|
||
|
|
r))))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define gcrtd (make-record-type crtd "grand-child" '(w)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define gcrcd
|
||
|
|
(make-record-constructor-descriptor gcrtd crcd
|
||
|
|
(rec gcprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (w x q z)
|
||
|
|
(let ([r ((p z x q 7) (* w 3))])
|
||
|
|
(pretty-print `(grand-child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(define gccons (r6rs:record-constructor gcrcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4)))
|
||
|
|
(pretty-print ($record->vector (gccons 1 2 3 4))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([prtd (#3%make-record-type "parent" '(x y))])
|
||
|
|
(let ([crtd (#3%make-record-type prtd "child" '(z))])
|
||
|
|
(let ([gcrtd (#3%make-record-type crtd "grand-child" '(w))])
|
||
|
|
(#3%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (#3%$record prtd 1 5)])
|
||
|
|
(#3%pretty-print (#3%list 'parent ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#3%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (#3%$record crtd 2 7 1)])
|
||
|
|
(#3%pretty-print (#3%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#3%pretty-print (#3%list 'child ($record->vector r)))
|
||
|
|
r)))
|
||
|
|
(#3%pretty-print
|
||
|
|
($record->vector
|
||
|
|
(let ([r (let ([r (let ([r (#3%$record gcrtd 2 10 4 3)])
|
||
|
|
(#3%pretty-print (#3%list 'parent ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#3%pretty-print (#3%list 'child ($record->vector r)))
|
||
|
|
r)])
|
||
|
|
(#3%pretty-print (#3%list 'grand-child ($record->vector r)))
|
||
|
|
r))))))))
|
||
|
|
(error? ; given prcd is not for parent rtd
|
||
|
|
(parameterize ([print-vector-length #f])
|
||
|
|
(with-output-to-string
|
||
|
|
; adding a grandchild
|
||
|
|
(lambda ()
|
||
|
|
(define prtd (make-record-type "parent" '(x y)))
|
||
|
|
(define crtd (make-record-type prtd "child" '(z)))
|
||
|
|
(define gcrtd (make-record-type prtd "grand-child" '(w)))
|
||
|
|
(define prcd
|
||
|
|
(make-record-constructor-descriptor prtd #f
|
||
|
|
(rec pprot
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (x n m)
|
||
|
|
(let ([r (new x (+ n m))])
|
||
|
|
(pretty-print `(parent ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define crcd
|
||
|
|
(make-record-constructor-descriptor crtd prcd
|
||
|
|
(rec cprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (z x n m)
|
||
|
|
(let ([r ((p x n m) z)])
|
||
|
|
(pretty-print `(child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define gcrcd
|
||
|
|
(make-record-constructor-descriptor gcrtd crcd
|
||
|
|
(rec gcprot
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (w x q z)
|
||
|
|
(let ([r ((p z x q 7) (* w 3))])
|
||
|
|
(pretty-print `(grand-child ,($record->vector r)))
|
||
|
|
r))))))
|
||
|
|
(define pcons (r6rs:record-constructor prcd))
|
||
|
|
(define ccons (r6rs:record-constructor crcd))
|
||
|
|
(define gccons (r6rs:record-constructor gcrcd))
|
||
|
|
(pretty-print ($record->vector (pcons 1 2 3)))
|
||
|
|
(pretty-print ($record->vector (ccons 1 2 3 4)))
|
||
|
|
(pretty-print ($record->vector (gccons 1 2 3 4)))))))
|
||
|
|
(eqv?
|
||
|
|
(make-record-type-descriptor 'foo #f '#{rats c7ajhty66y4x1og-a} #f #f '#())
|
||
|
|
(make-record-type-descriptor 'bar #f '#{rats c7ajhty66y4x1og-a} #f #f '#()))
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
|
||
|
|
(record-type-sealed? rtd))
|
||
|
|
#f)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record-type-sealed? rtd))
|
||
|
|
#t)
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record-type-sealed? rtd))))
|
||
|
|
'(begin
|
||
|
|
(#2%make-record-type-descriptor 'bar #f #f #t #f '#0())
|
||
|
|
#t))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record-type-sealed? rtd))))
|
||
|
|
'#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record? ((record-constructor rtd))))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(r6rs:record? ((record-constructor rtd))))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record? ((record-constructor rtd)) rtd))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
|
||
|
|
(define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
|
||
|
|
(record? ((record-constructor crtd)) prtd))
|
||
|
|
#t)
|
||
|
|
(error? ; parent sealed
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
|
||
|
|
(record? ((record-constructor crtd)) prtd)))
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
|
||
|
|
(define crtd (make-record-type-descriptor 'foo prtd #f #f #f '#()))
|
||
|
|
(define xrtd (make-record-type-descriptor 'poo #f #f #f #f '#()))
|
||
|
|
(record? ((record-constructor xrtd)) prtd))
|
||
|
|
#f)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #f #f '#()))
|
||
|
|
(record? x rtd))))
|
||
|
|
'(lambda (x)
|
||
|
|
(#3%record? x (#2%make-record-type-descriptor 'bar #f #f #f #f '#()))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(define rtd (make-record-type-descriptor 'bar #f #f #t #f '#()))
|
||
|
|
(record? x rtd))))
|
||
|
|
'(lambda (x)
|
||
|
|
(#3%$sealed-record? x (#2%make-record-type-descriptor 'bar #f #f #t #f '#0()))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat r6rs-records-procedural2
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17)))))
|
||
|
|
"abcde17")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#2%write (begin (#2%write 'd) (#2%write 'e) 17))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define a (begin (write 'b) (record-accessor (begin (write 'c) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'd) (record-constructor (begin (write 'e) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%write (begin (#3%write 'd) (#3%write 'e) 17))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17)))))
|
||
|
|
"abcbc17")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write
|
||
|
|
(begin
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
17))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-accessor (begin (write 'c) rtd) 0))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write
|
||
|
|
(begin
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
17))))
|
||
|
|
|
||
|
|
((lambda (x y) (and (member x y) #t))
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
|
||
|
|
(define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
|
||
|
|
(write
|
||
|
|
(let ([r qr])
|
||
|
|
((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
|
||
|
|
((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r)))))
|
||
|
|
'("bcbc17" "bcbc23"))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
|
||
|
|
(define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
|
||
|
|
(write
|
||
|
|
(let ([r qr])
|
||
|
|
((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
|
||
|
|
((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r))))))
|
||
|
|
`(lambda ()
|
||
|
|
(#2%write
|
||
|
|
(begin
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#3%$object-set! 'scheme-object ',record? ,fixnum? 23)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
17))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define-syntax rtd (lambda (x) #`(quote #,(make-record-type-descriptor 'foo #f uid #f #f '#((mutable x))))))
|
||
|
|
(define-syntax qr (lambda (x) #`(quote #,((record-constructor rtd) 17))))
|
||
|
|
(write
|
||
|
|
(let ([r qr])
|
||
|
|
((begin (write 'b) (record-mutator (begin (write 'c) rtd) 0)) r 23)
|
||
|
|
((begin (write 'b) (record-accessor (begin (write 'c) (record-rtd r)) 0)) r))))))
|
||
|
|
`(lambda ()
|
||
|
|
(#3%write
|
||
|
|
(begin
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%$object-set! 'scheme-object ',record? ,fixnum? 23)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
17))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17)))))
|
||
|
|
"abcbc#t")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write
|
||
|
|
(begin
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
#t))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(write ((begin (write 'b) (record-predicate (begin (write 'c) rtd)))
|
||
|
|
((begin (write 'b) (record-constructor (begin (write 'c) rtd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write
|
||
|
|
(begin
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
#t))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
|
||
|
|
(define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
|
||
|
|
(define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
|
||
|
|
(write (a x))))
|
||
|
|
"abcdefg17")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
|
||
|
|
(define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
|
||
|
|
(define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
|
||
|
|
(write (a x)))))
|
||
|
|
'(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#2%write 'd)
|
||
|
|
(#2%write 'e)
|
||
|
|
(#2%write 'f)
|
||
|
|
(#2%write 'g)
|
||
|
|
(#2%write 17)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define make (begin (write 'b) (record-constructor (begin (write 'c) rtd))))
|
||
|
|
(define a (begin (write 'd) (record-accessor (begin (write 'e) rtd) 0)))
|
||
|
|
(define x (make (let ((f (begin (write 'f) (lambda (x) x)))) (let ([g (begin (write 'g) (lambda (x) (or x f)))]) (g 3) (g 17)))))
|
||
|
|
(write (a x)))))
|
||
|
|
'(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%write 'd)
|
||
|
|
(#3%write 'e)
|
||
|
|
(#3%write 'f)
|
||
|
|
(#3%write 'g)
|
||
|
|
(#3%write 17)))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
|
||
|
|
(define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17)))))
|
||
|
|
"abcdef17")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
|
||
|
|
(define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'c)
|
||
|
|
(#2%write 'd)
|
||
|
|
(#2%write (begin (#2%write 'e) (#2%write 'f) 17))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd (begin (write 'b) (make-record-constructor-descriptor rtd #f #f)))
|
||
|
|
(define a (begin (write 'c) (record-accessor (begin (write 'd) rtd) 0)))
|
||
|
|
(write (a ((begin (write 'e) (record-constructor (begin (write 'f) rcd))) 17))))))
|
||
|
|
'(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'c)
|
||
|
|
(#3%write 'd)
|
||
|
|
(#3%write (begin (#3%write 'e) (#3%write 'f) 17))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
|
||
|
|
(define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
|
||
|
|
(write (list rcd1 rcd2))))
|
||
|
|
"abab(#<record constructor descriptor> #<record constructor descriptor>)")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
|
||
|
|
(define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
|
||
|
|
(write (list rcd1 rcd2)))))
|
||
|
|
`(lambda ()
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write 'a)
|
||
|
|
(#2%write 'b)
|
||
|
|
(#2%write
|
||
|
|
(#2%list
|
||
|
|
',record-constructor-descriptor?
|
||
|
|
',record-constructor-descriptor?))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define-syntax uid (lambda (x) #`(quote #,(datum->syntax #'* (gensym)))))
|
||
|
|
(define rtd1 (begin (write 'a) (make-record-type-descriptor 'foo #f uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd1 (begin (write 'b) (make-record-constructor-descriptor rtd1 #f #f)))
|
||
|
|
(define rtd2 (begin (write 'a) (make-record-type-descriptor 'foo rtd1 uid #f #f '#((immutable x)))))
|
||
|
|
(define rcd2 (begin (write 'b) (make-record-constructor-descriptor rtd2 rcd1 #f)))
|
||
|
|
(write (list rcd1 rcd2)))))
|
||
|
|
`(lambda ()
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write 'a)
|
||
|
|
(#3%write 'b)
|
||
|
|
(#3%write
|
||
|
|
(#3%list
|
||
|
|
',record-constructor-descriptor?
|
||
|
|
',record-constructor-descriptor?))))
|
||
|
|
|
||
|
|
; test cross-library optimization of record definitions
|
||
|
|
(begin
|
||
|
|
(with-output-to-file "testfile-rrp1.ss"
|
||
|
|
(lambda ()
|
||
|
|
(pretty-print
|
||
|
|
'(library (testfile-rrp1)
|
||
|
|
(export
|
||
|
|
make-bar bar? bar-x
|
||
|
|
make-foo foo? foo-x foo-y foo-x-set!
|
||
|
|
bar-inst foo-inst)
|
||
|
|
(import (chezscheme))
|
||
|
|
(define-record-type bar (fields x))
|
||
|
|
(define-record-type foo (parent bar) (fields (mutable x) y)
|
||
|
|
(protocol (lambda (pargs->new) (lambda (y z) ((pargs->new z) 17 y)))))
|
||
|
|
(define bar-inst (make-bar 7))
|
||
|
|
(define foo-inst (make-foo 13 11)))))
|
||
|
|
'replace)
|
||
|
|
#t)
|
||
|
|
; first, the control, with cp0 disabled
|
||
|
|
(begin
|
||
|
|
(load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([enable-cp0 #f]) (eval x))))
|
||
|
|
#t)
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define ugh
|
||
|
|
(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst)))))
|
||
|
|
(ugh 19))
|
||
|
|
'(#f #f #t #f #t #f #t #t #t #t 23 41 11 7 37 17 31 13))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
'(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([b ((#3%$top-level-value 'make-bar) 23)]
|
||
|
|
[f ((#3%$top-level-value 'make-foo) 31 41)])
|
||
|
|
((#3%$top-level-value 'foo-x-set!) f 37)
|
||
|
|
(#2%list
|
||
|
|
((#3%$top-level-value 'foo?) x)
|
||
|
|
((#3%$top-level-value 'foo?) b)
|
||
|
|
((#3%$top-level-value 'foo?) f)
|
||
|
|
((#3%$top-level-value 'foo?) (#3%$top-level-value 'bar-inst))
|
||
|
|
((#3%$top-level-value 'foo?) (#3%$top-level-value 'foo-inst))
|
||
|
|
((#3%$top-level-value 'bar?) x)
|
||
|
|
((#3%$top-level-value 'bar?) b)
|
||
|
|
((#3%$top-level-value 'bar?) f)
|
||
|
|
((#3%$top-level-value 'bar?) (#3%$top-level-value 'bar-inst))
|
||
|
|
((#3%$top-level-value 'bar?) (#3%$top-level-value 'foo-inst))
|
||
|
|
((#3%$top-level-value 'bar-x) b)
|
||
|
|
((#3%$top-level-value 'bar-x) f)
|
||
|
|
((#3%$top-level-value 'bar-x) (#3%$top-level-value 'foo-inst))
|
||
|
|
((#3%$top-level-value 'bar-x) (#3%$top-level-value 'bar-inst))
|
||
|
|
((#3%$top-level-value 'foo-x) f)
|
||
|
|
((#3%$top-level-value 'foo-x) (#3%$top-level-value 'foo-inst))
|
||
|
|
((#3%$top-level-value 'foo-y) f)
|
||
|
|
((#3%$top-level-value 'foo-y) (#3%$top-level-value 'foo-inst)))))))
|
||
|
|
; now with cp0 enabled and optimize-level 2...also need compiler or cross-library optimization won't occur
|
||
|
|
(begin
|
||
|
|
(load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) (eval x))))
|
||
|
|
#t)
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define ugh
|
||
|
|
(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst)))))
|
||
|
|
(ugh 19))
|
||
|
|
'(#f #f #t #f #t #f #t #t #t #t 23 41 11 7 37 17 31 13))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#2%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(let ([g4 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g4 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g4 ,fixnum?))
|
||
|
|
(let ([g4 (#3%$top-level-value 'bar-inst)])
|
||
|
|
(if (#3%record? g4 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g4 ,fixnum?))
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(let ([g3 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g3 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'foo-x g3 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g3 ,fixnum?))
|
||
|
|
31
|
||
|
|
(let ([g2 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g2 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'foo-y g2 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g2 ,fixnum?)))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#3%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(let ([g4 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g4 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g4 ,fixnum?))
|
||
|
|
(let ([g4 (#3%$top-level-value 'bar-inst)])
|
||
|
|
(if (#3%record? g4 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'bar-x g4 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g4 ,fixnum?))
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(let ([g3 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g3 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'foo-x g3 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g3 ,fixnum?))
|
||
|
|
31
|
||
|
|
(let ([g2 (#3%$top-level-value 'foo-inst)])
|
||
|
|
(if (#3%record? g2 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'foo-y g2 ',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g2 ,fixnum?)))))))
|
||
|
|
; now with cp0 enabled and optimize-level 3...also need compiler or cross-library optimization won't occur
|
||
|
|
(begin
|
||
|
|
(load-library "testfile-rrp1.ss" (lambda (x) (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [current-eval compile]) (eval x))))
|
||
|
|
#t)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#2%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
31
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#3%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
31
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
|
||
|
|
; now compiling to / loading from a file with cp0 enabled and optimize-level 3
|
||
|
|
(begin
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(compile-library "testfile-rrp1.ss"))
|
||
|
|
(load-library "testfile-rrp1.so")
|
||
|
|
#t)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#2%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
31
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(import (testfile-rrp1))
|
||
|
|
(let ([b (make-bar 23)] [f (make-foo 31 41)])
|
||
|
|
(foo-x-set! f 37)
|
||
|
|
(list
|
||
|
|
(foo? x) (foo? b) (foo? f) (foo? bar-inst) (foo? foo-inst)
|
||
|
|
(bar? x) (bar? b) (bar? f) (bar? bar-inst) (bar? foo-inst)
|
||
|
|
(bar-x b) (bar-x f) (bar-x foo-inst) (bar-x bar-inst)
|
||
|
|
(foo-x f) (foo-x foo-inst)
|
||
|
|
(foo-y f) (foo-y foo-inst))))))
|
||
|
|
`(begin
|
||
|
|
(#3%$invoke-library '(testfile-rrp1) '() 'testfile-rrp1)
|
||
|
|
(lambda (x)
|
||
|
|
(let ([f (#3%$record ',record-type-descriptor? 41 17 31)])
|
||
|
|
(#3%$object-set! 'scheme-object f ,fixnum? 37)
|
||
|
|
(#3%list (#3%record? x ',record-type-descriptor?) #f
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? x ',record-type-descriptor?) #t
|
||
|
|
#t
|
||
|
|
(#3%record? (#3%$top-level-value 'bar-inst) ',record-type-descriptor?)
|
||
|
|
(#3%record? (#3%$top-level-value 'foo-inst) ',record-type-descriptor?) 23
|
||
|
|
41
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'bar-inst) ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object f ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?)
|
||
|
|
31
|
||
|
|
(#3%$object-ref 'scheme-object (#3%$top-level-value 'foo-inst) ,fixnum?))))))
|
||
|
|
;; regression tests for cp0 handling of record-mutator when handed a
|
||
|
|
;; (record-rtd rtd expr) directly.
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define build-box
|
||
|
|
(lambda (name k)
|
||
|
|
(let ([gs (gensym (symbol->string name))])
|
||
|
|
(define-syntax mrtd
|
||
|
|
(identifier-syntax
|
||
|
|
(make-record-type-descriptor
|
||
|
|
name #f gs #f #f '#((mutable x)))))
|
||
|
|
(k (record-constructor
|
||
|
|
(make-record-constructor-descriptor mrtd #f #f))
|
||
|
|
(record-predicate mrtd)
|
||
|
|
(record-accessor mrtd 0)
|
||
|
|
(record-mutator mrtd 0)))))
|
||
|
|
(build-box 'record-box
|
||
|
|
(lambda (box box? unbox set-box!)
|
||
|
|
(let ([b (box 4)])
|
||
|
|
(set-box! b (* 3 (unbox b)))
|
||
|
|
(list (box? b) (unbox b))))))))
|
||
|
|
`(let ([gs (#2%gensym "record-box")])
|
||
|
|
(let ([g5 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
|
||
|
|
[g6 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))]
|
||
|
|
[g4 (#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))])
|
||
|
|
(let ([b ((#2%record-constructor
|
||
|
|
(#2%make-record-constructor-descriptor
|
||
|
|
(#2%make-record-type-descriptor 'record-box #f gs #f #f '#((mutable x)))
|
||
|
|
#f #f))
|
||
|
|
4)])
|
||
|
|
(let ([g7 (#2%* 3
|
||
|
|
(begin
|
||
|
|
(if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
|
||
|
|
(#3%$object-ref 'scheme-object b ,fixnum?)))])
|
||
|
|
(if (#3%record? b g4) (#2%void) (#3%$record-oops 'set-box! b g4))
|
||
|
|
(#3%$object-set! 'scheme-object b ,fixnum? g7))
|
||
|
|
(#2%list
|
||
|
|
(#3%record? b g5)
|
||
|
|
(begin
|
||
|
|
(if (#3%record? b g6) (#2%void) (#3%$record-oops 'unbox b g6))
|
||
|
|
(#3%$object-ref 'scheme-object b ,fixnum?)))))))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define build-box
|
||
|
|
(lambda (name k)
|
||
|
|
(let ([gs (gensym (symbol->string name))])
|
||
|
|
(define-syntax mrtd
|
||
|
|
(identifier-syntax
|
||
|
|
(make-record-type-descriptor
|
||
|
|
name #f gs #f #f '#((mutable x)))))
|
||
|
|
(k (record-constructor
|
||
|
|
(make-record-constructor-descriptor mrtd #f #f))
|
||
|
|
(record-predicate mrtd)
|
||
|
|
(record-accessor mrtd 0)
|
||
|
|
(record-mutator mrtd 0)))))
|
||
|
|
(build-box 'record-box
|
||
|
|
(lambda (box box? unbox set-box!)
|
||
|
|
(let ([b (box 4)])
|
||
|
|
(set-box! b (* 3 (unbox b)))
|
||
|
|
(list (box? b) (unbox b))))))
|
||
|
|
'(#t 12))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define useless
|
||
|
|
(lambda (name)
|
||
|
|
(record-mutator (make-record-type-descriptor
|
||
|
|
name #f #f #f #f '#((mutable x))) 0)))
|
||
|
|
(procedure? (useless 'useless-box-setter)))))
|
||
|
|
`(#2%procedure?
|
||
|
|
(let ([g0 (#2%make-record-type-descriptor 'useless-box-setter #f #f #f #f '#((mutable x)))])
|
||
|
|
(lambda (g1 g2)
|
||
|
|
(if (#3%record? g1 g0)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g1 g0))
|
||
|
|
(#3%$object-set! 'scheme-object g1 ,fixnum? g2)))))
|
||
|
|
(let ()
|
||
|
|
(define useless
|
||
|
|
(lambda (name)
|
||
|
|
(record-mutator (make-record-type-descriptor
|
||
|
|
name #f #f #f #f '#((mutable x))) 0)))
|
||
|
|
(procedure? (useless 'useless-box-setter)))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat r6rs-records-syntactic
|
||
|
|
; adapted from r6rs
|
||
|
|
(begin
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
#t)
|
||
|
|
(error? ; invalid syntax
|
||
|
|
point)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point 3))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point 3 4 5))
|
||
|
|
(begin
|
||
|
|
(define p (make-point 3 4))
|
||
|
|
#t)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point?))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point? p p))
|
||
|
|
(point? p)
|
||
|
|
(not (point? '(3 . 4)))
|
||
|
|
(not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
|
||
|
|
(error? ; unbound
|
||
|
|
(point-x-set! p 17))
|
||
|
|
(error? ; unbound
|
||
|
|
(point-y-set! p 17))
|
||
|
|
(eqv? (point-x p) 3)
|
||
|
|
(eqv? (point-y p) 4)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point-x))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point-y p p))
|
||
|
|
(not (eq? p (make-point 3 4)))
|
||
|
|
(not (record-field-mutable? (record-type-descriptor point) 0))
|
||
|
|
(not (record-field-mutable? (record-type-descriptor point) 1))
|
||
|
|
(error? (record-mutator (record-type-descriptor point) 0))
|
||
|
|
(error? (record-mutator (record-type-descriptor point) 1))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define p (make-point 3 4))
|
||
|
|
(and
|
||
|
|
(point? p)
|
||
|
|
(not (point? '(3 . 4)))
|
||
|
|
(not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
|
||
|
|
(eqv? (point-x p) 3)
|
||
|
|
(eqv? (point-y p) 4)
|
||
|
|
(not (eq? p (make-point 3 4)))))
|
||
|
|
|
||
|
|
(begin (set! make-point values) #t)
|
||
|
|
(begin
|
||
|
|
(define-record-type (point make-point point?)
|
||
|
|
(fields
|
||
|
|
(immutable x point-x)
|
||
|
|
(immutable y point-y)))
|
||
|
|
#t)
|
||
|
|
(error? ; invalid syntax
|
||
|
|
point)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point 3))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(make-point 3 4 5))
|
||
|
|
(begin
|
||
|
|
(define p (make-point 3 4))
|
||
|
|
#t)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point?))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point? p p))
|
||
|
|
(point? p)
|
||
|
|
(not (point? '(3 . 4)))
|
||
|
|
(not (point? (let () (define-record-type point (fields x y)) (make-point 3 4))))
|
||
|
|
(error? ; unbound
|
||
|
|
(point-x-set! p 17))
|
||
|
|
(error? ; unbound
|
||
|
|
(point-y-set! p 17))
|
||
|
|
(eqv? (point-x p) 3)
|
||
|
|
(eqv? (point-y p) 4)
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point-x))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(point-y p p))
|
||
|
|
(not (eq? p (make-point 3 4)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type widget (fields x))
|
||
|
|
#t)
|
||
|
|
(begin
|
||
|
|
(define-record-type frob
|
||
|
|
(fields (mutable widget))
|
||
|
|
(protocol
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (n) (p (make-widget n))))))
|
||
|
|
#t)
|
||
|
|
(begin
|
||
|
|
(define f (make-frob 17))
|
||
|
|
#t)
|
||
|
|
(frob? f)
|
||
|
|
(widget? (frob-widget f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set!))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set! f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set! f f f))
|
||
|
|
(eqv? (frob-widget-set! f (list (frob-widget f))) (void))
|
||
|
|
(pair? (frob-widget f))
|
||
|
|
(not (widget? (frob-widget f)))
|
||
|
|
|
||
|
|
(begin (set! make-frob values) #t)
|
||
|
|
(begin
|
||
|
|
(define-record-type (frob make-frob frob?)
|
||
|
|
(fields (mutable widget
|
||
|
|
frob-widget
|
||
|
|
frob-widget-set!))
|
||
|
|
(protocol
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (n) (p (make-widget n))))))
|
||
|
|
#t)
|
||
|
|
(begin
|
||
|
|
(define f (make-frob 17))
|
||
|
|
#t)
|
||
|
|
(frob? f)
|
||
|
|
(widget? (frob-widget f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set!))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set! f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(frob-widget-set! f f f))
|
||
|
|
(eqv? (frob-widget-set! f (list (frob-widget f))) (void))
|
||
|
|
(pair? (frob-widget f))
|
||
|
|
(not (widget? (frob-widget f)))
|
||
|
|
|
||
|
|
(begin (set! make-frob values) #t)
|
||
|
|
(begin
|
||
|
|
(define-record-type frob
|
||
|
|
(fields (mutable widget getwid setwid!))
|
||
|
|
(protocol
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (n) (p (make-widget n))))))
|
||
|
|
#t)
|
||
|
|
(begin
|
||
|
|
(define f (make-frob 17))
|
||
|
|
#t)
|
||
|
|
(frob? f)
|
||
|
|
(widget? (getwid f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(setwid!))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(setwid! f))
|
||
|
|
(error? ; wrong number of arguments
|
||
|
|
(setwid! f f f))
|
||
|
|
(eqv? (setwid! f (list (getwid f))) (void))
|
||
|
|
(pair? (getwid f))
|
||
|
|
(not (widget? (getwid f)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type (point make-point point?)
|
||
|
|
(fields (immutable x point-x)
|
||
|
|
(mutable y point-y set-point-y!))
|
||
|
|
(nongenerative
|
||
|
|
point-4893d957-e00b-11d9-817f-00111175eb9e))
|
||
|
|
(define-record-type (cpoint make-cpoint cpoint?)
|
||
|
|
(parent point)
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c)))))
|
||
|
|
(fields
|
||
|
|
(mutable rgb cpoint-rgb cpoint-rgb-set!)))
|
||
|
|
(define (color->rgb c)
|
||
|
|
(cons 'rgb c))
|
||
|
|
(define p1 (make-point 1 2))
|
||
|
|
(define p2 (make-cpoint 3 4 'red))
|
||
|
|
#t)
|
||
|
|
(point? p1)
|
||
|
|
(point? p2)
|
||
|
|
(not (point? (vector)))
|
||
|
|
(not (point? (cons 'a 'b)))
|
||
|
|
(not (cpoint? p1))
|
||
|
|
(cpoint? p2)
|
||
|
|
(eqv? (point-x p1) 1)
|
||
|
|
(eqv? (point-y p1) 2)
|
||
|
|
(eqv? (point-x p2) 3)
|
||
|
|
(eqv? (point-y p2) 4)
|
||
|
|
(equal? (cpoint-rgb p2) '(rgb . red))
|
||
|
|
(eqv? (set-point-y! p1 17) (void))
|
||
|
|
(eqv? (point-y p1) 17)
|
||
|
|
(record-type-descriptor? (record-rtd p1))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type (ex1 make-ex1 ex1?)
|
||
|
|
(protocol (lambda (p) (lambda a (p a))))
|
||
|
|
(fields (immutable f ex1-f)))
|
||
|
|
(define ex1-i1 (make-ex1 1 2 3))
|
||
|
|
#t)
|
||
|
|
(equal? (ex1-f ex1-i1) '(1 2 3))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type (ex2 make-ex2 ex2?)
|
||
|
|
(protocol
|
||
|
|
(lambda (p) (lambda (a . b) (p a b))))
|
||
|
|
(fields (immutable a ex2-a)
|
||
|
|
(immutable b ex2-b)))
|
||
|
|
(define ex2-i1 (make-ex2 1 2 3))
|
||
|
|
#t)
|
||
|
|
|
||
|
|
(eqv? (ex2-a ex2-i1) 1)
|
||
|
|
(equal? (ex2-b ex2-i1) '(2 3))
|
||
|
|
|
||
|
|
(not (record-type-opaque? (record-type-descriptor ex2)))
|
||
|
|
(not (record-type-sealed? (record-type-descriptor ex2)))
|
||
|
|
(record? ex2-i1)
|
||
|
|
(r6rs:record? ex2-i1)
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define *ex3-instance* #f)
|
||
|
|
(define-record-type ex3
|
||
|
|
(parent cpoint)
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y t)
|
||
|
|
(let ((r ((n x y 'red) t)))
|
||
|
|
(set! *ex3-instance* r)
|
||
|
|
r))))
|
||
|
|
(fields
|
||
|
|
(mutable thickness))
|
||
|
|
(sealed #t) (opaque #t))
|
||
|
|
(define ex3-i1 (make-ex3 1 2 17))
|
||
|
|
#t)
|
||
|
|
(ex3? ex3-i1)
|
||
|
|
(equal? (cpoint-rgb ex3-i1) '(rgb . red))
|
||
|
|
(eqv? (ex3-thickness ex3-i1) 17)
|
||
|
|
(begin
|
||
|
|
(ex3-thickness-set! ex3-i1 18)
|
||
|
|
#t)
|
||
|
|
(eqv? (ex3-thickness ex3-i1) 18)
|
||
|
|
(eqv? *ex3-instance* ex3-i1)
|
||
|
|
|
||
|
|
(record-type-opaque? (record-type-descriptor ex3))
|
||
|
|
(record-type-sealed? (record-type-descriptor ex3))
|
||
|
|
(not (r6rs:record? ex3-i1))
|
||
|
|
(not (record? ex3-i1))
|
||
|
|
(error? ; not a record
|
||
|
|
(record-rtd ex3-i1))
|
||
|
|
(error? ; not a record
|
||
|
|
(record-rtd ex3-i1))
|
||
|
|
(error? ; parent record type is sealed
|
||
|
|
(define-record-type ex3xxx (parent ex3)))
|
||
|
|
(record-type-descriptor? (record-type-descriptor ex3))
|
||
|
|
(record-constructor-descriptor? (record-constructor-descriptor ex3))
|
||
|
|
(equal?
|
||
|
|
(parameterize ([print-gensym 'pretty])
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type f (fields x))
|
||
|
|
(define-record-type g (fields y) (parent f) (opaque #t))
|
||
|
|
(define-record-type h (fields z) (parent g) (opaque #t))
|
||
|
|
(let ([fx (make-f 'a)] [gx (make-g 'a 'b)] [hx (make-h 'a 'b 'c)])
|
||
|
|
(write fx)
|
||
|
|
(write gx)
|
||
|
|
(write hx)
|
||
|
|
(record-writer (record-type-descriptor f)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "#<an f>" p)))
|
||
|
|
(record-writer (record-type-descriptor g)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "#<a g>" p)))
|
||
|
|
(record-writer (record-type-descriptor h)
|
||
|
|
(lambda (x p wr)
|
||
|
|
(display "#<an h x=" p)
|
||
|
|
(wr (f-x x) p)
|
||
|
|
(display " y=" p)
|
||
|
|
(wr (g-y x) p)
|
||
|
|
(display " z=" p)
|
||
|
|
(wr (h-z x) p)
|
||
|
|
(display ">" p)))
|
||
|
|
(write fx)
|
||
|
|
(write gx)
|
||
|
|
(write hx)))))
|
||
|
|
"#[#:f a]#<g>#<h>#<an f>#<a g>#<an h x=a y=b z=c>")
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record-type f (fields x))
|
||
|
|
(define-record-type g (fields y) (parent f) (opaque #t))
|
||
|
|
(define-record-type h (fields z) (parent g) (opaque #t))
|
||
|
|
(list
|
||
|
|
($record->vector
|
||
|
|
(with-input-from-string
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda () (write (make-f "hello"))))
|
||
|
|
read))
|
||
|
|
($record->vector
|
||
|
|
(with-input-from-string
|
||
|
|
(format "#[~s k]"
|
||
|
|
(record-type-uid (record-type-descriptor f)))
|
||
|
|
read))
|
||
|
|
($record->vector
|
||
|
|
(with-input-from-string
|
||
|
|
(format "#[~s k 9]"
|
||
|
|
(record-type-uid (record-type-descriptor g)))
|
||
|
|
read))
|
||
|
|
($record->vector
|
||
|
|
(with-input-from-string
|
||
|
|
(format "#[~s opaque? no problem]"
|
||
|
|
(record-type-uid (record-type-descriptor h)))
|
||
|
|
read))))
|
||
|
|
'(#(f "hello")
|
||
|
|
#(f k)
|
||
|
|
#(g k 9)
|
||
|
|
#(h opaque? no problem)))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define-record-type (unit-vector
|
||
|
|
make-unit-vector
|
||
|
|
unit-vector?)
|
||
|
|
(protocol
|
||
|
|
(lambda (p)
|
||
|
|
(lambda (x y z)
|
||
|
|
(let ((length
|
||
|
|
(sqrt (+ (* x x)
|
||
|
|
(* y y)
|
||
|
|
(* z z)))))
|
||
|
|
(p (/ x length)
|
||
|
|
(/ y length)
|
||
|
|
(/ z length))))))
|
||
|
|
(fields (immutable x unit-vector-x)
|
||
|
|
(immutable y unit-vector-y)
|
||
|
|
(immutable z unit-vector-z)))
|
||
|
|
(define uv (make-unit-vector 3 4 0))
|
||
|
|
#t)
|
||
|
|
(unit-vector? uv)
|
||
|
|
(eqv? (unit-vector-x uv) 3/5)
|
||
|
|
(eqv? (unit-vector-y uv) 4/5)
|
||
|
|
(eqv? (unit-vector-z uv) 0)
|
||
|
|
|
||
|
|
; to avoid gensyms in error messages, hence problems diffing mat output
|
||
|
|
(begin (print-record #f) #t)
|
||
|
|
|
||
|
|
; test generativity
|
||
|
|
(error? ; not a point
|
||
|
|
(let f ([x #f])
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-point 3 4)))))
|
||
|
|
|
||
|
|
(not (let f ([x #f])
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(if x
|
||
|
|
(point? x)
|
||
|
|
(f (make-point 3 4)))))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define ($f p)
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(if (eq? p 'make) (make-point 3 4) (point? p)))
|
||
|
|
(not ($f ($f 'make))))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-point 3 4))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(let f ([x #f])
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(if x
|
||
|
|
(point? x)
|
||
|
|
(f (make-point 3 4))))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define ($f p)
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(if (eq? p 'make) (make-point 3 4) (point? p)))
|
||
|
|
($f ($f 'make)))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define-record-type point (fields x y) (nongenerative spam))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-point 3 4))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(error? ; not a point
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(error? ; not a cpoint
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(error? ; not a cpoint
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(error? ; incompatible record type
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(error? ; incompatible record type
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(rgb . red))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint (nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
'(rgb . red))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0001))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(error? ; not a cpoint
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0002))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(error? ; incompatible record type
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0003)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(error? ; incompatible record type
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0004)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0005)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0006)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(rgb . red))
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0007))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0008)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(point-x x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
3)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0009))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(cpoint-rgb x)
|
||
|
|
(f (make-cpoint 3 4 'red))))
|
||
|
|
'(rgb . red))
|
||
|
|
|
||
|
|
; make sure we can use arbitrary symbols as uids w/o destroying bindings
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (fields x) (nongenerative cons))
|
||
|
|
(make-foo (cons 17 3))))
|
||
|
|
'#(foo (17 . 3)))
|
||
|
|
(equal? (cons 17 3) '(17 . 3))
|
||
|
|
|
||
|
|
; make sure we can use modifiers and types as field names
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (fields (mutable mutable) (immutable int) (immutable char) (mutable integer-32)))
|
||
|
|
(let ([x (make-foo 3 4 5 6)])
|
||
|
|
(foo-mutable-set! x 75)
|
||
|
|
(list ($record->vector x) (foo-mutable x) (foo-int x) (foo-char x) (foo-integer-32 x))))
|
||
|
|
'(#(foo 75 4 5 6) 75 4 5 6))
|
||
|
|
|
||
|
|
(begin (print-record #t) (print-record))
|
||
|
|
|
||
|
|
; optimization tests---observe with expand/optimize
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; try define-record-type
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red))))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red)))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#2%list x (#3%record? x rtd) (#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red)))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#3%list x (#3%record? x rtd) (#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; same but nongenerative w/accessor call
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red))))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red)))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#2%list
|
||
|
|
x
|
||
|
|
(let ([g12 x])
|
||
|
|
(if (#3%record? g12 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'cpoint-rgb g12
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g12 ,fixnum?))
|
||
|
|
',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(nongenerative)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 (color->rgb 'red)))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#3%list x (#3%$object-ref 'scheme-object x ,fixnum?) ',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; same but with child protocol
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#2%list x
|
||
|
|
(#3%record? x rtd)
|
||
|
|
(#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#3%list x
|
||
|
|
(#3%record? x rtd)
|
||
|
|
(#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; same but nongenerative w/accessor call
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0009))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0009))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#2%list
|
||
|
|
x
|
||
|
|
(let ([g35 x])
|
||
|
|
(if (#3%record? g35 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'cpoint-rgb g35
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g35 ,fixnum?))
|
||
|
|
',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point (fields x y) (nongenerative point0009))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#3%list
|
||
|
|
x
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; same as two above but with trivial parent protocol
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) #f #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#2%list
|
||
|
|
x
|
||
|
|
(#3%record? x rtd)
|
||
|
|
(#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#2%cons 'rgb 'red))))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint? x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
'(lambda ()
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'point #f
|
||
|
|
#f #f #f '#2((immutable x) (immutable y))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'cpoint rtd
|
||
|
|
#f #f #f '#1((mutable rgb))
|
||
|
|
'define-record-type)])
|
||
|
|
(if x
|
||
|
|
(#3%list x
|
||
|
|
(#3%record? x rtd)
|
||
|
|
(#3%$record rtd -8 -15))
|
||
|
|
(f (#3%$record rtd 3 4 (#3%cons 'rgb 'red))))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
; same but nongenerative w/accessor call
|
||
|
|
(let f ([x #f])
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(nongenerative point0009)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red)))))
|
||
|
|
'(#(cpoint 3 4 (rgb . red)) (rgb . red) #(point -8 -15)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(nongenerative point0009)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#2%list
|
||
|
|
x
|
||
|
|
(let ([g57 x])
|
||
|
|
(if (#3%record? g57 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'cpoint-rgb g57
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g57 ,fixnum?))
|
||
|
|
',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#2%cons 'rgb 'red))))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda ()
|
||
|
|
(define (color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type point
|
||
|
|
(fields x y)
|
||
|
|
(nongenerative point0009)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type cpoint (nongenerative cpoint0010)
|
||
|
|
(parent point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) (color->rgb c))))))
|
||
|
|
(if x
|
||
|
|
(list x (cpoint-rgb x) (make-point -8 -15))
|
||
|
|
(f (make-cpoint 3 4 'red))))))
|
||
|
|
`(lambda ()
|
||
|
|
(if x
|
||
|
|
(#3%list x
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
',record?)
|
||
|
|
(f (#3%$record ',record-type-descriptor? 3 4 (#3%cons 'rgb 'red))))))
|
||
|
|
(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
|
||
|
|
`(begin
|
||
|
|
(set! $color->rgb (lambda (c) (#2%cons 'rgb c)))
|
||
|
|
(set! $make-point
|
||
|
|
(lambda (g73 g74)
|
||
|
|
(#3%$record ',record-type-descriptor? g73 g74)))
|
||
|
|
(set! $point?
|
||
|
|
(lambda (g72)
|
||
|
|
(#3%record? g72 ',record-type-descriptor?)))
|
||
|
|
(set! $point-x
|
||
|
|
(lambda (g71)
|
||
|
|
(if (#3%record? g71 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g71
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g71 ,fixnum?)))
|
||
|
|
(set! $point-y
|
||
|
|
(lambda (g70)
|
||
|
|
(if (#3%record? g70 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g70
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g70 ,fixnum?)))
|
||
|
|
(set! $make-cpoint
|
||
|
|
(lambda (g67 g68 g69)
|
||
|
|
(#3%$record ',record-type-descriptor? g67 g68 g69)))
|
||
|
|
(set! $cpoint?
|
||
|
|
(lambda (g66)
|
||
|
|
(#3%record? g66 ',record-type-descriptor?)))
|
||
|
|
(set! $cpoint-rgb
|
||
|
|
(lambda (g65)
|
||
|
|
(if (#3%record? g65 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g65
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g65 ,fixnum?)))
|
||
|
|
(set! $cpoint-rgb-set!
|
||
|
|
(lambda (g63 g64)
|
||
|
|
(if (#3%record? g63 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g63
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-set! 'scheme-object g63 ,fixnum? g64)))
|
||
|
|
(#2%equal?
|
||
|
|
(#2%map
|
||
|
|
(lambda (x) (if (#2%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
|
||
|
|
(#2%list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb)))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
|
||
|
|
`(begin
|
||
|
|
(set! $color->rgb (lambda (c) (#3%cons 'rgb c)))
|
||
|
|
(set! $make-point
|
||
|
|
(lambda (g109 g110)
|
||
|
|
(#3%$record ',record-type-descriptor? g109 g110)))
|
||
|
|
(set! $point?
|
||
|
|
(lambda (g108)
|
||
|
|
(#3%record? g108 ',record-type-descriptor?)))
|
||
|
|
(set! $point-x
|
||
|
|
(lambda (g107) (#3%$object-ref 'scheme-object g107 ,fixnum?)))
|
||
|
|
(set! $point-y
|
||
|
|
(lambda (g106) (#3%$object-ref 'scheme-object g106 ,fixnum?)))
|
||
|
|
(set! $make-cpoint
|
||
|
|
(lambda (g103 g104 g105)
|
||
|
|
(#3%$record ',record-type-descriptor? g103 g104 g105)))
|
||
|
|
(set! $cpoint?
|
||
|
|
(lambda (g102)
|
||
|
|
(#3%record? g102 ',record-type-descriptor?)))
|
||
|
|
(set! $cpoint-rgb
|
||
|
|
(lambda (g101)
|
||
|
|
(#3%$object-ref 'scheme-object g101 ,fixnum?)))
|
||
|
|
(set! $cpoint-rgb-set!
|
||
|
|
(lambda (g99 g100)
|
||
|
|
(#3%$object-set! 'scheme-object g99 ,fixnum? g100)))
|
||
|
|
(#3%equal?
|
||
|
|
(#3%map
|
||
|
|
(lambda (x) (if (#3%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 ($color->rgb 'red))])
|
||
|
|
(#3%list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
|
||
|
|
(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) ($color->rgb c))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 'red)])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) ($color->rgb c))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 'red)])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
|
||
|
|
`(begin
|
||
|
|
(set! $color->rgb (lambda (c) (#2%cons 'rgb c)))
|
||
|
|
(letrec ([g7 (lambda (n) n)])
|
||
|
|
(#3%$set-top-level-value! 'rcd1
|
||
|
|
(#3%$make-record-constructor-descriptor
|
||
|
|
',record-type-descriptor? #f g7 'define-record-type)))
|
||
|
|
(set! $make-point (#2%r6rs:record-constructor (#2%$top-level-value 'rcd1)))
|
||
|
|
(set! $point?
|
||
|
|
(lambda (g153)
|
||
|
|
(#3%record? g153 ',record-type-descriptor?)))
|
||
|
|
(set! $point-x
|
||
|
|
(lambda (g152)
|
||
|
|
(if (#3%record? g152 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g152
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g152 ,fixnum?)))
|
||
|
|
(set! $point-y
|
||
|
|
(lambda (g151)
|
||
|
|
(if (#3%record? g151 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g151
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g151 ,fixnum?)))
|
||
|
|
(#3%$set-top-level-value! 'rcd2
|
||
|
|
(#2%$make-record-constructor-descriptor
|
||
|
|
',record-type-descriptor? (#2%$top-level-value 'rcd1)
|
||
|
|
(lambda (n) (lambda (x y c) ((n x y) ($color->rgb c))))
|
||
|
|
'define-record-type))
|
||
|
|
(set! $make-cpoint (#2%r6rs:record-constructor (#2%$top-level-value 'rcd2)))
|
||
|
|
(set! $cpoint?
|
||
|
|
(lambda (g150)
|
||
|
|
(#3%record? g150 ',record-type-descriptor?)))
|
||
|
|
(set! $cpoint-rgb
|
||
|
|
(lambda (g149)
|
||
|
|
(if (#3%record? g149 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g149
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-ref 'scheme-object g149 ,fixnum?)))
|
||
|
|
(set! $cpoint-rgb-set!
|
||
|
|
(lambda (g147 g148)
|
||
|
|
(if (#3%record? g147 ',record-type-descriptor?)
|
||
|
|
(#2%void)
|
||
|
|
(#3%$record-oops 'moi g147
|
||
|
|
',record-type-descriptor?))
|
||
|
|
(#3%$object-set! 'scheme-object g147 ,fixnum? g148)))
|
||
|
|
(#2%equal?
|
||
|
|
(#2%map
|
||
|
|
(lambda (x) (if (#2%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 'red)])
|
||
|
|
(#2%list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(begin
|
||
|
|
; test global define-record-type
|
||
|
|
(define ($color->rgb c) (cons 'rgb c))
|
||
|
|
(define-record-type ($point $make-point $point?)
|
||
|
|
(fields x y)
|
||
|
|
(protocol (lambda (n) n)))
|
||
|
|
(define-record-type ($cpoint $make-cpoint $cpoint?)
|
||
|
|
(parent $point)
|
||
|
|
(fields (mutable rgb))
|
||
|
|
(protocol
|
||
|
|
(lambda (n)
|
||
|
|
(lambda (x y c)
|
||
|
|
((n x y) ($color->rgb c))))))
|
||
|
|
(equal?
|
||
|
|
(map (lambda (x) (if (#%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 'red)])
|
||
|
|
(list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#($cpoint 3 4 (rgb . red)) (rgb . red) #($point -8 -15))))))
|
||
|
|
`(begin
|
||
|
|
(set! $color->rgb (lambda (c) (#3%cons 'rgb c)))
|
||
|
|
(letrec ([g7 (lambda (n) n)])
|
||
|
|
(#3%$set-top-level-value! 'rcd1
|
||
|
|
(#3%$make-record-constructor-descriptor
|
||
|
|
',record-type-descriptor? #f g7 'define-record-type)))
|
||
|
|
(set! $make-point (#3%r6rs:record-constructor (#3%$top-level-value 'rcd1)))
|
||
|
|
(set! $point?
|
||
|
|
(lambda (g129)
|
||
|
|
(#3%record? g129 ',record-type-descriptor?)))
|
||
|
|
(set! $point-x
|
||
|
|
(lambda (g128) (#3%$object-ref 'scheme-object g128 ,fixnum?)))
|
||
|
|
(set! $point-y
|
||
|
|
(lambda (g127) (#3%$object-ref 'scheme-object g127 ,fixnum?)))
|
||
|
|
(#3%$set-top-level-value! 'rcd2
|
||
|
|
(#3%$make-record-constructor-descriptor ',record-type-descriptor?
|
||
|
|
(#3%$top-level-value 'rcd1)
|
||
|
|
(lambda (n) (lambda (x y c) ((n x y) ($color->rgb c))))
|
||
|
|
'define-record-type))
|
||
|
|
(set! $make-cpoint (#3%r6rs:record-constructor (#3%$top-level-value 'rcd2)))
|
||
|
|
(set! $cpoint?
|
||
|
|
(lambda (g126)
|
||
|
|
(#3%record? g126 ',record-type-descriptor?)))
|
||
|
|
(set! $cpoint-rgb
|
||
|
|
(lambda (g125)
|
||
|
|
(#3%$object-ref 'scheme-object g125 ,fixnum?)))
|
||
|
|
(set! $cpoint-rgb-set!
|
||
|
|
(lambda (g123 g124)
|
||
|
|
(#3%$object-set! 'scheme-object g123 ,fixnum? g124)))
|
||
|
|
(#3%equal?
|
||
|
|
(#3%map
|
||
|
|
(lambda (x) (if (#3%$record? x) ($record->vector x) x))
|
||
|
|
(let ([x ($make-cpoint 3 4 'red)])
|
||
|
|
(#3%list x ($cpoint-rgb x) ($make-point -8 -15))))
|
||
|
|
'(#4($cpoint 3 4 (rgb . red)) (rgb . red) #3($point -8 -15)))))
|
||
|
|
(error? ; can't handle define-record-type parent
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat)
|
||
|
|
(define-record dormy fratrat ())))
|
||
|
|
(error? ; can't handle define-record parent
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ())
|
||
|
|
(define-record-type dormy (parent fratrat))))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ())
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
|
||
|
|
(let ([x (make-fratrat)] [y (make-dormy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))
|
||
|
|
'(#t #f #t #t))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ())
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
|
||
|
|
(let ([x (make-fratrat)] [y (make-dormy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))))
|
||
|
|
`(begin
|
||
|
|
(#2%$make-record-type-descriptor #!base-rtd 'dormy
|
||
|
|
',record-type-descriptor? #f #f #f '#0()
|
||
|
|
'define-record-type)
|
||
|
|
(#2%list #t #f #t #t)))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ())
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f)))
|
||
|
|
(let ([x (make-fratrat)] [y (make-dormy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y))))))
|
||
|
|
`(#3%list #t #f #t #t))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))
|
||
|
|
'(#t #f #t #t 17 23 creepy))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'dormy
|
||
|
|
',record-type-descriptor? #f #f #f
|
||
|
|
'#1((immutable y)) 'define-record-type)])
|
||
|
|
(let ([x (#3%$record ',record-type-descriptor? 17)]
|
||
|
|
[y (#3%$record rtd 23 'creepy)])
|
||
|
|
(#2%list #t #f #t #t
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object y ,fixnum?)
|
||
|
|
'creepy))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'dormy
|
||
|
|
',record-type-descriptor? #f #f #f
|
||
|
|
'#1((immutable y)) 'define-record-type)])
|
||
|
|
(let ([x (#3%$record ',record-type-descriptor? 17)]
|
||
|
|
[y (#3%$record rtd 23 'creepy)])
|
||
|
|
(#3%list #t #f #t #t
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object y ,fixnum?)
|
||
|
|
'creepy))))
|
||
|
|
(equal?
|
||
|
|
(let () ; add a protocol
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y))
|
||
|
|
(protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))
|
||
|
|
'(#t #f #t #t 17 23 (23 creepy)))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y))
|
||
|
|
(protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'dormy
|
||
|
|
',record-type-descriptor? #f #f #f
|
||
|
|
'#1((immutable y)) 'define-record-type)])
|
||
|
|
(let ([x (#3%$record ',record-type-descriptor? 17)]
|
||
|
|
[y (#3%$record rtd 23 '(23 creepy))])
|
||
|
|
(#2%list #t #f #t #t
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object y ,fixnum?)
|
||
|
|
'(23 creepy)))))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat (x))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y))
|
||
|
|
(protocol (lambda (p) (lambda (q) ((p (car q)) q)))))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy '(23 creepy))])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'dormy
|
||
|
|
',record-type-descriptor? #f #f #f
|
||
|
|
'#1((immutable y)) 'define-record-type)])
|
||
|
|
(let ([x (#3%$record ',record-type-descriptor? 17)]
|
||
|
|
[y (#3%$record rtd 23 '(23 creepy))])
|
||
|
|
(#3%list #t #f #t #t
|
||
|
|
(#3%$object-ref 'scheme-object x ,fixnum?)
|
||
|
|
(#3%$object-ref 'scheme-object y ,fixnum?)
|
||
|
|
'(23 creepy)))))
|
||
|
|
(error? ; m-r-c-d can't handle non-scheme-object fields
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable integer-32 x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(nongenerative)
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))
|
||
|
|
'(#t #f #t #t 17 23 creepy))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(nongenerative)
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(#2%list #t #f #t #t 17 23 'creepy))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(nongenerative)
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(#3%list #t #f #t #t 17 23 'creepy))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-0} '((immutable y))))
|
||
|
|
(define make-dormy (record-constructor dormy))
|
||
|
|
(define dormy? (record-predicate dormy))
|
||
|
|
(define dormy-y (record-accessor dormy 0))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))
|
||
|
|
'(#t #f #t #t 17 23 creepy))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above (note dormy gensym must be different)
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-1} '((immutable y))))
|
||
|
|
(define make-dormy (record-constructor dormy))
|
||
|
|
(define dormy? (record-predicate dormy))
|
||
|
|
(define dormy-y (record-accessor dormy 0))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(#2%list #t #f #t #t 17 23 'creepy))
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above (note dormy gensym must be different)
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define dormy (make-record-type (type-descriptor fratrat) '#{dormy a3utgl1aoz8jzrg1-2} '((immutable y))))
|
||
|
|
(define make-dormy (record-constructor dormy))
|
||
|
|
(define dormy? (record-predicate dormy))
|
||
|
|
(define dormy-y (record-accessor dormy 0))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y))))))
|
||
|
|
`(#3%list #t #f #t #t 17 23 'creepy))
|
||
|
|
(error? ; can't have both parent and parent-rtd
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have both parent and parent-rtd
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(parent fratrat2)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two parent-rtd clauses
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two parent clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(parent fratrat2)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two fields clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(fields z)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two nongenerative clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(nongenerative)
|
||
|
|
(nongenerative spam-for-dinner)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two sealed? clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(sealed #t)
|
||
|
|
(sealed #t)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two opaque? clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(opaque #t)
|
||
|
|
(opaque #t)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; can't have two protocol clauses
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(protocol values)
|
||
|
|
(protocol (lambda (x) x))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; protocol expression doesn't evaluate to a procedure
|
||
|
|
(let ()
|
||
|
|
(define-record-type fratrat2 (fields (immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent fratrat2)
|
||
|
|
(protocol 'whoops!)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; not an rcd
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd
|
||
|
|
(type-descriptor fratrat)
|
||
|
|
'rats)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(error? ; not an rtd
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd 'rats
|
||
|
|
(make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (fratrat-x y) (dormy-y y)))))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd #f #f)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (dormy-y y))))
|
||
|
|
'(#t #f #f #t 17 creepy))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd (record-type-descriptor fratrat) #f)
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 23 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (dormy-y y))))
|
||
|
|
'(#t #f #t #t 17 creepy))
|
||
|
|
(error? ; "can't specify rcd w/o rtd"
|
||
|
|
(let ()
|
||
|
|
(define-record fratrat ((immutable x)))
|
||
|
|
(define-record-type dormy
|
||
|
|
(parent-rtd #f (make-record-constructor-descriptor (type-descriptor fratrat) #f #f))
|
||
|
|
(fields (immutable y)))
|
||
|
|
(let ([x (make-fratrat 17)] [y (make-dormy 'creepy)])
|
||
|
|
(list (fratrat? x) (dormy? x) (fratrat? y) (dormy? y)
|
||
|
|
(fratrat-x x) (dormy-y y)))))
|
||
|
|
(error? ; invalid syntax
|
||
|
|
(define-record-type (fields x)))
|
||
|
|
(error? ; invalid clause
|
||
|
|
(define-record-type foo (x)))
|
||
|
|
(error? ; invalid clause
|
||
|
|
(define-record-type foo (fields . x)))
|
||
|
|
(error? ; invalid field
|
||
|
|
(define-record-type foo (fields (mutable flyboy flyboy))))
|
||
|
|
(error? ; invalid field
|
||
|
|
(define-record-type foo (fields (immutable flyboy flyboy flyboy!))))
|
||
|
|
(error? ; invalid field
|
||
|
|
(define-record-type foo (fields (ugly flyboy))))
|
||
|
|
(error? ; invalid clause
|
||
|
|
(define-record-type foo (nongenerative 'spam)))
|
||
|
|
(error? ; cannot handle record name defined by define-record
|
||
|
|
(let ()
|
||
|
|
(define-record frob ())
|
||
|
|
(record-constructor-descriptor frob)))
|
||
|
|
(error? ; invalid protocol value
|
||
|
|
(define-record-type frob (protocol 'oops)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (nongenerative #{rats c9zu8koxo8gppgp-a}))
|
||
|
|
(define-record-type bar (nongenerative #{rats c9zu8koxo8gppgp-a}))
|
||
|
|
(and
|
||
|
|
(eqv? (type-descriptor foo) (type-descriptor bar))
|
||
|
|
(foo? (make-bar))
|
||
|
|
(bar? (make-foo))))
|
||
|
|
|
||
|
|
; test for appropriate choice of pretty names for uids
|
||
|
|
((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo)
|
||
|
|
(record-type-uid (record-type-descriptor foo)))
|
||
|
|
"foo")
|
||
|
|
|
||
|
|
; test for appropriate choice of pretty names for uids
|
||
|
|
((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type (foo xfoo yfoo))
|
||
|
|
(record-type-uid (record-type-descriptor foo)))
|
||
|
|
"foo")
|
||
|
|
|
||
|
|
; test for appropriate choice of pretty names for uids
|
||
|
|
((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (nongenerative))
|
||
|
|
(record-type-uid (record-type-descriptor foo)))
|
||
|
|
"foo")
|
||
|
|
|
||
|
|
; test for appropriate choice of pretty names for uids
|
||
|
|
((lambda (x y) (and (gensym? x) (equal? (symbol->string x) y)))
|
||
|
|
(let ()
|
||
|
|
(define-record-type (foo xfoo yfoo) (nongenerative))
|
||
|
|
(record-type-uid (record-type-descriptor foo)))
|
||
|
|
"foo")
|
||
|
|
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type bar)
|
||
|
|
(record-type-sealed? (record-type-descriptor bar)))
|
||
|
|
#f)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record-type-sealed? (record-type-descriptor bar)))
|
||
|
|
#t)
|
||
|
|
(equivalent-expansion? ; optimize-level 2 expansion of above
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record-type-sealed? (record-type-descriptor bar)))))
|
||
|
|
'(begin
|
||
|
|
(#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #t #f '#() 'define-record-type)
|
||
|
|
#t))
|
||
|
|
(equivalent-expansion? ; optimize-level 3 expansion of above
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record-type-sealed? (record-type-descriptor bar)))))
|
||
|
|
'#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record? (make-bar)))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(r6rs:record? (make-bar)))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record? (make-bar) (record-type-descriptor bar)))
|
||
|
|
#t)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type prnt)
|
||
|
|
(define-record-type chld (parent prnt))
|
||
|
|
(record? (make-chld) (record-type-descriptor prnt)))
|
||
|
|
#t)
|
||
|
|
(error? ; parent sealed
|
||
|
|
(let ()
|
||
|
|
(define-record-type prnt (sealed #t))
|
||
|
|
(define-record-type chld (parent prnt))
|
||
|
|
(record? (make-chld) (record-type-descriptor prnt))))
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type prnt)
|
||
|
|
(define-record-type chld (parent prnt))
|
||
|
|
(define-record-type xftr)
|
||
|
|
(record? (make-xftr) (record-type-descriptor prnt)))
|
||
|
|
#f)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(define-record-type bar)
|
||
|
|
(record? x (record-type-descriptor bar)))))
|
||
|
|
'(lambda (x)
|
||
|
|
(#3%record? x (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #f #f '#() 'define-record-type))))
|
||
|
|
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (x)
|
||
|
|
(define-record-type bar (sealed #t))
|
||
|
|
(record? x (record-type-descriptor bar)))))
|
||
|
|
'(lambda (x)
|
||
|
|
(#3%$sealed-record? x (#2%$make-record-type-descriptor #!base-rtd 'bar #f #f #t #f '#() 'define-record-type))))
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z))))))
|
||
|
|
(make-C 4)))
|
||
|
|
'#(C 4))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z))))))
|
||
|
|
(make-C 4))))
|
||
|
|
`',record?)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda () ((make) 0)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields)
|
||
|
|
(protocol (lambda (make) (lambda () ((make))))))
|
||
|
|
(make-C)))
|
||
|
|
'#(C 0))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda () ((make) 0)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields)
|
||
|
|
(protocol (lambda (make) (lambda () ((make))))))
|
||
|
|
(make-C))))
|
||
|
|
`',record?)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0)))))
|
||
|
|
(make-C 4)))
|
||
|
|
'#(C 4 0))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0)))))
|
||
|
|
(make-C 4))))
|
||
|
|
`',record?)
|
||
|
|
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w q1 q2 q3)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
|
||
|
|
(make-C 4)))
|
||
|
|
'#(C 4 0 1 2 3))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w q1 q2 q3)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
|
||
|
|
(make-C 4))))
|
||
|
|
`',record?)
|
||
|
|
|
||
|
|
; try hierarchy of five levels
|
||
|
|
(equal?
|
||
|
|
($record->vector
|
||
|
|
(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w q1 q2 q3)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
|
||
|
|
(define-record-type D
|
||
|
|
(nongenerative)
|
||
|
|
(parent C)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z w/2) ((make z) (* w/2 2))))))
|
||
|
|
(define-record-type E
|
||
|
|
(nongenerative)
|
||
|
|
(parent D)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z a b) ((make z (/ a 5)) (+ a b))))))
|
||
|
|
(make-E 3 7 11)))
|
||
|
|
'#(E 3 0 1 2 3 14/5 18))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type A
|
||
|
|
(nongenerative)
|
||
|
|
(fields))
|
||
|
|
(define-record-type B
|
||
|
|
(nongenerative)
|
||
|
|
(parent A)
|
||
|
|
(fields z)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make) z)))))
|
||
|
|
(define-record-type C
|
||
|
|
(nongenerative)
|
||
|
|
(parent B)
|
||
|
|
(fields w q1 q2 q3)
|
||
|
|
(protocol (lambda (make) (lambda (z) ((make z) 0 1 2 3)))))
|
||
|
|
(define-record-type D
|
||
|
|
(nongenerative)
|
||
|
|
(parent C)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z w/2) ((make z) (* w/2 2))))))
|
||
|
|
(define-record-type E
|
||
|
|
(nongenerative)
|
||
|
|
(parent D)
|
||
|
|
(fields w)
|
||
|
|
(protocol (lambda (make) (lambda (z a b) ((make z (/ a 5)) (+ a b))))))
|
||
|
|
(make-E 3 7 11))))
|
||
|
|
`',record?)
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(module ($drt-foo1)
|
||
|
|
(define-record-type $drt-foo1
|
||
|
|
(protocol (lambda (new) (lambda () (new))))))
|
||
|
|
(define-record-type $drt-bar1
|
||
|
|
(parent $drt-foo1)
|
||
|
|
(protocol (lambda (make-new) (lambda () ((make-new))))))
|
||
|
|
($drt-bar1? (make-$drt-bar1)))
|
||
|
|
($drt-bar1? (make-$drt-bar1))
|
||
|
|
|
||
|
|
(begin
|
||
|
|
(define $drt-false #f)
|
||
|
|
(module ($drt-foo2)
|
||
|
|
(define-record-type $drt-foo2
|
||
|
|
(parent-rtd $drt-false $drt-false)
|
||
|
|
(protocol (lambda (new) (lambda () (new))))))
|
||
|
|
(define-record-type $drt-bar2
|
||
|
|
(parent $drt-foo2)
|
||
|
|
(protocol (lambda (make-new) (lambda () ((make-new))))))
|
||
|
|
($drt-bar2? (make-$drt-bar2)))
|
||
|
|
($drt-bar2? (make-$drt-bar2))
|
||
|
|
|
||
|
|
; make sure record accessor isn't folded when applied to
|
||
|
|
; the wrong type of constant argument
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (b)
|
||
|
|
(let ([x 'x])
|
||
|
|
(define-record-type frob (nongenerative) (fields x))
|
||
|
|
(if b (frob-x x) 72)))))
|
||
|
|
`(lambda (b)
|
||
|
|
(if b
|
||
|
|
(begin
|
||
|
|
(#3%$record-oops 'frob-x 'x ',record-type-descriptor?)
|
||
|
|
(#3%$object-ref 'scheme-object 'x ,fixnum?))
|
||
|
|
72)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (b)
|
||
|
|
(let ([x 'x])
|
||
|
|
(define-record-type frob (nongenerative) (fields x))
|
||
|
|
(if b (frob-x x) 72)))))
|
||
|
|
`(lambda (b)
|
||
|
|
(if b
|
||
|
|
(#3%$object-ref 'scheme-object 'x ,fixnum?)
|
||
|
|
72)))
|
||
|
|
; ensure we're checking to make sure field names, accessors, and
|
||
|
|
; mutators are identifiers
|
||
|
|
(error? ; invalid field spec
|
||
|
|
(define-record-type foo (fields 876)))
|
||
|
|
(error? ; invalid field spec
|
||
|
|
(define-record-type foo (fields (mutable (x)))))
|
||
|
|
(error? ; invalid field spec
|
||
|
|
(define-record-type foo (fields (immutable "spam"))))
|
||
|
|
(error? ; invalid field spec
|
||
|
|
(define-record-type foo (fields (immutable (x) foo-x))))
|
||
|
|
(error? ; invalid accessor name
|
||
|
|
(define-record-type foo (fields (immutable x (foo-x)))))
|
||
|
|
(error? ; invalid field spec
|
||
|
|
(define-record-type foo (fields (mutable (x) foo-x foo-x!))))
|
||
|
|
(error? ; invalid accessor name
|
||
|
|
(define-record-type foo (fields (mutable x (foo-x) foo-x!))))
|
||
|
|
(error? ; invalid accessor name
|
||
|
|
(define-record-type foo (fields (mutable x foo-x (foo-x!)))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat define-record-type-extensions
|
||
|
|
(error? ; nongenerative clause missing
|
||
|
|
(parameterize ([require-nongenerative-clause #t])
|
||
|
|
(eval '
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo)
|
||
|
|
make-foo))))
|
||
|
|
(procedure?
|
||
|
|
(parameterize ([require-nongenerative-clause #t])
|
||
|
|
(eval '
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (nongenerative #f))
|
||
|
|
make-foo))))
|
||
|
|
(procedure?
|
||
|
|
(parameterize ([require-nongenerative-clause #t])
|
||
|
|
(eval '
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (nongenerative))
|
||
|
|
make-foo))))
|
||
|
|
(procedure?
|
||
|
|
(parameterize ([require-nongenerative-clause #t])
|
||
|
|
(eval '
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (nongenerative #{foo e7akngbfn4x0395fvq3uor-0}))
|
||
|
|
make-foo))))
|
||
|
|
((lambda (ls) (not (apply eq? ls)))
|
||
|
|
(let ()
|
||
|
|
(define f
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type foo (nongenerative #f))
|
||
|
|
(record-type-descriptor foo)))
|
||
|
|
(list (f) (f))))
|
||
|
|
((lambda (ls) (apply eq? ls))
|
||
|
|
(let ()
|
||
|
|
(define f
|
||
|
|
(lambda ()
|
||
|
|
(define-record-type foo (nongenerative))
|
||
|
|
(record-type-descriptor foo)))
|
||
|
|
(list (f) (f))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat cp0-record-ref-optimizations
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (fields x))
|
||
|
|
(let ([x 17])
|
||
|
|
(let ([q (make-foo x)])
|
||
|
|
(set! x 43)
|
||
|
|
(foo-x q))))
|
||
|
|
17)
|
||
|
|
(eqv?
|
||
|
|
(let ()
|
||
|
|
(define-record-type foo (fields x))
|
||
|
|
(let ([x 17])
|
||
|
|
(let ([q (make-foo x)])
|
||
|
|
#;(set! x 43)
|
||
|
|
(foo-x q))))
|
||
|
|
17)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type foo (fields x))
|
||
|
|
(let ([x 17])
|
||
|
|
(let ([q (make-foo x)])
|
||
|
|
#;(set! x 43)
|
||
|
|
(foo-x q))))))
|
||
|
|
17)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record-type foo (fields x))
|
||
|
|
(let ([x 17])
|
||
|
|
(let ([q (make-foo x)])
|
||
|
|
(set! x 43)
|
||
|
|
(foo-x q))))))
|
||
|
|
`(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x))
|
||
|
|
'define-record-type)])
|
||
|
|
(let ([x 17])
|
||
|
|
(let ([q (#3%$record rtd x)])
|
||
|
|
(set! x 43)
|
||
|
|
(#3%$object-ref 'scheme-object q ,fixnum?)))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (fields x y))
|
||
|
|
(let ([q (make-foo a 3)])
|
||
|
|
(list (foo-x q) (foo-y q))))))
|
||
|
|
'(lambda (a)
|
||
|
|
(#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x) (immutable y))
|
||
|
|
'define-record-type)
|
||
|
|
(#2%list a 3)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (fields x y))
|
||
|
|
(let ([q (make-foo a 3)])
|
||
|
|
(list (foo-x q) (foo-y q))))))
|
||
|
|
'(lambda (a) (#3%list a 3)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (nongenerative) (fields x y))
|
||
|
|
(let ([q (make-foo a 3)])
|
||
|
|
(list (foo-x q) (foo-y q))))))
|
||
|
|
'(lambda (a) (#2%list a 3)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (nongenerative) (fields x y))
|
||
|
|
(let ([q (make-foo a 3)])
|
||
|
|
(list (foo-x q) (foo-y q))))))
|
||
|
|
'(lambda (a) (#3%list a 3)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (fields x y))
|
||
|
|
(let ([q (make-foo (cons a a) (lambda () a))])
|
||
|
|
(list (foo-x q) ((foo-y q)))))))
|
||
|
|
'(lambda (a)
|
||
|
|
(#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable x) (immutable y))
|
||
|
|
'define-record-type)
|
||
|
|
(#2%list (#2%cons a a) a)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (fields x y))
|
||
|
|
(let ([q (make-foo (cons a a) (lambda () a))])
|
||
|
|
(list (foo-x q) ((foo-y q)))))))
|
||
|
|
'(lambda (a) (#3%list (#3%cons a a) a)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (nongenerative) (fields x y))
|
||
|
|
(let ([q (make-foo (cons a a) (lambda () a))])
|
||
|
|
(list (foo-x q) ((foo-y q)))))))
|
||
|
|
'(lambda (a) (#2%list (#2%cons a a) a)))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (a)
|
||
|
|
(define-record-type foo (nongenerative) (fields x y))
|
||
|
|
(let ([q (make-foo (cons a a) (lambda () a))])
|
||
|
|
(list (foo-x q) ((foo-y q)))))))
|
||
|
|
'(lambda (a) (#3%list (#3%cons a a) a)))
|
||
|
|
; oscar's example
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record foo ([immutable ptr a] [immutable ptr b]))
|
||
|
|
(define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([r (make-foo 37 x)]
|
||
|
|
[r (inc r)]
|
||
|
|
[r (inc r)])
|
||
|
|
r)))))
|
||
|
|
`(lambda (x) (#3%$record ',record-type-descriptor? 37 (#2%+ 1 (#2%+ 1 x)))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f] [compile-profile #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record foo ([immutable ptr a] [immutable ptr b]))
|
||
|
|
(define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([r (make-foo 37 x)]
|
||
|
|
[r (inc r)]
|
||
|
|
[r (inc r)])
|
||
|
|
r)))))
|
||
|
|
`(lambda (x) (#3%$record ',record-type-descriptor? 37 (#3%+ 1 (#3%+ 1 x)))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record-type foo (fields a b))
|
||
|
|
(define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([r (make-foo 37 x)]
|
||
|
|
[r (inc r)]
|
||
|
|
[r (inc r)])
|
||
|
|
r)))))
|
||
|
|
'(let ([rtd (#2%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b)) 'define-record-type)])
|
||
|
|
(lambda (x) (#3%$record rtd 37 (#2%+ 1 (#2%+ 1 x))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record-type foo (fields a b))
|
||
|
|
(define (inc r) (make-foo (foo-a r) (+ (foo-b r) 1)))
|
||
|
|
(lambda (x)
|
||
|
|
(let* ([r (make-foo 37 x)]
|
||
|
|
[r (inc r)]
|
||
|
|
[r (inc r)])
|
||
|
|
r)))))
|
||
|
|
'(let ([rtd (#3%$make-record-type-descriptor #!base-rtd 'foo #f #f #f #f '#((immutable a) (immutable b))
|
||
|
|
'define-record-type)])
|
||
|
|
(lambda (x) (#3%$record rtd 37 (#3%+ 1 (#3%+ 1 x))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record-type foo
|
||
|
|
(nongenerative)
|
||
|
|
(fields a b)
|
||
|
|
(protocol
|
||
|
|
(let ([ctr 0])
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (q)
|
||
|
|
(let ([x (begin (set! ctr (+ xtr 1)) ctr)])
|
||
|
|
(new q x)))))))
|
||
|
|
(make-foo 3))))
|
||
|
|
`(let ([ctr 0])
|
||
|
|
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#2%+ 1 xtr)) ctr))))])
|
||
|
|
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
|
||
|
|
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#2%+ 1 xtr)) ctr)))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(import scheme)
|
||
|
|
(define-record-type foo
|
||
|
|
(nongenerative)
|
||
|
|
(fields a b)
|
||
|
|
(protocol
|
||
|
|
(let ([ctr 0])
|
||
|
|
(lambda (new)
|
||
|
|
(lambda (q)
|
||
|
|
(let ([x (begin (set! ctr (+ xtr 1)) ctr)])
|
||
|
|
(new q x)))))))
|
||
|
|
(make-foo 3))))
|
||
|
|
`(let ([ctr 0])
|
||
|
|
(letrec ([g0 (lambda (new) (lambda (q) (new q (begin (set! ctr (#3%+ 1 xtr)) ctr))))])
|
||
|
|
(#3%$make-record-constructor-descriptor ',record-type-descriptor? #f g0 'define-record-type)
|
||
|
|
(#3%$record ',record-type-descriptor? 3 (begin (set! ctr (#3%+ 1 xtr)) ctr)))))
|
||
|
|
(error? ; invalid uid
|
||
|
|
(let ()
|
||
|
|
(define useless
|
||
|
|
(lambda (name)
|
||
|
|
(record-mutator (make-record-type-descriptor
|
||
|
|
name #f 5 #f #f '#((mutable x))) 0)))
|
||
|
|
(procedure? (useless 'useless-box-setter))))
|
||
|
|
(equal?
|
||
|
|
(let ()
|
||
|
|
(define-record foo ((immutable double x)))
|
||
|
|
(foo-x (make-foo 3.0)))
|
||
|
|
3.0)
|
||
|
|
(begin
|
||
|
|
(define $foo
|
||
|
|
(lambda (y)
|
||
|
|
(define-record foo ((immutable double x) (immutable int y)))
|
||
|
|
(foo-x (make-foo 3.0 y))))
|
||
|
|
#t)
|
||
|
|
(equal? ($foo 17) 3.0)
|
||
|
|
)
|
||
|
|
|
||
|
|
(mat cp0-rtd-inspection-optimizations
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd
|
||
|
|
(make-record-type-descriptor 'foo #f #f #f #f
|
||
|
|
'#((mutable x))))
|
||
|
|
(define rtd
|
||
|
|
(make-record-type-descriptor 'bar prtd 'pluto #t #f
|
||
|
|
'#((mutable y) (immutable z))))
|
||
|
|
(define rcd (make-record-constructor-descriptor rtd #f #f))
|
||
|
|
(list
|
||
|
|
(record-type-descriptor? rtd)
|
||
|
|
(record-constructor-descriptor? rcd)
|
||
|
|
(record-type-descriptor? rcd)
|
||
|
|
(record-constructor-descriptor? rtd)
|
||
|
|
(record-field-mutable? prtd 0)
|
||
|
|
(record-field-mutable? rtd 0)
|
||
|
|
(record-field-mutable? rtd 1)
|
||
|
|
(record-type-field-names prtd)
|
||
|
|
(record-type-field-names rtd)
|
||
|
|
(list (record-type-generative? prtd) (record-type-generative? rtd))
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#((mutable x)))])
|
||
|
|
(let ([rtd (#2%make-record-type-descriptor 'bar prtd 'pluto #t #f '#((mutable y) (immutable z)))])
|
||
|
|
(let ([rcd (#3%make-record-constructor-descriptor rtd #f #f)])
|
||
|
|
(#2%list
|
||
|
|
#t
|
||
|
|
#t
|
||
|
|
(#2%record-type-descriptor? rcd)
|
||
|
|
(#2%record-constructor-descriptor? rtd)
|
||
|
|
#t
|
||
|
|
#t
|
||
|
|
#f
|
||
|
|
'#(x)
|
||
|
|
'#(y z)
|
||
|
|
(#2%list (#2%record-type-generative? prtd) (#2%record-type-generative? rtd))
|
||
|
|
(#2%list #f #f)
|
||
|
|
(#2%list #f #t))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#())])
|
||
|
|
(#2%make-record-type-descriptor 'bar prtd #f #f #f '#())
|
||
|
|
(#2%list
|
||
|
|
(#2%list #f #f)
|
||
|
|
(#2%list #f #f))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #t '#())])
|
||
|
|
(#2%make-record-type-descriptor 'bar prtd #f #f #f '#())
|
||
|
|
(#2%list
|
||
|
|
(#2%list #t #t)
|
||
|
|
(#2%list #f #f))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #f '#())])
|
||
|
|
(#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
|
||
|
|
(#2%list
|
||
|
|
(#2%list #f #t)
|
||
|
|
(#2%list #f #t))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(let ([prtd (#2%make-record-type-descriptor 'foo #f #f #f #t '#())])
|
||
|
|
(#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
|
||
|
|
(#2%list
|
||
|
|
(#2%list #t #t)
|
||
|
|
(#2%list #f #t))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f sealed? opaque? '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #f #f '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(let ([prtd (#2%make-record-type-descriptor 'foo #f #f sealed? opaque? '#())])
|
||
|
|
(let ([rtd (#2%make-record-type-descriptor 'bar prtd #f #f #f '#())])
|
||
|
|
(#2%list
|
||
|
|
(#2%list (#2%record-type-opaque? prtd) (#2%record-type-opaque? rtd))
|
||
|
|
(#2%list (#2%record-type-sealed? prtd) #f))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f sealed? opaque? '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f #t #t '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(let ([prtd (#2%make-record-type-descriptor 'foo #f #f sealed? opaque? '#())])
|
||
|
|
(#2%make-record-type-descriptor 'bar prtd #f #t #t '#())
|
||
|
|
(#2%list
|
||
|
|
(#2%list (#2%record-type-opaque? prtd) #t)
|
||
|
|
(#2%list (#2%record-type-sealed? prtd) #t)))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #f '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f sealed? opaque? '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(let ([rtd (#2%make-record-type-descriptor 'bar (#2%make-record-type-descriptor 'foo #f #f #f #f '#()) #f sealed? opaque? '#())])
|
||
|
|
(#2%list
|
||
|
|
(#2%list #f (#2%record-type-opaque? rtd))
|
||
|
|
(#2%list #f (#2%record-type-sealed? rtd))))))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(define prtd (make-record-type-descriptor 'foo #f #f #f #t '#()))
|
||
|
|
(define rtd (make-record-type-descriptor 'bar prtd #f sealed? opaque? '#()))
|
||
|
|
(list
|
||
|
|
(list (record-type-opaque? prtd) (record-type-opaque? rtd))
|
||
|
|
(list (record-type-sealed? prtd) (record-type-sealed? rtd))))))
|
||
|
|
'(lambda (sealed? opaque?)
|
||
|
|
(let ([rtd (#2%make-record-type-descriptor 'bar (#2%make-record-type-descriptor 'foo #f #f #f #t '#()) #f sealed? opaque? '#())])
|
||
|
|
(#2%list
|
||
|
|
(#2%list #t #t)
|
||
|
|
(#2%list #f (#2%record-type-sealed? rtd))))))
|
||
|
|
)
|
||
|
|
|
||
|
|
(define (cp0x3 cp0 x)
|
||
|
|
(cp0 (cp0 (cp0 x))))
|
||
|
|
|
||
|
|
(define (member? o l)
|
||
|
|
(and (member o l) #t))
|
||
|
|
|
||
|
|
(mat cp0-kar-kons-optimizations
|
||
|
|
; for now, it's necessary to run cp0 three times to complete the reduction
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record mybox (val))
|
||
|
|
(display (mybox-val (begin (display 1) (make-mybox 2))))))
|
||
|
|
"12")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record mybox (val))
|
||
|
|
(display (mybox-val (begin (display 1) (make-mybox 2)))))))
|
||
|
|
'(#2%display
|
||
|
|
(begin
|
||
|
|
(#2%display 1)
|
||
|
|
2)))
|
||
|
|
(eq? (let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(kons-kar (make-kons 'a 'b)))
|
||
|
|
'a)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(kons-kar (make-kons 'a 'b)))))
|
||
|
|
''a)
|
||
|
|
(eq? (let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(kons-kdr (make-kons 'a 'b)))
|
||
|
|
'b)
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(kons-kdr (make-kons 'a 'b)))))
|
||
|
|
''b)
|
||
|
|
(member?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(display (kons-kar (make-kons (begin (display 1) (display 2) 3)
|
||
|
|
(begin (display 4) (display 5) 6))))))
|
||
|
|
'("45123" "12453"))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(display (kons-kar (make-kons (begin (display 1) (display 2) 3)
|
||
|
|
(begin (display 4) (display 5) 6)))))))
|
||
|
|
'(#2%display
|
||
|
|
(begin
|
||
|
|
(#2%display 4)
|
||
|
|
(#2%display 5)
|
||
|
|
(#2%display 1)
|
||
|
|
(#2%display 2)
|
||
|
|
3)))
|
||
|
|
(member?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(display (kons-kdr (make-kons (begin (display 1) (display 2) 3)
|
||
|
|
(begin (display 4) (display 5) 6))))))
|
||
|
|
'("45126" "12456"))
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record kons (kar kdr))
|
||
|
|
(display (kons-kdr (make-kons (begin (display 1) (display 2) 3)
|
||
|
|
(begin (display 4) (display 5) 6)))))))
|
||
|
|
'(#2%display
|
||
|
|
(begin
|
||
|
|
(#2%display 4)
|
||
|
|
(#2%display 5)
|
||
|
|
(#2%display 1)
|
||
|
|
(#2%display 2)
|
||
|
|
6)))
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record ktail (kar (immutable kdr)))
|
||
|
|
(define x (make-ktail 1 2))
|
||
|
|
(display 3)
|
||
|
|
(display (ktail-kdr (begin (display 4) x)))))
|
||
|
|
"342")
|
||
|
|
(equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record ktail (kar (immutable kdr)))
|
||
|
|
(define x (make-ktail 1 2))
|
||
|
|
(display 3)
|
||
|
|
(display (ktail-kdr (begin (display 4) x))))))
|
||
|
|
'(begin
|
||
|
|
(#2%display 3)
|
||
|
|
(#2%display
|
||
|
|
(begin
|
||
|
|
(#2%display 4)
|
||
|
|
2))))
|
||
|
|
(equal?
|
||
|
|
(with-output-to-string
|
||
|
|
(lambda ()
|
||
|
|
(define-record ktail (kar (immutable kdr)))
|
||
|
|
(define x (make-ktail 1 2))
|
||
|
|
(display 3)
|
||
|
|
(display (ktail-kar (begin (display 4) x)))))
|
||
|
|
"341")
|
||
|
|
(not (equivalent-expansion?
|
||
|
|
(parameterize ([optimize-level 2] [enable-cp0 #t] [run-cp0 cp0x3] [#%$suppress-primitive-inlining #f])
|
||
|
|
(expand/optimize
|
||
|
|
'(let ()
|
||
|
|
(define-record ktail (kar (immutable kdr)))
|
||
|
|
(define x (make-ktail 1 2))
|
||
|
|
(display 3)
|
||
|
|
(display (ktail-kar (begin (display 4) x))))))
|
||
|
|
'(begin
|
||
|
|
(#2%display 3)
|
||
|
|
(#2%display
|
||
|
|
(begin
|
||
|
|
(#2%display 4)
|
||
|
|
1)))))
|
||
|
|
)
|