diff --git a/LOG b/LOG index 013059ff0..fa326da92 100644 --- a/LOG +++ b/LOG @@ -2301,3 +2301,67 @@ record.ms, root-experr-compile-0-f-f-f - updated comments describing the new features record-defn.ss +- fixed newly improved generate-temporaries so it doesn't loop + indefinitely on cycles in the elemenents of the input list. + syntax.ss, + 8.mo, root-experr-compile-0-f-f-f +- cp0 record-construct handlers now keep record-type wrappers when + propagating constants and refs. + cp0.ss +- added immutable-vector primitiive along with cp0 handling of + fully (foldable) and partially static immutable vectors. + primdata.ss, cpnanopass.ss, base-lang.ss, cpcheck.ss, cpletrec.ss, + cpcommonize.ss, cprep.ss, prims.ss, cp0.ss, + 5_6.ms, cp0.ms +- define-values now uses an immutable vector rather than a mutable + vector to package the values. + syntax.ss +- now working harder to determine the truth of the test part of an + if expression in order to eliminate the if itself. + cp0.ss, + cp0.ms +- eliminated some code duplication in rfa and rfm helpers. + cp0.ss +- now using compile-time (nongenerative) record types as proxies + for the run-time (generative) counterparts for defining record-type + accessors and mutators. this improves cross-library optimization + of generative record types in general, and specifically breaks + an otherwise unresolvable cycle among the internal definitions + of a record type with methods for which cpvalid was inserting + valid checks and assignments. + record-defn.ss, record.ss, cp0.ss, primdata.ss, + record.ms +- improved handling of records with methods. Lsrc record-type form + now hosts base-rtd and extras, which cp0 now uses to inline methods + through vtable indirects when it can. cp0 also propagates + record-type information through record forms, i.e., it no longer + drops the record-type wrapper around the record-type expression + that gets placed in the record form. cp0's record? handler also + now recognizes record-types as records. + cp0.ss, base-lang.ss, cpletrec.ss, cpcommonize.ss, cprep.ss, + interpret.ss, + record.ms +- fixed cp0 handler for $record to handle the case where the rtrd is + constant and all fields are immutable. it was punting this case and + thus possibly disabling some optimization. + cp0.ss +- added cp0 handler for $record-type-field-offsets. + cp0.ss +- define-record-type now requires that all the ancestors of a new + type with methods must be known at cmompile time, i.e., must all + have been specified via parent rather than parent-rtd. this + ensures we can determine the full set of methods that the type + inherits at expand time, hence the set of new generics that the + new type definition should bind. + record-defn.ss, + record.ms, root-experr-compile-0-f-f-f +- interface methods now use an out-of-line $query-interface operator, + interfaces are now packaged in an immutable vector, and cp0 tries + to fold $query-interface at compile time when possible. + cp0.ss, record-defn.ss, primdata.ss, + record.ms +- added open-interface as a friendly wrapper on $query-interface. + record-defn.ss, primdata.ss, + record.ms, root-experr-compile-0-f-f-f +- updated patch files + patch-compile-0-f-t-f, patch-compile-0-t-f-f, patch-interpret-0-f-t-f diff --git a/boot/a6le/petite.boot b/boot/a6le/petite.boot index 05c90b8f4..3d06f4fde 100644 Binary files a/boot/a6le/petite.boot and b/boot/a6le/petite.boot differ diff --git a/boot/a6le/scheme.boot b/boot/a6le/scheme.boot index 0ac27b830..c1d22f689 100644 Binary files a/boot/a6le/scheme.boot and b/boot/a6le/scheme.boot differ diff --git a/boot/a6nt/petite.boot b/boot/a6nt/petite.boot index c2616e567..392912df1 100644 Binary files a/boot/a6nt/petite.boot and b/boot/a6nt/petite.boot differ diff --git a/boot/a6nt/scheme.boot b/boot/a6nt/scheme.boot index 011e80ed4..84c641f43 100644 Binary files a/boot/a6nt/scheme.boot and b/boot/a6nt/scheme.boot differ diff --git a/boot/a6osx/petite.boot b/boot/a6osx/petite.boot index 176a42f9e..ddab5c801 100644 Binary files a/boot/a6osx/petite.boot and b/boot/a6osx/petite.boot differ diff --git a/boot/a6osx/scheme.boot b/boot/a6osx/scheme.boot index 284849089..29d22864a 100644 Binary files a/boot/a6osx/scheme.boot and b/boot/a6osx/scheme.boot differ diff --git a/boot/arm32le/petite.boot b/boot/arm32le/petite.boot index 0b16cf6c1..fafcfd08a 100644 Binary files a/boot/arm32le/petite.boot and b/boot/arm32le/petite.boot differ diff --git a/boot/arm32le/scheme.boot b/boot/arm32le/scheme.boot index 5de149c87..2d7f7d30a 100644 Binary files a/boot/arm32le/scheme.boot and b/boot/arm32le/scheme.boot differ diff --git a/boot/i3le/petite.boot b/boot/i3le/petite.boot index ce68ca159..27012d758 100644 Binary files a/boot/i3le/petite.boot and b/boot/i3le/petite.boot differ diff --git a/boot/i3le/scheme.boot b/boot/i3le/scheme.boot index 7e53e688f..88cc9928e 100644 Binary files a/boot/i3le/scheme.boot and b/boot/i3le/scheme.boot differ diff --git a/boot/i3nt/petite.boot b/boot/i3nt/petite.boot index 67ad5436d..75732c630 100644 Binary files a/boot/i3nt/petite.boot and b/boot/i3nt/petite.boot differ diff --git a/boot/i3nt/scheme.boot b/boot/i3nt/scheme.boot index f45eba3ba..fcc7e1812 100644 Binary files a/boot/i3nt/scheme.boot and b/boot/i3nt/scheme.boot differ diff --git a/boot/i3osx/petite.boot b/boot/i3osx/petite.boot index 594a6ac4f..ef427a86e 100644 Binary files a/boot/i3osx/petite.boot and b/boot/i3osx/petite.boot differ diff --git a/boot/i3osx/scheme.boot b/boot/i3osx/scheme.boot index a2129b489..c46aefbd4 100644 Binary files a/boot/i3osx/scheme.boot and b/boot/i3osx/scheme.boot differ diff --git a/boot/ta6le/petite.boot b/boot/ta6le/petite.boot index 4c43e1033..e90034e3f 100644 Binary files a/boot/ta6le/petite.boot and b/boot/ta6le/petite.boot differ diff --git a/boot/ta6le/scheme.boot b/boot/ta6le/scheme.boot index 394fcf019..6ebf54f20 100644 Binary files a/boot/ta6le/scheme.boot and b/boot/ta6le/scheme.boot differ diff --git a/boot/ta6nt/petite.boot b/boot/ta6nt/petite.boot index 9604781b3..f04fef71b 100644 Binary files a/boot/ta6nt/petite.boot and b/boot/ta6nt/petite.boot differ diff --git a/boot/ta6nt/scheme.boot b/boot/ta6nt/scheme.boot index c25f3ce31..c5e44348b 100644 Binary files a/boot/ta6nt/scheme.boot and b/boot/ta6nt/scheme.boot differ diff --git a/boot/ta6osx/petite.boot b/boot/ta6osx/petite.boot index 63d797092..3fdc3321a 100644 Binary files a/boot/ta6osx/petite.boot and b/boot/ta6osx/petite.boot differ diff --git a/boot/ta6osx/scheme.boot b/boot/ta6osx/scheme.boot index 70a3496d9..aaed5fb2a 100644 Binary files a/boot/ta6osx/scheme.boot and b/boot/ta6osx/scheme.boot differ diff --git a/boot/ti3le/petite.boot b/boot/ti3le/petite.boot index 980ac3c2e..846cabd79 100644 Binary files a/boot/ti3le/petite.boot and b/boot/ti3le/petite.boot differ diff --git a/boot/ti3le/scheme.boot b/boot/ti3le/scheme.boot index 41245ef47..0aeecf356 100644 Binary files a/boot/ti3le/scheme.boot and b/boot/ti3le/scheme.boot differ diff --git a/boot/ti3nt/petite.boot b/boot/ti3nt/petite.boot index 7def30a70..2a224f087 100644 Binary files a/boot/ti3nt/petite.boot and b/boot/ti3nt/petite.boot differ diff --git a/boot/ti3nt/scheme.boot b/boot/ti3nt/scheme.boot index 4cb52275b..43fc5d3a7 100644 Binary files a/boot/ti3nt/scheme.boot and b/boot/ti3nt/scheme.boot differ diff --git a/boot/ti3osx/petite.boot b/boot/ti3osx/petite.boot index d0b638a92..4f71f4580 100644 Binary files a/boot/ti3osx/petite.boot and b/boot/ti3osx/petite.boot differ diff --git a/boot/ti3osx/scheme.boot b/boot/ti3osx/scheme.boot index fbc3777aa..ca69e4a8e 100644 Binary files a/boot/ti3osx/scheme.boot and b/boot/ti3osx/scheme.boot differ diff --git a/mats/5_6.ms b/mats/5_6.ms index 6b4620581..dff8b036e 100644 --- a/mats/5_6.ms +++ b/mats/5_6.ms @@ -18,6 +18,23 @@ (eq? (vector) '#()) ) +(mat immutable-vector + (equal? (immutable-vector 1 2 3 4) (vector->immutable-vector '#(1 2 3 4))) + (eq? (immutable-vector) (vector->immutable-vector '#())) + (begin + (define (f x) + (let ([v (immutable-vector (begin (write 'a) (+ x 1)) (begin (write 'a) 2) (begin (write 'a) (cons 3 x)))]) + (for-each write + (list + (begin (write 'b) (vector-ref v 0)) + (begin (write 'b) (vector-ref v 1)) + (begin (write 'b) (vector-ref v 2)))))) + #t) + (equal? + (with-output-to-string (lambda () (f 7))) + "aaabbb82(3 . 7)") + ) + (mat make-vector (eqv? (vector-length (make-vector 10)) 10) (eqv? (vector-length (make-vector 100)) 100) diff --git a/mats/8.ms b/mats/8.ms index a1a7ecf3e..169b185cb 100644 --- a/mats/8.ms +++ b/mats/8.ms @@ -794,6 +794,10 @@ (load "testfile.so") #t) (equal? $gt-x '(53 -10 . 17)) + ; make sure generate-temporaries doesn't loop indefinitely on cycles + (error? ; cycle + (generate-temporaries (let ([x (list 'a 'b)]) (set-cdr! (cdr x) x) x))) + (= (length (generate-temporaries (let ([x (list 'a 'b 'c)]) (set-car! (cddr x) x) x))) 3) ) (mat syntax->list diff --git a/mats/cp0.ms b/mats/cp0.ms index 9476978a9..312ca67fa 100644 --- a/mats/cp0.ms +++ b/mats/cp0.ms @@ -2673,6 +2673,26 @@ (begin (#2%write 'f) ($yyy)) (begin (#2%write 'g) ($zzz)))) (begin (#2%write 'h) 3))))) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) + (expand/optimize + '(immutable-vector 1 2 3))) + ''#(1 2 3)) + (equivalent-expansion? + (parameterize ([enable-cp0 #t] [#%$suppress-primitive-inlining #f] [optimize-level 2]) + (expand/optimize + '(lambda (x) + (let ([v (begin (write 'a) (immutable-vector x 2 3))]) + (list + (begin (write 'b) (vector-ref v 0)) + (begin (write 'c) (vector-ref v 1)) + (begin (write 'd) (vector-ref v 2))))))) + '(lambda (x) + (#2%write 'a) + (#2%list + (begin (#2%write 'b) x) + (begin (#2%write 'c) 2) + (begin (#2%write 'd) 3)))) ) (mat let-pushing @@ -2887,3 +2907,53 @@ `(lambda (x) (= x x))) ; x could be +nan.0 `(lambda (x) (($primitive ,(if (fx= (optimize-level) 3) 3 2) =) x x)))) ) + +(mat if + (equal? + (let ([f (lambda (x) (+ x 1))] [g (lambda (x) (+ x 2))]) + (define (q1) (and f (f 3))) + (define (q2) (and g (g 7))) + (set! g values) + (list (q1) (q2))) + '(4 7)) + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (equivalent-expansion? + (expand/optimize + '(let ([f (lambda (x) (+ x 1))] [g (lambda (x) (+ x 2))]) + (define (q1) (and f (f 3))) + (define (q2) (and g (g 7))) + (set! g values) + (list (q1) (q2)))) + '(let ([g (lambda (x) (#2%+ 2 x))]) + (set! g #2%values) + (#2%list 4 (if g (g 7) #f))))) + (equal? + (let ([x (list 3)]) (and x (car x))) + 3) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let ([x (list 3)]) (and x (car x))))) + 3) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(lambda (x) (let ([p (list x)]) (and p (car p)))))) + '(lambda (x) x)) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(lambda (x) (let ([p (list x)]) (and p (list p)))))) + '(lambda (x) (#2%list (#2%list x)))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-record-type a (fields x)) + (let ([q (make-a 17)]) + (if q q (list q)))))) + '(#3%$record + (#2%$make-record-type-descriptor #!base-rtd 'a #f #f #f #f + '#((immutable x)) 'define-record-type) + 17)) +) diff --git a/mats/patch-compile-0-f-t-f b/mats/patch-compile-0-f-t-f index a9dfb1ef8..b772fc372 100644 --- a/mats/patch-compile-0-f-t-f +++ b/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** patches-work-dir/errors-compile-0-f-f-f 2021-12-03 16:51:41.000000000 -0800 ---- patches-work-dir/errors-compile-0-f-t-f 2021-12-03 16:51:41.000000000 -0800 +*** patches-work-dir/errors-compile-0-f-f-f 2022-02-03 16:55:57.000000000 -0800 +--- patches-work-dir/errors-compile-0-f-t-f 2022-02-03 16:55:57.000000000 -0800 *************** *** 54,60 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". @@ -397,8 +397,8 @@ record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "unrecognized parent record type fratrat". *************** -*** 7921,7939 **** - record.mo:Expected error in mat oop: "record-type definition has multiple method clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". +*** 7921,7932 **** + record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)". record.mo:Expected error in mat oop: "variable blast-x-set! is not bound". ! record.mo:Expected error in mat oop: "#> is not of type #>". @@ -409,16 +409,9 @@ ! record.mo:Expected error in mat oop: "#> is not of type #>". record.mo:Expected error in mat oop: "record-rtd: # is not a record". record.mo:Expected error in mat oop: "parent record type is sealed b". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". -! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #". - record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". - record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". - record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". ---- 7921,7939 ---- - record.mo:Expected error in mat oop: "record-type definition has multiple method clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". + record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +--- 7921,7932 ---- + record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)". record.mo:Expected error in mat oop: "variable blast-x-set! is not bound". ! record.mo:Expected error in mat oop: "-mupu1: #> is not of type #>". @@ -429,10 +422,20 @@ ! record.mo:Expected error in mat oop: "s$mupu2-set!: #> is not of type #>". record.mo:Expected error in mat oop: "record-rtd: # is not a record". record.mo:Expected error in mat oop: "parent record type is sealed b". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". + record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +*************** +*** 7936,7942 **** + record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". + record.mo:Expected error in mat oop: "unrecognized interface method name m2". + record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface ((foo m1) (foo m2)) a)". +! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #". + record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". + record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". + record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". +--- 7936,7942 ---- record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". + record.mo:Expected error in mat oop: "unrecognized interface method name m2". + record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface ((foo m1) (foo m2)) a)". ! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #>". record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index 0eb2892ae..12a241c87 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** patches-work-dir/errors-compile-0-f-f-f 2021-06-14 11:18:43.640000000 -0400 ---- patches-work-dir/errors-compile-0-t-f-f 2021-06-14 11:18:43.650000000 -0400 +*** patches-work-dir/errors-compile-0-f-f-f 2022-02-03 16:55:57.000000000 -0800 +--- patches-work-dir/errors-compile-0-t-f-f 2022-02-03 16:55:57.000000000 -0800 *************** *** 146,152 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #". @@ -4052,7 +4052,7 @@ 6.mo:Expected error in mat pretty-print: "pretty-format: invalid format (bad 0 ... ... 0 format)". 6.mo:Expected error in mat fasl: "separate-eval: Warning in fasl-write: fasl file content is compressed internally; compressing the file (#) is redundant and can slow fasl writing and reading significantly *************** -*** 6807,6838 **** +*** 6882,6913 **** io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #". io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #". io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #". @@ -4085,7 +4085,7 @@ io.mo:Expected error in mat port-operations1: "open-file-input/output-port: failed for /probably/not/a/good/path: no such file or directory". io.mo:Expected error in mat port-operations1: "invalid file option uncompressed". io.mo:Expected error in mat port-operations1: "invalid file option truncate". ---- 6807,6838 ---- +--- 6882,6913 ---- io.mo:Expected error in mat port-operations: "put-u8: not permitted on closed port #". io.mo:Expected error in mat port-operations: "put-bytevector: not permitted on closed port #". io.mo:Expected error in mat port-operations: "flush-output-port: not permitted on closed port #". @@ -4119,7 +4119,7 @@ io.mo:Expected error in mat port-operations1: "invalid file option uncompressed". io.mo:Expected error in mat port-operations1: "invalid file option truncate". *************** -*** 6843,6849 **** +*** 6918,6924 **** io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length". io.mo:Expected error in mat port-operations1: "truncate-port: # is not an output port". io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port". @@ -4127,7 +4127,7 @@ io.mo:Expected error in mat port-operations1: "truncate-port: not permitted on closed port #". io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port". io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port". ---- 6843,6849 ---- +--- 6918,6924 ---- io.mo:Expected error in mat port-operations1: "set-port-length!: all-the-way is not a valid length". io.mo:Expected error in mat port-operations1: "truncate-port: # is not an output port". io.mo:Expected error in mat port-operations1: "truncate-port: animal-crackers is not an output port". @@ -4136,7 +4136,7 @@ io.mo:Expected error in mat port-operations3: "file-port?: "not a port" is not a port". io.mo:Expected error in mat port-operations3: "port-file-descriptor: oops is not a port". *************** -*** 7026,7038 **** +*** 7101,7113 **** io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #". @@ -4150,7 +4150,7 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: shoe is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". ---- 7026,7038 ---- +--- 7101,7113 ---- io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: #vu8(1 2 3) is not a valid size for #". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: -1 is not a valid size for #". io.mo:Expected error in mat low-level-port-operations: "set-binary-port-output-size!: 6 is not a valid size for #". @@ -4165,7 +4165,7 @@ io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: 0 is not a positive fixnum". io.mo:Expected error in mat custom-port-buffer-size: "custom-port-buffer-size: -15 is not a positive fixnum". *************** -*** 7058,7073 **** +*** 7133,7148 **** io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #". io.mo:Expected error in mat compression: "port-file-compressed!: # is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #". @@ -4182,7 +4182,7 @@ io.mo:Expected error in mat custom-binary-ports: "unget-u8: cannot unget 255 on #". io.mo:Expected error in mat custom-binary-ports: "put-u8: # is not a binary output port". io.mo:Expected error in mat custom-binary-ports: "port-length: # does not support operation". ---- 7058,7073 ---- +--- 7133,7148 ---- io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #". io.mo:Expected error in mat compression: "port-file-compressed!: # is not a file port". io.mo:Expected error in mat compression: "port-file-compressed!: cannot compress input/output port #". @@ -4200,7 +4200,7 @@ io.mo:Expected error in mat custom-binary-ports: "put-u8: # is not a binary output port". io.mo:Expected error in mat custom-binary-ports: "port-length: # does not support operation". *************** -*** 7139,7154 **** +*** 7214,7229 **** io.mo:Expected error in mat current-ports: "console-output-port: # is not a textual output port". io.mo:Expected error in mat current-ports: "console-error-port: # is not a textual output port". io.mo:Expected error in mat current-transcoder: "current-transcoder: # is not a transcoder". @@ -4217,7 +4217,7 @@ io.mo:Expected error in mat utf-16-codec: "utf-16-codec: invalid endianness #f". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #". ---- 7139,7154 ---- +--- 7214,7229 ---- io.mo:Expected error in mat current-ports: "console-output-port: # is not a textual output port". io.mo:Expected error in mat current-ports: "console-error-port: # is not a textual output port". io.mo:Expected error in mat current-transcoder: "current-transcoder: # is not a transcoder". @@ -4235,7 +4235,7 @@ io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 0 of #". io.mo:Expected error in mat to-fold-or-not-to-fold: "get-datum: invalid character name #\newLine at char 15 of #". *************** -*** 7320,7326 **** +*** 7396,7402 **** 7.mo:Expected error in mat eval-when: "invalid syntax visit-x". 7.mo:Expected error in mat eval-when: "invalid syntax revisit-x". 7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory". @@ -4243,7 +4243,7 @@ 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception in environment: attempt to import invisible library (testfile-wpo-lib) 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found ---- 7320,7326 ---- +--- 7396,7402 ---- 7.mo:Expected error in mat eval-when: "invalid syntax visit-x". 7.mo:Expected error in mat eval-when: "invalid syntax revisit-x". 7.mo:Expected error in mat compile-whole-program: "compile-whole-program: failed for nosuchfile.wpo: no such file or directory". @@ -4252,7 +4252,7 @@ 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-a4) not found 7.mo:Expected error in mat compile-whole-program: "separate-eval: Exception: library (testfile-wpo-c4) not found *************** -*** 7386,7412 **** +*** 7462,7488 **** 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A) 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B) 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol". @@ -4280,7 +4280,7 @@ 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: hello is not an environment". 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: # is not a symbol". 7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound". ---- 7386,7412 ---- +--- 7462,7488 ---- 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1A) 7.mo:Expected error in mat concatenate-object-files: "separate-eval: Exception in verify-loadability: cannot find object file for library (testfile-cof1B) 7.mo:Expected error in mat top-level-value-functions: "top-level-bound?: "hello" is not a symbol". @@ -4309,7 +4309,7 @@ 7.mo:Expected error in mat top-level-value-functions: "define-top-level-value: # is not a symbol". 7.mo:Expected error in mat top-level-value-functions: "variable i-am-not-bound-i-hope is not bound". *************** -*** 7827,7937 **** +*** 7962,8072 **** hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments to #". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments to #". @@ -4421,7 +4421,7 @@ hash.mo:Expected error in mat hashtable-arguments: "hashtable-ephemeron?: (hash . table) is not a hashtable". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function # return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function # return value 3.5 for any". ---- 7827,7937 ---- +--- 7962,8072 ---- hash.mo:Expected error in mat old-hash-table: "hash-table-for-each: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments to #". hash.mo:Expected error in mat old-hash-table: "incorrect number of arguments to #". @@ -4534,7 +4534,7 @@ hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function # return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-ref: invalid hash-function # return value 3.5 for any". *************** -*** 7951,8057 **** +*** 8086,8192 **** hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value 3.5 for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value 1+2i for any". @@ -4642,7 +4642,7 @@ hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument -1". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f". ---- 7951,8057 ---- +--- 8086,8192 ---- hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value "oops" for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value 3.5 for any". hash.mo:Expected error in mat hash-return-value: "hashtable-delete!: invalid hash-function # return value 1+2i for any". @@ -4751,7 +4751,7 @@ hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #t". hash.mo:Expected error in mat eqv-hashtable-arguments: "make-ephemeron-eqv-hashtable: invalid size argument #f". *************** -*** 8059,8074 **** +*** 8194,8209 **** hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: # is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: # is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: # is not mutable". @@ -4768,7 +4768,7 @@ hash.mo:Expected error in mat hash-functions: "string-ci-hash: hello is not a string". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #". ---- 8059,8074 ---- +--- 8194,8209 ---- hash.mo:Expected error in mat generic-hashtable: "hashtable-delete!: # is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: # is not mutable". hash.mo:Expected error in mat generic-hashtable: "hashtable-update!: # is not mutable". @@ -4786,7 +4786,7 @@ hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #". hash.mo:Expected error in mat fasl-other-hashtable: "fasl-write: invalid fasl object #". *************** -*** 8184,8191 **** +*** 8321,8328 **** 8.mo:Expected error in mat with-syntax: "invalid syntax a". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". @@ -4794,8 +4794,8 @@ ! 8.mo:Expected error in mat generate-temporaries: "incorrect argument count in call (generate-temporaries (quote (a b c)) (quote (d e f)))". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". - 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". ---- 8184,8191 ---- + 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b a b a b ...)". +--- 8321,8328 ---- 8.mo:Expected error in mat with-syntax: "invalid syntax a". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". 8.mo:Expected error in mat with-syntax: "duplicate pattern variable x in (x x)". @@ -4803,9 +4803,9 @@ ! 8.mo:Expected error in mat generate-temporaries: "incorrect number of arguments to #". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". - 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". + 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b a b a b ...)". *************** -*** 8802,8817 **** +*** 8940,8955 **** 8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo". 8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #))". 8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol". @@ -4822,7 +4822,7 @@ 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: hello is not an environment". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: # is not a symbol". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #". ---- 8802,8817 ---- +--- 8940,8955 ---- 8.mo:Expected error in mat rnrs-eval: "attempt to assign unbound identifier foo". 8.mo:Expected error in mat rnrs-eval: "invalid definition in immutable environment (define cons (quote #))". 8.mo:Expected error in mat top-level-syntax-functions: "top-level-syntax: "hello" is not a symbol". @@ -4840,7 +4840,7 @@ 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: # is not a symbol". 8.mo:Expected error in mat top-level-syntax-functions: "define-top-level-syntax: cannot modify immutable environment #". *************** -*** 8910,8932 **** +*** 9048,9070 **** fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum". @@ -4864,7 +4864,7 @@ fx.mo:Expected error in mat $fxu<: "incorrect number of arguments to #". fx.mo:Expected error in mat $fxu<: "incorrect number of arguments to #". fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum". ---- 8910,8932 ---- +--- 9048,9070 ---- fx.mo:Expected error in mat fx=?: "fx=?: (a) is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: is not a fixnum". fx.mo:Expected error in mat fx=?: "fx=?: <-int> is not a fixnum". @@ -4889,7 +4889,7 @@ fx.mo:Expected error in mat $fxu<: "incorrect number of arguments to #". fx.mo:Expected error in mat $fxu<: "$fxu<: <-int> is not a fixnum". *************** -*** 8958,8970 **** +*** 9096,9108 **** fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". @@ -4903,7 +4903,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 8958,8970 ---- +--- 9096,9108 ---- fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". @@ -4918,7 +4918,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". *************** -*** 9014,9026 **** +*** 9152,9164 **** fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum". @@ -4932,7 +4932,7 @@ fx.mo:Expected error in mat fxmax: "fxmax: a is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum". ---- 9014,9026 ---- +--- 9152,9164 ---- fx.mo:Expected error in mat fx1+: "fx1+: <-int> is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: is not a fixnum". fx.mo:Expected error in mat fx1+: "fx1+: a is not a fixnum". @@ -4947,7 +4947,7 @@ fx.mo:Expected error in mat fxmax: "fxmax: is not a fixnum". fx.mo:Expected error in mat fxmax: "fxmax: <-int> is not a fixnum". *************** -*** 9118,9127 **** +*** 9256,9265 **** fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments and 10". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and ". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1". @@ -4958,7 +4958,7 @@ fx.mo:Expected error in mat fxbit-field: "fxbit-field: 35.0 is not a fixnum". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index". ---- 9118,9127 ---- +--- 9256,9265 ---- fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments and 10". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments -4097 and ". fx.mo:Expected error in mat fxarithmetic-shift: "fxarithmetic-shift: fixnum overflow with arguments <-int> and 1". @@ -4970,7 +4970,7 @@ fx.mo:Expected error in mat fxbit-field: "fxbit-field: 5.0 is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: 8.0 is not a valid end index". *************** -*** 9135,9168 **** +*** 9273,9306 **** fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid end index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid end index". @@ -5005,7 +5005,7 @@ fx.mo:Expected error in mat fxif: "fxif: a is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum". ---- 9135,9168 ---- +--- 9273,9306 ---- fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid end index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid start index". fx.mo:Expected error in mat fxbit-field: "fxbit-field: is not a valid end index". @@ -5041,7 +5041,7 @@ fx.mo:Expected error in mat fxif: "fxif: 3.4 is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: (a) is not a fixnum". *************** -*** 9172,9215 **** +*** 9310,9353 **** fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". @@ -5086,7 +5086,7 @@ fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: 3.4 is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: is not a fixnum". ---- 9172,9215 ---- +--- 9310,9353 ---- fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". fx.mo:Expected error in mat fxif: "fxif: <-int> is not a fixnum". @@ -5132,7 +5132,7 @@ fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: is not a fixnum". *************** -*** 9218,9228 **** +*** 9356,9366 **** fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index ". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index ". @@ -5144,7 +5144,7 @@ fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: "3" is not a fixnum". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index". ---- 9218,9228 ---- +--- 9356,9366 ---- fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index -1". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index ". fx.mo:Expected error in mat fxcopy-bit: "fxcopy-bit: invalid bit index ". @@ -5157,7 +5157,7 @@ fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3.4 is not a valid start index". fx.mo:Expected error in mat fxcopy-bit-field: "fxcopy-bit-field: 3/4 is not a valid end index". *************** -*** 9282,9291 **** +*** 9420,9429 **** fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". @@ -5168,7 +5168,7 @@ fx.mo:Expected error in mat fx+/carry: "fx+/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum". ---- 9282,9291 ---- +--- 9420,9429 ---- fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: (a) is not a fixnum". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". fx.mo:Expected error in mat fxdiv0-and-mod0: "fxmod0: undefined for 0". @@ -5180,7 +5180,7 @@ fx.mo:Expected error in mat fx+/carry: "fx+/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: 3.0 is not a fixnum". *************** -*** 9301,9310 **** +*** 9439,9448 **** fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". @@ -5191,7 +5191,7 @@ fx.mo:Expected error in mat fx-/carry: "fx-/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum". ---- 9301,9310 ---- +--- 9439,9448 ---- fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx+/carry: "fx+/carry: <-int> is not a fixnum". @@ -5203,7 +5203,7 @@ fx.mo:Expected error in mat fx-/carry: "fx-/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: 3.0 is not a fixnum". *************** -*** 9320,9329 **** +*** 9458,9467 **** fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". @@ -5214,7 +5214,7 @@ fx.mo:Expected error in mat fx*/carry: "fx*/carry: 1.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum". ---- 9320,9329 ---- +--- 9458,9467 ---- fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx-/carry: "fx-/carry: <-int> is not a fixnum". @@ -5226,7 +5226,7 @@ fx.mo:Expected error in mat fx*/carry: "fx*/carry: 2.0 is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: 3.0 is not a fixnum". *************** -*** 9339,9349 **** +*** 9477,9487 **** fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". @@ -5238,7 +5238,7 @@ fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: a is not a fixnum". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0". ---- 9339,9349 ---- +--- 9477,9487 ---- fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". fx.mo:Expected error in mat fx*/carry: "fx*/carry: <-int> is not a fixnum". @@ -5251,7 +5251,7 @@ fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index 2.0". *************** -*** 9366,9375 **** +*** 9504,9513 **** fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index ". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index ". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5". @@ -5262,7 +5262,7 @@ fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: a is not a fixnum". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0". ---- 9366,9375 ---- +--- 9504,9513 ---- fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index ". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: invalid end index ". fx.mo:Expected error in mat fxrotate-bit-field: "fxrotate-bit-field: count 1 is greater than difference between end index 5 and start index 5". @@ -5274,7 +5274,7 @@ fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid start index 0.0". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index 2.0". *************** -*** 9385,9402 **** +*** 9523,9540 **** fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index ". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5". @@ -5293,7 +5293,7 @@ fl.mo:Expected error in mat fl=: "fl=: (a) is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". ---- 9385,9402 ---- +--- 9523,9540 ---- fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index ". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: invalid end index <-int>". fx.mo:Expected error in mat fxreverse-bit-field: "fxreverse-bit-field: start index 7 is greater than end index 5". @@ -5313,7 +5313,7 @@ fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". fl.mo:Expected error in mat fl=: "fl=: a is not a flonum". *************** -*** 9404,9410 **** +*** 9542,9548 **** fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". @@ -5321,7 +5321,7 @@ fl.mo:Expected error in mat fl<: "fl<: (a) is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". ---- 9404,9410 ---- +--- 9542,9548 ---- fl.mo:Expected error in mat fl=: "fl=: 3 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". fl.mo:Expected error in mat fl=: "fl=: 7/2 is not a flonum". @@ -5330,7 +5330,7 @@ fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". fl.mo:Expected error in mat fl<: "fl<: a is not a flonum". *************** -*** 9412,9418 **** +*** 9550,9556 **** fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". @@ -5338,7 +5338,7 @@ fl.mo:Expected error in mat fl>: "fl>: (a) is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". ---- 9412,9418 ---- +--- 9550,9556 ---- fl.mo:Expected error in mat fl<: "fl<: 3 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". fl.mo:Expected error in mat fl<: "fl<: 7/2 is not a flonum". @@ -5347,7 +5347,7 @@ fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". fl.mo:Expected error in mat fl>: "fl>: a is not a flonum". *************** -*** 9420,9426 **** +*** 9558,9564 **** fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". @@ -5355,7 +5355,7 @@ fl.mo:Expected error in mat fl<=: "fl<=: (a) is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". ---- 9420,9426 ---- +--- 9558,9564 ---- fl.mo:Expected error in mat fl>: "fl>: 3 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". fl.mo:Expected error in mat fl>: "fl>: 7/2 is not a flonum". @@ -5364,7 +5364,7 @@ fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: a is not a flonum". *************** -*** 9428,9434 **** +*** 9566,9572 **** fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". @@ -5372,7 +5372,7 @@ fl.mo:Expected error in mat fl>=: "fl>=: (a) is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". ---- 9428,9434 ---- +--- 9566,9572 ---- fl.mo:Expected error in mat fl<=: "fl<=: 3 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". fl.mo:Expected error in mat fl<=: "fl<=: 7/2 is not a flonum". @@ -5381,7 +5381,7 @@ fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: a is not a flonum". *************** -*** 9436,9475 **** +*** 9574,9613 **** fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". @@ -5422,7 +5422,7 @@ fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum". ---- 9436,9475 ---- +--- 9574,9613 ---- fl.mo:Expected error in mat fl>=: "fl>=: 3 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". fl.mo:Expected error in mat fl>=: "fl>=: 7/2 is not a flonum". @@ -5464,7 +5464,7 @@ fl.mo:Expected error in mat fl>=?: "fl>=?: a is not a flonum". fl.mo:Expected error in mat fl>=?: "fl>=?: 3 is not a flonum". *************** -*** 9479,9485 **** +*** 9617,9623 **** fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum". @@ -5472,7 +5472,7 @@ fl.mo:Expected error in mat fl-: "fl-: (a . b) is not a flonum". fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum". fl.mo:Expected error in mat fl-: "fl-: a is not a flonum". ---- 9479,9485 ---- +--- 9617,9623 ---- fl.mo:Expected error in mat fl+: "fl+: (a . b) is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 1 is not a flonum". fl.mo:Expected error in mat fl+: "fl+: 2/3 is not a flonum". @@ -5481,7 +5481,7 @@ fl.mo:Expected error in mat fl-: "fl-: 1 is not a flonum". fl.mo:Expected error in mat fl-: "fl-: a is not a flonum". *************** -*** 9489,9571 **** +*** 9627,9709 **** fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum". @@ -5565,7 +5565,7 @@ fl.mo:Expected error in mat flround: "flround: a is not a flonum". fl.mo:Expected error in mat flround: "flround: 2.0+1.0i is not a flonum". fl.mo:Expected error in mat flround: "flround: 2+1i is not a flonum". ---- 9489,9571 ---- +--- 9627,9709 ---- fl.mo:Expected error in mat fl*: "fl*: (a . b) is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 1 is not a flonum". fl.mo:Expected error in mat fl*: "fl*: 2/3 is not a flonum". @@ -5650,7 +5650,7 @@ fl.mo:Expected error in mat flround: "flround: 2.0+1.0i is not a flonum". fl.mo:Expected error in mat flround: "flround: 2+1i is not a flonum". *************** -*** 9585,9620 **** +*** 9723,9758 **** fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum". @@ -5687,7 +5687,7 @@ fl.mo:Expected error in mat fleven?: "fleven?: a is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer". ---- 9585,9620 ---- +--- 9723,9758 ---- fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: 3/4 is not a flonum". fl.mo:Expected error in mat flinfinite?: "flinfinite?: hi is not a flonum". @@ -5725,7 +5725,7 @@ fl.mo:Expected error in mat fleven?: "fleven?: 3 is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: 3.2 is not an integer". *************** -*** 9622,9629 **** +*** 9760,9767 **** fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer". fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer". @@ -5734,7 +5734,7 @@ fl.mo:Expected error in mat flodd?: "flodd?: a is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer". ---- 9622,9629 ---- +--- 9760,9767 ---- fl.mo:Expected error in mat fleven?: "fleven?: 1+1i is not a flonum". fl.mo:Expected error in mat fleven?: "fleven?: +inf.0 is not an integer". fl.mo:Expected error in mat fleven?: "fleven?: +nan.0 is not an integer". @@ -5744,7 +5744,7 @@ fl.mo:Expected error in mat flodd?: "flodd?: 3 is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: 3.2 is not an integer". *************** -*** 9631,9637 **** +*** 9769,9775 **** fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer". fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer". @@ -5752,7 +5752,7 @@ fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". ---- 9631,9637 ---- +--- 9769,9775 ---- fl.mo:Expected error in mat flodd?: "flodd?: 3+1i is not a flonum". fl.mo:Expected error in mat flodd?: "flodd?: +inf.0 is not an integer". fl.mo:Expected error in mat flodd?: "flodd?: +nan.0 is not an integer". @@ -5761,7 +5761,7 @@ fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". *************** -*** 9639,9645 **** +*** 9777,9783 **** fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum". @@ -5769,7 +5769,7 @@ fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum". ---- 9639,9645 ---- +--- 9777,9783 ---- fl.mo:Expected error in mat flmin: "flmin: a is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmin: "flmin: 0+1i is not a flonum". @@ -5778,7 +5778,7 @@ fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 3 is not a flonum". *************** -*** 9647,9660 **** +*** 9785,9798 **** fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum". @@ -5793,7 +5793,7 @@ fl.mo:Expected error in mat fldenominator: "fldenominator: a is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum". ---- 9647,9660 ---- +--- 9785,9798 ---- fl.mo:Expected error in mat flmax: "flmax: a is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0.0+1.0i is not a flonum". fl.mo:Expected error in mat flmax: "flmax: 0+1i is not a flonum". @@ -5809,7 +5809,7 @@ fl.mo:Expected error in mat fldenominator: "fldenominator: 3 is not a flonum". fl.mo:Expected error in mat fldenominator: "fldenominator: 0+1i is not a flonum". *************** -*** 9700,9706 **** +*** 9838,9844 **** cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". @@ -5817,7 +5817,7 @@ cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". ---- 9700,9706 ---- +--- 9838,9844 ---- cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". @@ -5826,7 +5826,7 @@ cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". cfl.mo:Expected error in mat cfl-: "cfl-: a is not a cflonum". *************** -*** 9710,9723 **** +*** 9848,9861 **** cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". @@ -5841,7 +5841,7 @@ foreign.mo:Expected error in mat load-shared-object: "load-shared-object: invalid path 3". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". ---- 9710,9723 ---- +--- 9848,9861 ---- cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". cfl.mo:Expected error in mat cfl/: "cfl/: a is not a cflonum". @@ -5857,7 +5857,7 @@ foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: no entry for "i do not exist"". *************** -*** 9752,9759 **** +*** 9890,9897 **** foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde". foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0". @@ -5866,7 +5866,7 @@ foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier i-am-not-a-type". foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"". ---- 9752,9759 ---- +--- 9890,9897 ---- foreign.mo:Expected error in mat foreign-procedure: "id: invalid foreign-procedure argument foo". foreign.mo:Expected error in mat foreign-procedure: "foreign-procedure: invalid foreign procedure handle abcde". foreign.mo:Expected error in mat foreign-procedure: "float_id: invalid foreign-procedure argument 0". @@ -5876,7 +5876,7 @@ foreign.mo:Expected error in mat foreign-sizeof: "foreign-sizeof: invalid foreign type specifier 1". foreign.mo:Expected error in mat foreign-bytevectors: "u8*->u8*: invalid foreign-procedure argument "hello"". *************** -*** 10251,10263 **** +*** 10389,10401 **** unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -5890,7 +5890,7 @@ windows.mo:Expected error in mat registry: "get-registry: pooh is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". ---- 10251,10263 ---- +--- 10389,10401 ---- unix.mo:Expected error in mat file-operations: "file-access-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-change-time: failed for "testlink": no such file or directory". unix.mo:Expected error in mat file-operations: "file-modification-time: failed for "testlink": no such file or directory". @@ -5905,7 +5905,7 @@ windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". windows.mo:Expected error in mat registry: "put-registry!: 3 is not a string". *************** -*** 10285,10356 **** +*** 10423,10494 **** ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for -inf.0 would be outside of fixnum range". ieee.mo:Expected error in mat flonum->fixnum: "flonum->fixnum: result for +nan.0 would be outside of fixnum range". ieee.mo:Expected error in mat fllp: "fllp: 3 is not a flonum". @@ -5978,7 +5978,7 @@ date.mo:Expected error in mat time: "time>=?: 3 is not a time record". date.mo:Expected error in mat time: "time>=?: # is not a time record". date.mo:Expected error in mat time: "time>=?: types of in (super)". - record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". - record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". ---- 7921,7939 ---- - record.mo:Expected error in mat oop: "record-type definition has multiple method clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". + record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +--- 7921,7932 ---- + record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)". record.mo:Expected error in mat oop: "variable blast-x-set! is not bound". ! record.mo:Expected error in mat oop: "#> is not of type #>". @@ -569,16 +562,26 @@ ! record.mo:Expected error in mat oop: "#> is not of type #>". record.mo:Expected error in mat oop: "record-rtd: # is not a record". record.mo:Expected error in mat oop: "parent record type is sealed b". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". - record.mo:Expected error in mat oop: "m1: not applicable to #". + record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +*************** +*** 7936,7942 **** + record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". + record.mo:Expected error in mat oop: "unrecognized interface method name m2". + record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface ((foo m1) (foo m2)) a)". +! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #>". + record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". + record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". + record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". +--- 7936,7942 ---- record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". + record.mo:Expected error in mat oop: "unrecognized interface method name m2". + record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface ((foo m1) (foo m2)) a)". ! record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #". record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". *************** -*** 9092,9104 **** +*** 9096,9108 **** fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". @@ -592,7 +595,7 @@ fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". ---- 9092,9104 ---- +--- 9096,9108 ---- fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". diff --git a/mats/record.ms b/mats/record.ms index 3d18d1365..f7b75017b 100644 --- a/mats/record.ms +++ b/mats/record.ms @@ -9969,7 +9969,7 @@ (let ([q (make-b 71)]) (list (a? q) (b? q) (c? q) (a-x q) (m1 q) (m2 q))))) - (equal? ; okay if we don't try to call m1 + (error? ; must fully specify ancestry of record-type w/methods using parent, not parent-rtd (let () (define-record-type a (fields x) (methods (m1 () (* x 2)))) (define-record-type b @@ -9977,13 +9977,9 @@ (record-rtd (make-a 0)) #f) (methods (m2 () 23))) - (define-record-type c - (parent-rtd - (record-rtd (make-b 0)) - #f)) + (define-record-type c (parent b)) (let ([q (make-b 71)]) - (list (a? q) (b? q) (c? q) (a-x q) (m2 q)))) - '(#t #t #f 71 23)) + (list (a? q) (b? q) (c? q) (a-x q) (m2 q))))) ; extending a record type with a class is okay (equal? @@ -10041,6 +10037,76 @@ (define-record-type a (parent this-parent-should-be-undefined)) (make-a))) (begin (print-record #t) (print-record)) + (equal? + (let () + (define-interface (methods (m1 (x)))) + (define-interface (methods (m2 (x)))) + (define-interface (parent ) (methods (m3 (x)))) + (define-record-type A + (implements ) + (fields x) + (methods [m1 (y) (list 'A 'm1 x y)])) + (define-record-type B + (implements ) + (fields x y) + (methods [m2 (z) (list 'B 'm2 x y z)])) + (define-record-type C + (implements ) + (fields x y z) + (methods + [m1 (w) (list 'C 'm1 x y z w)] + [m2 (w) (list 'C 'm2 x y z w)] + [m3 (w) (list 'C 'm3 x y z w)] + [m4 (w) (list 'C 'm4 x y z w)])) + (define a (make-A 23)) + (define b (make-B 31 47)) + (define c (make-C 53 67 71)) + (open-interface ([a.m1 m1]) a) + (open-interface ([b.m2 m2]) b) + (open-interface ([c.m1 m1] [c.m3 m3]) c) + (open-interface ([c.m1^ m1]) c) + (open-interface ([c.m2^ m2]) c) + (list + (list (? a) (? b) (? c)) + (list (? a) (? b) (? c)) + (list (? a) (? b) (? c)) + (a.m1 3) + (b.m2 5) + (c.m1 7) + (c.m3 13) + (c.m1^ 17) + (c.m2^ 19))) + '((#t #f #t) + (#f #t #t) + (#f #f #t) + (A m1 23 3) + (B m2 31 47 5) + (C m1 53 67 71 7) + (C m3 53 67 71 13) + (C m1 53 67 71 17) + (C m2 53 67 71 19))) + (error? ; no method in interface + (let () + (define-interface (methods (m1 (x)))) + (define-record-type A + (implements ) + (fields x) + (methods [m1 (y) (list 'A 'm1 x y)])) + (define a (make-A 23)) + (open-interface ([a.m1 m1] [a.m2 m2]) a) + (a.m1 3))) + (error? ; duplicate local method name + (let () + (define-interface (methods (m1 (x)) (m2 (y)))) + (define-record-type A + (implements ) + (fields x) + (methods + [m1 (y) (list 'A 'm1 x y)] + [m2 (y) (list 'A 'm2 x y)])) + (define a (make-A 23)) + (open-interface ([foo m1] [foo m2]) a) + (foo 3))) ) (mat oop-contributed @@ -11785,3 +11851,97 @@ 0) (begin (print-record #t) (print-record)) ) + +(mat oop-cp0 + (equal? + (let () + (define-record-type a (fields x) (methods [m (y) (+ x y)])) + (m (make-a 17) 13)) + 30) + (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 a (fields x) (methods [m (y) (+ x y)])) + (m (make-a 17) 13)))) + 30) + (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 a (fields x) (methods [m (y) (+ x y)])) + (m (make-a 17) 13)))) + 30) + (equal? + (let () + (define-record-type a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y)) + (m (make-b 17 13) 11)) + 28) + (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 a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y)) + (m (make-b 17 13) 11)))) + 28) + (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 a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y)) + (m (make-b 17 13) 11)))) + 28) + (equal? + (let () + (define-record-type a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y) (methods [m (z) (+ (super y) z)])) + (m (make-b 17 13) 11)) + 41) + (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 a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y) (methods [m (z) (+ (super y) z)])) + (m (make-b 17 13) 11)))) + 41) + (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 a (fields x) (methods [m (y) (+ x y)])) + (define-record-type b (parent a) (fields y) (methods [m (z) (+ (super y) z)])) + (m (make-b 17 13) 11)))) + 41) + (procedure? + (let () + (define-record-type a (fields x) (methods [m (y) (+ x y)])) + (lambda (x) (m x 13)))) + (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 a (fields x) (methods [m (y) (+ x y)])) + (lambda (x) (m x 13))))) + `(lambda (x) ((#3%$object-ref 'scheme-object (#3%record-rtd x) ,fixnum?) x 13))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-interface i (methods (m1 (y)))) + (define-record-type a (implements i) (fields x) (methods [m1 (y) (+ x y)])) + (m1 (make-a 17) 12)))) + 29) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(let () + (define-interface i (methods (m1 (y)))) + (define-record-type a (implements i) (fields x) (methods [m1 (y) (+ x y)])) + (open-interface i ([a.m1 m1]) (make-a 17)) + (a.m1 12)))) + 29) +) diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index 7aa3787cf..e146c105d 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -7929,10 +7929,13 @@ record.mo:Expected error in mat oop: "#> is not of type #> is not of type #>". record.mo:Expected error in mat oop: "record-rtd: # is not a record". record.mo:Expected error in mat oop: "parent record type is sealed b". -record.mo:Expected error in mat oop: "m1: not applicable to #". +record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". record.mo:Expected error in mat oop: "m1: not applicable to #". record.mo:Expected error in mat oop: "m1: not applicable to #". record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". +record.mo:Expected error in mat oop: "unrecognized interface method name m2". +record.mo:Expected error in mat oop: "duplicate local method name foo in (open-interface ((foo m1) (foo m2)) a)". record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #". record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". @@ -8322,6 +8325,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal 8.mo:Expected error in mat generate-temporaries: "incorrect argument count in call (generate-temporaries (quote (a b c)) (quote (d e f)))". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". +8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b a b a b ...)". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". 8.mo:Expected error in mat syntax->vector: "syntax->vector: invalid argument #". diff --git a/mats/root-experr-compile-2-f-f-f b/mats/root-experr-compile-2-f-f-f index 9fc21bfeb..8bc83a068 100644 --- a/mats/root-experr-compile-2-f-f-f +++ b/mats/root-experr-compile-2-f-f-f @@ -7860,18 +7860,18 @@ record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: inc record.mo:Expected error in mat r6rs-records-syntactic: "# is not of type #". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: incompatible record type cpoint - different parent". -record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record-type parent fratrat". +record.mo:Expected error in mat r6rs-records-syntactic: "unrecognized parent record type fratrat". record.mo:Expected error in mat r6rs-records-syntactic: "cannot extend define-record parent fratrat". record.mo:Expected error in mat r6rs-records-syntactic: "make-record-constructor-descriptor: cannot create constructor descriptor for record type with non-scheme-object fields". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has both parent and parent-rtd clauses (define-record-type dormy (parent fratrat2) (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has both parent and parent-rtd clauses (define-record-type dormy (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (parent fratrat2) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple parent-rtd clauses (define-record-type dormy (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple parent clauses (define-record-type dormy (parent fratrat2) (parent fratrat2) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple fields clauses (define-record-type dormy (parent fratrat2) (fields z) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple nongenerative clauses (define-record-type dormy (parent fratrat2) (nongenerative) (nongenerative spam-for-dinner) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple sealed clauses (define-record-type dormy (parent fratrat2) (sealed #t) (sealed #t) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple opaque clauses (define-record-type dormy (parent fratrat2) (opaque #t) (opaque #t) (fields (immutable y)))". -record.mo:Expected error in mat r6rs-records-syntactic: "record definition has multiple protocol clauses (define-record-type dormy (parent fratrat2) (protocol values) (protocol (lambda (...) x)) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has both parent and parent-rtd clauses (define-record-type dormy (parent fratrat2) (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has both parent and parent-rtd clauses (define-record-type dormy (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (parent fratrat2) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple parent-rtd clauses (define-record-type dormy (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (parent-rtd (type-descriptor fratrat) (make-record-constructor-descriptor (...) #f #f)) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple parent clauses (define-record-type dormy (parent fratrat2) (parent fratrat2) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple fields clauses (define-record-type dormy (parent fratrat2) (fields z) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple nongenerative clauses (define-record-type dormy (parent fratrat2) (nongenerative) (nongenerative spam-for-dinner) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple sealed clauses (define-record-type dormy (parent fratrat2) (sealed #t) (sealed #t) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple opaque clauses (define-record-type dormy (parent fratrat2) (opaque #t) (opaque #t) (fields (immutable y)))". +record.mo:Expected error in mat r6rs-records-syntactic: "record-type definition has multiple protocol clauses (define-record-type dormy (parent fratrat2) (protocol values) (protocol (lambda (...) x)) (fields (immutable y)))". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid protocol whoops!". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid record constructor descriptor rats". record.mo:Expected error in mat r6rs-records-syntactic: "define-record-type: invalid parent rats". @@ -7896,6 +7896,64 @@ record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier record.mo:Expected error in mat r6rs-records-syntactic: "invalid field specifier (mutable x foo-x (foo-x!))". record.mo:Expected error in mat define-record-type-extensions: "missing nongenerative clause and require-nongenerative-clause is #t (define-record-type foo)". record.mo:Expected error in mat cp0-record-ref-optimizations: "make-record-type-descriptor: invalid uid 5". +record.mo:Expected error in mat oop: "incorrect number of arguments to #". +record.mo:Expected error in mat oop: "incorrect number of arguments to #". +record.mo:Expected error in mat oop: "incorrect number of arguments to #". +record.mo:Expected error in mat oop: "incorrect number of arguments to #". +record.mo:Expected error in mat oop: "m1: not applicable to 17". +record.mo:Expected error in mat oop: "arity not supported by base record-type method hit". +record.mo:Expected error in mat oop: "a record type with methods or interfaces cannot be nongenerative (define-record-type b (parent a) (nongenerative) (methods (m1 (...) (...))))". +record.mo:Expected error in mat oop: "no inherited bar method for baz in (super)". +record.mo:Expected error in mat oop: "arity not supported by interface method whack". +record.mo:Expected error in mat oop: "arity not supported by interface method whack". +record.mo:Expected error in mat oop: "arity not supported by interface method whack". +record.mo:Expected error in mat oop: "arity not supported by interface method whack". +record.mo:Expected error in mat oop: "arity not supported by interface method whack". +record.mo:Expected error in mat oop: "fish: not applicable to 3". +record.mo:Expected error in mat oop: "rats: not applicable to 3". +record.mo:Expected error in mat oop: "fish: not applicable to #". +record.mo:Expected error in mat oop: "no suitable implementation for interface method rats (define-record-type (implements i1 i2) (fields x) (protocol (lambda (...) (...))) (methods (fish (...) (...)) (run (...) (...)) (x! (...) (...))))". +record.mo:Expected error in mat oop: "define-record-type: incompatible record type frap - different fields". +record.mo:Expected error in mat oop: "a record type with methods or interfaces cannot be nongenerative (define-record-type frap (nongenerative #{frap \x2E;R@iB9FE~OXVz\x5C;\x5C;%}) (methods (m1 () 5)))". +record.mo:Expected error in mat oop: "a record type with methods or interfaces cannot be nongenerative (define-record-type frap (nongenerative) (methods (m1 () 5)))". +record.mo:Expected error in mat oop: "invalid syntax ". +record.mo:Expected error in mat oop: "record-type definition has multiple fields clauses (define-record-type foo (fields x) (fields y) (methods (show () (...))))". +record.mo:Expected error in mat oop: "record-type definition has multiple methods clauses (define-record-type foo (fields x y) (methods (show () (...))) (methods (get-x () x)))". +record.mo:Expected error in mat oop: "invalid assignment of immutable field (set! x v)". +record.mo:Expected error in mat oop: "variable blast-x-set! is not bound". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "#> is not of type #>". +record.mo:Expected error in mat oop: "record-rtd: # is not a record". +record.mo:Expected error in mat oop: "parent record type is sealed b". +record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +record.mo:Expected error in mat oop: "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd (define-record-type b (parent-rtd (record-rtd (...)) #f) (methods (m2 () 23)))". +record.mo:Expected error in mat oop: "m1: not applicable to #". +record.mo:Expected error in mat oop: "m1: not applicable to #". +record.mo:Expected error in mat oop: "define-record-type: unrecognized parent record type this-parent-should-be-undefined". +record.mo:Expected error in mat oop: "unrecognized interface method name m2". +record.mo:Expected error in mat oop-contributed: "incorrect number of arguments to #". +record.mo:Expected error in mat oop-contributed: "no inherited foo method for in (super)". +record.mo:Expected error in mat oop-contributed: "multiple definitions for Repeat and other identifiers in body (let () (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) (define-record-type Repeat (parent ) (fields) (protocol (...)) (methods)) 0)". +record.mo:Expected error in mat oop-contributed: "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names (define-record-type Vars (parent ) (fields (mutable i) (mutable i)) (protocol (lambda (...) (...))) (methods))". +record.mo:Expected error in mat oop-contributed: "define-record-type: unrecognized parent record type aaaaa". +record.mo:Expected error in mat oop-contributed: "define-record-type: unrecognized parent record type aaaaa". +record.mo:Expected error in mat oop-contributed: "duplicate arity for method M1". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "variable j is not bound". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "variable unbound is not bound". +record.mo:Expected error in mat oop-contributed: "multiple definitions for M1 in body (let () (define-record-type One (parent ) (fields) (protocol (...)) (methods (...))) (define-record-type Two (parent ) (fields) (protocol (...)) (methods (...))) 0)". +record.mo:Expected error in mat oop-contributed: "multiple definitions for M2 in body (let () (define-record-type One (parent Pop) (fields) (protocol (...)) (methods (...) (...))) (define-record-type Two (parent Pop) (fields) (protocol (...)) (methods (...))) 0)". +record.mo:Expected error in mat oop-contributed: "variable ingnacious is not bound". +record.mo:Expected error in mat oop-contributed: "invalid syntax Class". +record.mo:Expected error in mat oop-contributed: "variable make-fowl is not bound". hash.mo:Expected error in mat old-hash-table: "get-hash-table: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "put-hash-table!: ((a . b)) is not an eq hashtable". hash.mo:Expected error in mat old-hash-table: "remove-hash-table!: ((a . b)) is not an eq hashtable". @@ -8266,6 +8324,7 @@ enum.mo:Expected error in mat enumeration: "make-record-type: cannot extend seal 8.mo:Expected error in mat generate-temporaries: "incorrect argument count in call (generate-temporaries (quote (a b c)) (quote (d e f)))". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: improper list structure (a b . c)". 8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b c b c b ...)". +8.mo:Expected error in mat generate-temporaries: "generate-temporaries: cyclic list structure (a b a b a b ...)". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". 8.mo:Expected error in mat syntax->list: "syntax->list: invalid argument #". 8.mo:Expected error in mat syntax->vector: "syntax->vector: invalid argument #". @@ -10532,71 +10591,3 @@ date.mo:Expected error in mat conversions/sleep: "sleep: 20 is not a time record exceptions.mo:Expected error in mat assert: "failed assertion (memq (quote b) (quote (1 2 a 3 4)))". exceptions.mo:Expected error in mat assert: "failed assertion (q ...)". exceptions.mo:Expected error in mat assert: "failed assertion (andmap symbol? (syntax (x ...)))". -oop.mo:Expected error in mat oop: "incorrect number of arguments to #>". -oop.mo:Expected error in mat oop: "incorrect number of arguments to #>". -oop.mo:Expected error in mat oop: "incorrect number of arguments to #". -oop.mo:Expected error in mat oop: "incorrect number of arguments to #". -oop.mo:Expected error in mat oop: "m1: not applicable to 17". -oop.mo:Expected error in mat oop: "variable -x1 is not bound". -oop.mo:Expected error in mat oop: "variable -x1-set! is not bound". -oop.mo:Expected error in mat oop: "arity not supported by base class method hit". -oop.mo:Expected error in mat oop: "no inherited bar method for baz in (super)". -oop.mo:Expected error in mat oop: "arity not supported by interface method whack". -oop.mo:Expected error in mat oop: "arity not supported by interface method whack". -oop.mo:Expected error in mat oop: "arity not supported by interface method whack". -oop.mo:Expected error in mat oop: "arity not supported by interface method spam". -oop.mo:Expected error in mat oop: "arity not supported by interface method spam". -oop.mo:Expected error in mat oop: "fish: not applicable to 3". -oop.mo:Expected error in mat oop: "rats: not applicable to 3". -oop.mo:Expected error in mat oop: "fish: not applicable to #". -oop.mo:Expected error in mat oop: "no suitable implementation for interface method rats". -oop.mo:Expected error in mat oop: "make-record-type: incompatible record type frap - different fields". -oop.mo:Expected error in mat oop: "cannot specify gensym class-name with methods or interfaces #{frap \x2E;R@iB9FE~OXVz\x5C;\x5C;%}". -oop.mo:Expected error in mat oop: "invalid syntax ". -oop.mo:Expected error in mat oop: "extra ivars clause (ivars (y 1))". -oop.mo:Expected error in mat oop: "extra methods clause (methods (get-x () x))". -oop.mo:Expected error in mat oop: "invalid assignment of immutable ivar (set! x (* x x))". -oop.mo:Expected error in mat oop: "invalid assignment of immutable ivar (set! x v)". -oop.mo:Expected error in mat oop: "variable blast-x-set! is not bound". -oop.mo:Expected error in mat oop: "variable -mupr4 is not bound". -oop.mo:Expected error in mat oop: "variable -mupr5 is not bound". -oop.mo:Expected error in mat oop: "variable -impr6 is not bound". -oop.mo:Expected error in mat oop: "variable -mupr7 is not bound". -oop.mo:Expected error in mat oop: "variable -mupr8 is not bound". -oop.mo:Expected error in mat oop: "variable -impr9 is not bound". -oop.mo:Expected error in mat oop: "variable -impu3-set! is not bound". -oop.mo:Expected error in mat oop: "variable -mupr4-set! is not bound". -oop.mo:Expected error in mat oop: "variable -mupr5-set! is not bound". -oop.mo:Expected error in mat oop: "variable -impr6-set! is not bound". -oop.mo:Expected error in mat oop: "variable -mupr7-set! is not bound". -oop.mo:Expected error in mat oop: "variable -mupr8-set! is not bound". -oop.mo:Expected error in mat oop: "variable -impr9-set! is not bound". -oop.mo:Expected error in mat oop: "variable -impu3-set! is not bound". -oop.mo:Expected error in mat oop: "-mupu1: not applicable to #>". -oop.mo:Expected error in mat oop: "-mupu1-set!: not applicable to #>". -oop.mo:Expected error in mat oop: "variable -impu1 is not bound". -oop.mo:Expected error in mat oop: "variable s$impu3-set! is not bound". -oop.mo:Expected error in mat oop: "s$mupu1: not applicable to #>". -oop.mo:Expected error in mat oop: "s$mupu1-set!: not applicable to #>". -oop.mo:Expected error in mat oop: "s$mupu1: not applicable to #>". -oop.mo:Expected error in mat oop: "s$mupu1-set!: not applicable to #>". -oop.mo:Expected error in mat oop: "incorrect number of arguments to base class ". -oop.mo:Expected error in mat oop: "no inherited foo method for in (super)". -oop.mo:Expected error in mat oop: "multiple definitions for Repeat and other identifiers in body (let () (define-class (Repeat) () (ivars) (methods)) (define-class (Repeat) () (ivars) (methods)) 0)". -oop.mo:Expected error in mat oop: "duplicate instance variable i". -oop.mo:Expected error in mat oop: "define-class: unrecognized base class aaaaa". -oop.mo:Expected error in mat oop: "define-class: unrecognized base class aaaaa". -oop.mo:Expected error in mat oop: "duplicate arity for method M1". -oop.mo:Expected error in mat oop: "incorrect number of arguments to base class ". -oop.mo:Expected error in mat oop: "variable unbound is not bound". -oop.mo:Expected error in mat oop: "variable unbound is not bound". -oop.mo:Expected error in mat oop: "variable j is not bound". -oop.mo:Expected error in mat oop: "variable unbound is not bound". -oop.mo:Expected error in mat oop: "variable unbound is not bound". -oop.mo:Expected error in mat oop: "variable unbound is not bound". -oop.mo:Expected error in mat oop: "multiple definitions for M1 in body (let () (define-class (One) () (ivars) (methods (...))) (define-class (Two) () (ivars) (methods (...))) 0)". -oop.mo:Expected error in mat oop: "multiple definitions for M2 in body (let () (define-class (One) (Pop) (ivars) (methods (...) (...))) (define-class (Two) (Pop) (ivars) (methods (...))) 0)". -oop.mo:Expected error in mat oop: "variable ingnacious is not bound". -oop.mo:Expected error in mat oop: "invalid syntax Class". -oop.mo:Expected error in mat oop: "variable oop-x1 is not bound". -oop.mo:Expected error in mat oop: "variable make-fowl is not bound". diff --git a/s/base-lang.ss b/s/base-lang.ss index 6f7f4bdd9..b029e3939 100644 --- a/s/base-lang.ss +++ b/s/base-lang.ss @@ -208,15 +208,17 @@ (for-all fixnum? x)))) (define maybe-string? (lambda (x) (or (eq? x #f) (string? x)))) + (define maybe-record-type-descriptor? (lambda (x) (or (eq? x #f) (record-type-descriptor? x)))) ; source language used by the passes leading up to the compiler or interpreter (define-language Lsrc - (nongenerative-id #{Lsrc czsa1fcfzdeh493n-3}) + (nongenerative-id #{Lsrc czsa1fcfzdeh493n-5}) (terminals (preinfo (preinfo)) ($prelex (x)) (datum (d)) (record-type-descriptor (rtd)) + (maybe-record-type-descriptor (maybe-base-rtd)) (rcd (rcd)) (source-object (src)) (maybe-source-object (maybe-src)) @@ -228,7 +230,7 @@ (maybe-string (name)) (symbol (sym type)) (primref (pr))) - (Expr (e body rtd-expr) + (Expr (e body rtd-expr extra) pr (moi) (ref maybe-src x) => x @@ -241,9 +243,10 @@ (letrec ([x* e*] ...) body) (letrec* ([x* e*] ...) body) (call preinfo e0 e1 ...) => (e0 e1 ...) - (record-type rtd e) + (record-type rtd rtd-expr maybe-base-rtd (e* ...) extra* ...) (record-cd rcd rtd-expr e) (immutable-list (e* ...) e) + (immutable-vector (e* ...) e) (record rtd rtd-expr e* ...) (record-ref rtd type index e) (record-set! rtd type index e1 e2) diff --git a/s/cp0.ss b/s/cp0.ss index 2bc77bbad..60721e721 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -87,6 +87,9 @@ ;;; used to memoize pure?, etc. (define-threaded cp0-info-hashtable) + ;;; used to memoize truth + (define-threaded cp0-truth-hashtable) + (module () (define-syntax define-cp0-param (syntax-rules () @@ -760,20 +763,23 @@ [(seq ,e1 ,e2) e2] [else e]))) + (define indirect-ref + (lambda (x) + (or (nanopass-case (Lsrc Expr) x + [(ref ,maybe-src ,x) + (and (not (prelex-was-assigned x)) + (let ([opnd (prelex-operand x)]) + (and opnd + (let ([x (operand-value opnd)]) + (and x (result-exp x))))))] + [else #f]) + x))) + (define result-exp/indirect-ref ; useful only when interested in non-propagatable result expressions, e.g., lambda expressions ; NB: to avoid code duplication, don't residualize the resulting value (lambda (x) - (let ([x (result-exp x)]) - (or (nanopass-case (Lsrc Expr) x - [(ref ,maybe-src ,x) - (and (not (prelex-was-assigned x)) - (let ([opnd (prelex-operand x)]) - (and opnd - (let ([x (operand-value opnd)]) - (and x (result-exp x))))))] - [else #f]) - x)))) + (indirect-ref (result-exp x)))) (define non-result-exp (lambda (e body) @@ -862,12 +868,13 @@ (let ([do-expr (ids->do-expr (append x* ids))]) (for-each do-expr e*) (do-expr body))] - [(record-type ,rtd ,[do-expr : e]) (void)] + [(record-type ,rtd ,[do-expr : rtd-expr] ,maybe-base-rtd (,e* ...) ,extra* ...) (void)] [(record-cd ,rcd ,rtd-expr ,[do-expr : e]) (void)] [(record-ref ,rtd ,type ,index ,[do-expr : e]) (bump!)] [(record-set! ,rtd ,type ,index ,[do-expr : e1] ,[do-expr : e2]) (bump!)] [(record ,rtd ,[do-expr : rtd-expr] ,[do-expr : e*] ...) (bump!)] [(immutable-list (,[e*] ...) ,[e]) (void)] + [(immutable-vector (,[e*] ...) ,[e]) (void)] [(pariah) (void)] [(profile ,src) (void)] [else (exit #f)])))) @@ -947,10 +954,11 @@ [(set! ,maybe-src ,x ,e) #f] [(record-cd ,rcd ,rtd-expr ,e) (memoize (pure? e))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] - [(record-type ,rtd ,e) (memoize (pure? e))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (memoize (pure? rtd-expr))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (pure? e))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap pure? e*) (pure? body)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))] + [(immutable-vector (,e* ...) ,e) (memoize (and (andmap pure? e*) (pure? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (pure? e))] [(moi) #t] @@ -1006,10 +1014,11 @@ [(set! ,maybe-src ,x ,e) #f] [(record-cd ,rcd ,rtd-expr ,e) (memoize (ivory? e))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] - [(record-type ,rtd ,e) (memoize (ivory? e))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (memoize (ivory? rtd-expr))] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (ivory? e))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap ivory? e*) (ivory? body)))] [(immutable-list (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))] + [(immutable-vector (,e* ...) ,e) (memoize (and (andmap ivory? e*) (ivory? e)))] [(profile ,src) #t] [(cte-optimization-loc ,box ,e) (memoize (ivory? e))] [(moi) #t] @@ -1045,6 +1054,7 @@ [(seq ,e1 ,e2) (memoize (and (simple? e1) (simple? e2)))] [(set! ,maybe-src ,x ,e) #f] [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple? e*) (simple? e)))] + [(immutable-vector (,e* ...) ,e) (memoize (and (andmap simple? e*) (simple? e)))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple? e*) (simple? body)))] [,pr #t] @@ -1052,7 +1062,7 @@ [(record-ref ,rtd ,type ,index ,e) (memoize (simple? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple? e))] - [(record-type ,rtd ,e) (memoize (simple? e))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (memoize (simple? rtd-expr))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple? rtd-expr) (andmap simple? e*)))] [(pariah) #f] [(profile ,src) #f] @@ -1090,6 +1100,7 @@ [(seq ,e1 ,e2) (memoize (and (simple/profile? e1) (simple/profile? e2)))] [(set! ,maybe-src ,x ,e) #f] [(immutable-list (,e* ...) ,e) (memoize (and (andmap simple/profile? e*) (simple/profile? e)))] + [(immutable-vector (,e* ...) ,e) (memoize (and (andmap simple/profile? e*) (simple/profile? e)))] [(letrec ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))] [(letrec* ([,x* ,e*] ...) ,body) (memoize (and (andmap simple/profile? e*) (simple/profile? body)))] [,pr #t] @@ -1097,7 +1108,7 @@ [(record-ref ,rtd ,type ,index ,e) (memoize (simple/profile? e))] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) (memoize (simple/profile? e))] - [(record-type ,rtd ,e) (memoize (simple/profile? e))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (memoize (simple/profile? rtd-expr))] [(record ,rtd ,rtd-expr ,e* ...) (memoize (and (simple/profile? rtd-expr) (andmap simple/profile? e*)))] [(pariah) #t] [(profile ,src) #t] @@ -1127,11 +1138,12 @@ [(letrec* ([,x* ,e*] ...) ,body) (memoize (boolean-valued? body))] [(letrec ([,x* ,e*] ...) ,body) (memoize (boolean-valued? body))] [,pr #f] - [(record-type ,rtd ,e) #f] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) #f] [(record-cd ,rcd ,rtd-expr ,e) #f] [(record-set! ,rtd ,type ,index ,e1 ,e2) #f] [(record ,rtd ,rtd-expr ,e* ...) #f] [(immutable-list (,e* ...) ,e) #f] + [(immutable-vector (,e* ...) ,e) #f] [(cte-optimization-loc ,box ,e) (memoize (boolean-valued? e))] [(profile ,src) #f] [(set! ,maybe-src ,x ,e) #f] @@ -1141,6 +1153,55 @@ [(pariah) #f] [else ($oops who "unrecognized record ~s" e)]))))) + (define-who truth + (lambda (e) + (define ($memoize e th) + (let ([a (hashtable-cell cp0-truth-hashtable e #f)]) + (or (cdr a) + (let ([x (th)]) + (set-cdr! a x) + x)))) + (define-syntax memoize + (syntax-rules () + [(_ e1 e2 ...) + ($memoize e (lambda () e1 e2 ...))])) + (nanopass-case (Lsrc Expr) e + [(call ,preinfo ,e ,e* ...) + (nanopass-case (Lsrc Expr) (result-exp e) + [,pr (guard (all-set? (prim-mask true) (primref-flags pr))) 'true] + [(case-lambda ,preinfo1 (clause (,x* ...) ,interface ,body)) + (guard (fx= interface (length e*))) + (memoize (truth body))] + [else 'unknown])] + [(if ,e0 ,e1 ,e2) + (memoize + (let ([e1 (truth e1)] [e2 (truth e2)]) + (if (eq? e1 e2) + e1 + 'unknown)))] + [(record-ref ,rtd ,type ,index ,e) 'unknown] + [(ref ,maybe-src ,x) 'unknown] + [(quote ,d) (if d 'true 'false)] + [(seq ,e1 ,e2) (memoize (truth e2))] + [(case-lambda ,preinfo ,cl* ...) 'true] + [(letrec* ([,x* ,e*] ...) ,body) (memoize (truth body))] + [(letrec ([,x* ,e*] ...) ,body) (memoize (truth body))] + [,pr (if (all-set? (prim-mask proc) (primref-flags pr)) 'true 'unknown)] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) 'true] + [(record-cd ,rcd ,rtd-expr ,e) 'true] + [(record-set! ,rtd ,type ,index ,e1 ,e2) 'true] + [(record ,rtd ,rtd-expr ,e* ...) 'true] + [(immutable-list (,e* ...) ,e) 'true] + [(immutable-vector (,e* ...) ,e) 'true] + [(cte-optimization-loc ,box ,e) (memoize (truth e))] + [(profile ,src) 'unknown] + [(set! ,maybe-src ,x ,e) 'true] + [(moi) 'unknown] + [(foreign (,conv* ...) ,name ,e (,arg-type* ...) ,result-type) 'true] + [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) 'true] + [(pariah) 'unknown] + [else ($oops who "unrecognized record ~s" e)]))) + (define find-call-lambda-clause (lambda (exp opnds) (define rest-clause @@ -1332,13 +1393,13 @@ (if (andmap eq? new-e2* e2*) e `(record ,rtd ,(car new-e2*) ,(cdr new-e2*) ...))))] - [(record-type ,rtd ,e) - (let ([e* (list e)]) + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e1* ...) ,extra* ...) + (let ([e* (list rtd-expr)]) (let-values ([(new-e* pure-e*?) (f e* (and pure-left? pure-right?))]) (safe-assert (= (length new-e*) 1)) (if (andmap eq? new-e* e*) e - `(record-type ,rtd ,(car new-e*)))))] + `(record-type ,rtd ,(car new-e*) ,maybe-base-rtd (,e1* ...) ,extra* ...))))] [(ref ,maybe-src ,x) (guard (not (prelex-assigned x)) (not (prelex-multiply-referenced x))) (let ([a (assq x alist)]) @@ -1365,8 +1426,8 @@ (drop-let (list e1 e2) (lambda (e e*) (safe-assert (= (length e*) 1)) `(record-set! ,rtd ,type ,index ,e ,(car e*))))] [(record ,rtd ,rtd-expr ,e* ...) (drop-let (cons rtd-expr e*) (lambda (rtd-expr e*) `(record ,rtd ,rtd-expr ,e* ...)))] - [(record-type ,rtd ,e) - (drop-let (list e) (lambda (e e*) (safe-assert (null? e*)) `(record-type ,rtd ,e)))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e1* ...) ,extra* ...) + (drop-let (list rtd-expr) (lambda (rtd-expr e*) (safe-assert (null? e*)) `(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e1* ...) ,extra* ...)))] [else #f])))] [else (build-let lambda-preinfo id* rhs* body)]))))])) @@ -1499,10 +1560,10 @@ (let ((rhs (result-exp (operand-value opnd)))) (nanopass-case (Lsrc Expr) rhs [(quote ,d) rhs] - [(record-type ,rtd ,e) + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) `(record-type ,rtd ,(residualize-ref maybe-src - (nanopass-case (Lsrc Expr) e + (nanopass-case (Lsrc Expr) rtd-expr [(ref ,maybe-src ,x) (guard (not (prelex-was-assigned x)) ; protect against (letrec ([x x]) ---) @@ -1511,7 +1572,8 @@ (set-prelex-was-multiply-referenced! x #t)) x] [else id]) - sc))] + sc) + ,maybe-base-rtd (,e* ...) ,extra* ...)] [(record-cd ,rcd ,rtd-expr ,e) `(record-cd ,rcd ,rtd-expr ,(residualize-ref maybe-src @@ -1538,6 +1600,19 @@ x] [else id]) sc))] + [(immutable-vector (,e* ...) ,e) + `(immutable-vector (,e* ...) + ,(residualize-ref maybe-src + (nanopass-case (Lsrc Expr) e + [(ref ,maybe-src ,x) + (guard (not (prelex-was-assigned x)) + ; protect against (letrec ([x x]) ---) + (not (eq? x id))) + (when (prelex-was-multiply-referenced id) + (set-prelex-was-multiply-referenced! x #t)) + x] + [else id]) + sc))] [(ref ,maybe-src1 ,x) (cond [(and (not (prelex-was-assigned x)) @@ -2074,9 +2149,10 @@ [,pr (list e)] [(foreign (,conv* ...) ,name ,e0 (,arg-type* ...) ,result-type) (list e)] [(fcallable (,conv* ...) ,e0 (,arg-type* ...) ,result-type) (list e)] - [(record-type ,rtd0 ,e0) (list e)] + [(record-type ,rtd0 ,rtd-expr0 ,maybe-base-rtd0 (,e* ...) ,extra0* ...) (list e)] [(record-cd ,rcd0 ,rtd-expr0 ,e0) (list e)] [(immutable-list (,e0* ...) ,e0) (list e)] + [(immutable-vector (,e0* ...) ,e0) (list e)] [(record-ref ,rtd ,type ,index ,e0) (list e)] [(record-set! ,rtd ,type ,index ,e1 ,e2) (list e)] [(record ,rtd ,rtd-expr ,e* ...) (list e)] @@ -2142,6 +2218,38 @@ empty-vector-rec)] [args #f]) + (define-inline 2 immutable-vector + [() (begin + (residualize-seq '() '() ctxt) + `(quote ,(immutable-vector)))] + [opnd* + (or (let ([e* (objs-if-constant (value-visit-operands! opnd*))]) + (and e* + (begin + (residualize-seq '() opnd* ctxt) + `(quote ,(apply immutable-vector e*))))) + (begin + (residualize-seq opnd* '() ctxt) + (let loop ([e* (value-visit-operands! opnd*)] + [lhs* '()] + [rhs* '()] + [re* '()]) + (if (null? e*) + (let ([e* (reverse re*)]) + (let ([e `(immutable-vector (,e* ...) + ,(build-primcall 3 'immutable-vector e*))]) + (if (null? lhs*) + e + (build-let lhs* rhs* e)))) + (let ([e (car e*)] [e* (cdr e*)]) + (if (nanopass-case (Lsrc Expr) e + [(quote ,d) #t] + [(ref ,maybe-src ,x) (not (prelex-was-assigned x))] + [else #f]) + (loop e* lhs* rhs* (cons e re*)) + (let ([t (cp0-make-temp #t)]) + (loop e* (cons t lhs*) (cons e rhs*) (cons (build-ref t) re*)))))))))]) + (define-inline 2 string [() (begin (residualize-seq '() '() ctxt) @@ -2661,11 +2769,40 @@ #f] [else #f]))]) + (define-inline 2 $query-interface + [(x y) + (let ([iface-rtd-e (result-exp (value-visit-operand! x))] + [ego-e (result-exp/indirect-ref (value-visit-operand! y))]) + (nanopass-case (Lsrc Expr) iface-rtd-e + [(quote ,d) + (guard (record-type-descriptor? d) (not (ctrtd? d))) + (let ([iface-rtd d]) + (nanopass-case (Lsrc Expr) ego-e + [(record ,rtd0 (record-type ,rtd1 ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) ,e0* ...) + (let loop ([e* e*]) + (and (not (null? e*)) + (nanopass-case (Lsrc Expr) (car e*) + [(ref ,maybe-src ,x) #t] + [else #f]) + (or (nanopass-case (Lsrc Expr) (indirect-ref (car e*)) + [(record ,rtd ,rtd-expr ,e2* ...) + (guard + (let f ([rtd rtd]) + (or (eq? rtd iface-rtd) + (let ([rtd (record-type-parent rtd)]) + (and rtd (f rtd)))))) + (residualize-seq '() (list x y) ctxt) + (car e*)] + [else #f]) + (loop (cdr e*)))))] + [else #f]))] + [else #f]))]) + (let () (define (get-prtd ?parent k) (if ?parent (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?parent)) - [(record-type ,rtd ,e) + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (and (not (record-type-sealed? rtd)) (k rtd))] [(quote ,d) (and (or (eq? d #f) @@ -2698,97 +2835,145 @@ (values #f ctrtd-opaque-known) (values #f 0)))] [else (values #f 0)]))) + (define (bind-extras expr* k) + (let loop ([expr* expr*] [rexpr* '()] [rt* '()] [re* '()]) + (if (null? expr*) + (let ([body (k (reverse rexpr*))]) + (if (null? rt*) + body + (build-let rt* re* body))) + (let ([expr (car expr*)] [expr* (cdr expr*)]) + (if (nanopass-case (Lsrc Expr) expr + [(quote ,d) #t] + [(ref ,maybe-src ,x) (not (prelex-was-assigned x))] + [else #f]) + (loop expr* (cons expr rexpr*) rt* re*) + (let ([t (cp0-make-temp #f)]) + (loop expr* (cons (build-ref t) rexpr*) (cons t rt*) (cons expr re*)))))))) (let () - (define (mrt ?parent ?name ?fields maybe-?sealed maybe-?opaque ctxt level prim primname opnd*) - (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?name)) - [(quote ,d) - (and (gensym? d) - (let ([objs (objs-if-constant (value-visit-operands! opnd*))]) - (and objs - (let ([rtd (guard (c [#t #f]) (apply prim objs))]) - (and rtd - (begin - (residualize-seq '() opnd* ctxt) - `(quote ,rtd)))))))] - [else #f]) - (get-prtd ?parent - (lambda (prtd) - (get-fields ?fields - (lambda (fields) - (let-values ([(sealed? sealed-flag) (get-sealed maybe-?sealed)] - [(opaque? opaque-flag) (get-opaque maybe-?opaque prtd)]) - (cond - [(guard (c [#t #f]) - ($make-record-type base-ctrtd prtd "tmp" fields - sealed? opaque? (fxlogor sealed-flag opaque-flag))) => - (lambda (ctrtd) - (residualize-seq opnd* '() ctxt) - `(record-type ,ctrtd - ,(build-primcall (app-preinfo ctxt) level primname - (value-visit-operands! opnd*))))] - [else #f])))))))) + (define (mrt maybe-?base-rtd ?parent ?name ?fields maybe-?sealed maybe-?opaque ctxt level prim primname regular-opnd* extra-opnd*) + (let ([all-opnd* (append regular-opnd* extra-opnd*)]) + (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?name)) + [(quote ,d) + (and (gensym? d) + (let ([objs (objs-if-constant (value-visit-operands! all-opnd*))]) + (and objs + (let ([rtd (guard (c [#t #f]) (apply prim objs))]) + (and rtd + (begin + (residualize-seq '() all-opnd* ctxt) + `(quote ,rtd)))))))] + [else #f]) + (get-prtd ?parent + (lambda (prtd) + (get-fields ?fields + (lambda (fields) + (let-values ([(sealed? sealed-flag) (get-sealed maybe-?sealed)] + [(opaque? opaque-flag) (get-opaque maybe-?opaque prtd)]) + (cond + [(guard (c [#t #f]) + ($make-record-type base-ctrtd prtd "tmp" fields + sealed? opaque? (fxlogor sealed-flag opaque-flag))) => + (lambda (ctrtd) + (residualize-seq all-opnd* '() ctxt) + (bind-extras (value-visit-operands! extra-opnd*) + (lambda (extra-expr*) + `(record-type ,ctrtd + ,(build-primcall (app-preinfo ctxt) level primname + (append (value-visit-operands! regular-opnd*) extra-expr*)) + ,(if maybe-?base-rtd + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! maybe-?base-rtd)) + [(quote ,d) d] + [else #f]) + #!base-rtd) + () ,extra-expr* ...))))] + [else #f]))))))))) (define-inline 2 make-record-type [(?name ?fields) - (mrt #f ?name ?fields #f #f ctxt level make-record-type 'make-record-type - (list ?name ?fields))] + (mrt #f #f ?name ?fields #f #f ctxt level make-record-type 'make-record-type + (list ?name ?fields) + '())] [(?parent ?name ?fields) - (mrt ?parent ?name ?fields #f #f ctxt level make-record-type 'make-record-type - (list ?parent ?name ?fields))]) + (mrt #f ?parent ?name ?fields #f #f ctxt level make-record-type 'make-record-type + (list ?parent ?name ?fields) + '())]) (define-inline 2 $make-record-type - [(?base-id ?parent ?name ?fields ?sealed ?opaque . ?extras) - (mrt ?parent ?name ?fields ?sealed ?opaque ctxt level $make-record-type '$make-record-type - (list* ?base-id ?parent ?name ?fields ?sealed ?opaque ?extras))])) + [(?base-rtd ?parent ?name ?fields ?sealed ?opaque . ?extras) + (mrt ?base-rtd ?parent ?name ?fields ?sealed ?opaque ctxt level $make-record-type '$make-record-type + (list ?base-rtd ?parent ?name ?fields ?sealed ?opaque) + ?extras)])) (let () - (define (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level prim primname opnd*) - (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?uid)) - [(quote ,d) - (and d - (let ([objs (objs-if-constant (value-visit-operands! opnd*))]) - (and objs - (let ([rtd (guard (c [#t #f]) (apply prim objs))]) - (and rtd - (begin - (residualize-seq '() opnd* ctxt) - `(quote ,rtd)))))))] - [else #f]) - (get-prtd ?parent - (lambda (prtd) - (get-fields ?fields - (lambda (fields) - (let-values ([(sealed? sealed-flag) (get-sealed ?sealed)] - [(opaque? opaque-flag) (get-opaque ?opaque prtd)]) - (cond - [(guard (c [#t #f]) - ($make-record-type-descriptor base-ctrtd 'tmp prtd #f - sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag))) => - (lambda (rtd) - (residualize-seq opnd* '() ctxt) - `(record-type ,rtd - ; can't use level 3 unconditionally because we're missing checks for - ; ?base-rtd, ?name, ?uid, ?who, and ?extras - ,(build-primcall (app-preinfo ctxt) level primname - (value-visit-operands! opnd*))))] - [else #f])))))))) + (define (mrtd maybe-?base-rtd ?parent ?uid ?fields ?sealed ?opaque ctxt level prim primname maybe-?interfaces regular-opnd* extra-opnd*) + (let ([all-opnd* (append regular-opnd* extra-opnd*)]) + (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?uid)) + [(quote ,d) + (and d + (let ([objs (objs-if-constant (value-visit-operands! all-opnd*))]) + (and objs + (let ([rtd (guard (c [#t #f]) (apply prim objs))]) + (and rtd + (begin + (residualize-seq '() all-opnd* ctxt) + `(quote ,rtd)))))))] + [else #f]) + (get-prtd ?parent + (lambda (prtd) + (get-fields ?fields + (lambda (fields) + (let-values ([(sealed? sealed-flag) (get-sealed ?sealed)] + [(opaque? opaque-flag) (get-opaque ?opaque prtd)]) + (cond + [(guard (c [#t #f]) + ($make-record-type-descriptor base-ctrtd 'tmp prtd #f + sealed? opaque? fields 'cp0 (fxlogor sealed-flag opaque-flag))) => + (lambda (rtd) + (residualize-seq all-opnd* '() ctxt) + (bind-extras (value-visit-operands! extra-opnd*) + (lambda (extra-expr*) + `(record-type ,rtd + ; can't use level 3 unconditionally because we're missing checks for + ; ?base-rtd, ?name, ?uid, ?who, and ?extras + ,(build-primcall (app-preinfo ctxt) level primname + (append (value-visit-operands! regular-opnd*) extra-expr*)) + ,(if maybe-?base-rtd + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! maybe-?base-rtd)) + [(quote ,d) d] + [else #f]) + #!base-rtd) + (,(if maybe-?interfaces + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! maybe-?interfaces)) + [(immutable-vector (,e* ...) ,e) e*] + [else '()]) + '()) + ...) + ,extra-expr* ...))))] + [else #f]))))))))) (define-inline 2 make-record-type-descriptor [(?name ?parent ?uid ?sealed ?opaque ?fields) - (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level + (mrtd #f ?parent ?uid ?fields ?sealed ?opaque ctxt level make-record-type-descriptor 'make-record-type-descriptor - (list ?name ?parent ?uid ?sealed ?opaque ?fields))]) + #f + (list ?name ?parent ?uid ?sealed ?opaque ?fields) + '())]) (define-inline 2 $make-record-type-descriptor [(?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who . ?extras) - (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level + (mrtd ?base-rtd ?parent ?uid ?fields ?sealed ?opaque ctxt level $make-record-type-descriptor '$make-record-type-descriptor - (list* ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who ?extras))]) + #f + (list ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?who) + ?extras)]) (define-inline 2 $make-record-type-descriptor/interfaces [(?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?interfaces ?who . ?extras) - (mrtd ?parent ?uid ?fields ?sealed ?opaque ctxt level + (mrtd ?base-rtd ?parent ?uid ?fields ?sealed ?opaque ctxt level $make-record-type-descriptor '$make-record-type-descriptor/interfaces - (list* ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?interfaces ?who ?extras))]))) + ?interfaces + (list ?base-rtd ?name ?parent ?uid ?sealed ?opaque ?fields ?interfaces ?who) + ?extras)]))) (let () ; if you update this, also update duplicate in record.ss (define-record-type rcd @@ -2821,9 +3006,9 @@ (and (record-type-descriptor? d) (eqv? (rtd-pm d) -1) ; all ptrs (k d expr))] - [(record-type ,rtd (ref ,maybe-src ,x)) + [(record-type ,rtd (ref ,maybe-src ,x) ,maybe-base-rtd (,e* ...) ,extra* ...) (and (eqv? (rtd-pm rtd) -1) ; all ptrs - (k rtd `(ref ,maybe-src ,x)))] + (k rtd expr))] [else #f]))) (define (get-prcd ?prcd rtd k) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?prcd)) @@ -2923,10 +3108,10 @@ (let ([expr (result-exp (value-visit-operand! ?rtd))]) (nanopass-case (Lsrc Expr) expr [(quote ,d) (and (record-type-descriptor? d) (k1 d expr))] - [(record-type ,rtd ,e) - (nanopass-case (Lsrc Expr) e - [(ref ,maybe-src ,x) (k1 rtd e)] - [else (k2 rtd e)])] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (nanopass-case (Lsrc Expr) rtd-expr + [(ref ,maybe-src ,x) (k1 rtd expr)] + [else (k2 rtd expr)])] [else #f]))) (define-inline 2 record-predicate [(?rtd) @@ -3098,16 +3283,16 @@ [(?rtd/rcd) (and likely-to-be-compiled? (cond - [(let ([x (result-exp (value-visit-operand! ?rtd/rcd))]) - (nanopass-case (Lsrc Expr) x - [(quote ,d) (and (record-type-descriptor? d) (cons d x))] - [(record-type ,rtd (ref ,maybe-src ,x)) (cons rtd `(ref ,maybe-src ,x))] + [(let ([expr (result-exp (value-visit-operand! ?rtd/rcd))]) + (nanopass-case (Lsrc Expr) expr + [(quote ,d) (and (record-type-descriptor? d) (cons d expr))] + [(record-type ,rtd (ref ,maybe-src ,x) ,maybe-base-rtd (,e* ...) ,extra* ...) (cons rtd expr)] [else #f])) => (lambda (rtd.rtd-e) (residualize-seq '() (list ?rtd/rcd) ctxt) (finish ctxt sc wd moi (go (< level 3) (car rtd.rtd-e) (cdr rtd.rtd-e) ctxt)))] [(nanopass-case (Lsrc Expr) (result-exp (operand-value ?rtd/rcd)) - [(record-type ,rtd ,e) rtd] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) rtd] [else #f]) => (lambda (rtd) (residualize-seq (list ?rtd/rcd) '() ctxt) @@ -3122,7 +3307,7 @@ (try-rcd level ?rcd ctxt sc wd name moi))]))) (let () - (define (find-fld ?field rtd-e rtd k) + (define (find-fld ?field rtd k) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field)) [(quote ,d) (cond @@ -3133,168 +3318,154 @@ (and (not (null? flds)) (let ([fld (car flds)]) (if (eq? d (fld-name fld)) - (k rtd-e rtd fld index) + (k rtd fld index) (loop (cdr flds) index))))))] [(fixnum? d) (let ((flds (rtd-flds rtd))) (and ($fxu< d (length flds)) - (k rtd-e rtd (list-ref flds d) d)))] + (k rtd (list-ref flds d) d)))] [else #f])] [else #f])) - (define (r6rs:find-fld ?field rtd-e rtd k) + (define (r6rs:find-fld ?field rtd k) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?field)) [(quote ,d) (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)]) (let ([index (if prtd (+ d (length (rtd-flds prtd))) d)]) (and ($fxu< index (length flds)) - (k rtd-e rtd (list-ref flds index) index))))] + (k rtd (list-ref flds index) index))))] [else #f])) (define (find-rtd-and-field ?rtd ?field find-fld k) - (let ([x (result-exp (value-visit-operand! ?rtd))]) - (nanopass-case (Lsrc Expr) x - [(quote ,d) - (and (record-type-descriptor? d) (find-fld ?field x d k))] - [(record-type ,rtd ,e) - (find-fld ?field e rtd k)] - [else #f]))) + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) + [(quote ,d) + (and (record-type-descriptor? d) (find-fld ?field d k))] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (find-fld ?field rtd k)] + [else #f])) + + (define maybe-cons (lambda (x ls) (if x (cons x ls) ls))) + + (define (add-record-check name rec-ref rtd-e expr) + (make-seq 'value + `(if ,(build-primcall 3 'record? (list rec-ref rtd-e)) + ,void-rec + ,(build-primcall 3 '$record-oops + (list name rec-ref rtd-e))) + expr)) (let () - (define (rfa ?rtd ?field level ctxt find-fld) + (define (rfa ?proxy ?rtd ?field level ctxt find-fld) (and likely-to-be-compiled? - (find-rtd-and-field ?rtd ?field find-fld - (lambda (rtd-e rtd fld index) - ; assuming all fields are accessible - (let ([rec-t (cp0-make-temp #t)]) - (let ([expr `(record-ref ,rtd ,(fld-type fld) ,index (ref #f ,rec-t))]) - (cond - [(fx= level 3) - (residualize-seq '() (list ?rtd ?field) ctxt) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) (list rec-t) expr)] - [(nanopass-case (Lsrc Expr) rtd-e - [(quote ,d) #t] - [(ref ,maybe-src ,x) #t] - [else #f]) - (residualize-seq '() (list ?rtd ?field) ctxt) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) (list rec-t) - `(seq - (if ,(build-primcall 3 'record? - (list (build-ref rec-t) rtd-e)) - ,void-rec - ,(build-primcall 3 '$record-oops - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - (build-ref rec-t) - rtd-e))) - ,expr))] - [else - (let ([rtd-t (cp0-make-temp #t)]) - (residualize-seq (list ?rtd) (list ?field) ctxt) - (build-let (list rtd-t) (list (operand-value ?rtd)) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) (list rec-t) - `(seq - (if ,(build-primcall 3 'record? - (list (build-ref rec-t) (build-ref rtd-t))) - ,void-rec - ,(build-primcall 3 '$record-oops - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - (build-ref rec-t) - (build-ref rtd-t)))) - ,expr))))]))))))) + (find-rtd-and-field (or ?proxy ?rtd) ?field find-fld + (lambda (rtd fld index) + (define (add-lambda rec-t expr) + (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) (list rec-t) expr)) + (define (build-record-ref rec-ref) + `(record-ref ,rtd ,(fld-type fld) ,index ,rec-ref)) + (if (or (fx= level 3) (not ?rtd)) + (let* ([rec-t (cp0-make-temp #f)] [rec-ref (build-ref rec-t)]) + (residualize-seq '() (maybe-cons ?proxy (maybe-cons ?rtd (list ?field))) ctxt) + (add-lambda rec-t (build-record-ref rec-ref))) + (let* ([rec-t (cp0-make-temp #t)] + [rec-ref (build-ref rec-t)] + [expr (build-record-ref rec-ref)] + [rtd-e (result-exp (value-visit-operand! ?rtd))] + [name (let ([name (app-name ctxt)]) + (if name `(quote ,name) `(moi)))]) + (if (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) + [(quote ,d) #t] + [(ref ,maybe-src ,x) #t] + [else #f]) + (begin + (residualize-seq '() (maybe-cons ?proxy (list ?rtd ?field)) ctxt) + (add-lambda rec-t + (add-record-check name rec-ref rtd-e + expr))) + (let* ([rtd-t (cp0-make-temp #t)] [rtd-e (build-ref rtd-t)]) + (residualize-seq (list ?rtd) (maybe-cons ?proxy (list ?field)) ctxt) + (build-let (list rtd-t) (list (operand-value ?rtd)) + (add-lambda rec-t + (add-record-check name rec-ref rtd-e + expr))))))))))) (define-inline 2 csv7:record-field-accessor - [(?rtd ?field) (finish ctxt sc wd moi (rfa ?rtd ?field level ctxt find-fld))]) + [(?rtd ?field) (finish ctxt sc wd moi (rfa #f ?rtd ?field level ctxt find-fld))]) (define-inline 2 record-accessor - [(?rtd ?field) (finish ctxt sc wd moi (rfa ?rtd ?field level ctxt r6rs:find-fld))])) + [(?rtd ?field) (finish ctxt sc wd moi (rfa #f ?rtd ?field level ctxt r6rs:find-fld))]) + (define-inline 2 $record-accessor/proxy + [(?proxy ?field) (finish ctxt sc wd moi (rfa ?proxy #f ?field level ctxt r6rs:find-fld))] + [(?proxy ?rtd ?field) (finish ctxt sc wd moi (rfa ?proxy ?rtd ?field level ctxt r6rs:find-fld))])) (let () - (define (rfm ?rtd ?field level ctxt who find-fld) + (define (rfm ?proxy ?rtd ?field level ctxt who find-fld) (and likely-to-be-compiled? - (find-rtd-and-field ?rtd ?field find-fld - (lambda (rtd-e rtd fld index) + (find-rtd-and-field (or ?proxy ?rtd) ?field find-fld + (lambda (rtd fld index) (and (fld-mutable? fld) (let* ([type (fld-type fld)] [real-type (filter-foreign-type type)] - [rec-t (cp0-make-temp #t)] - [val-t (cp0-make-temp #t)]) - (let ([expr `(record-set! ,rtd ,type ,index (ref #f ,rec-t) (ref #f ,val-t))] - [pred (and (not (memq real-type '(scheme-object boolean))) - (type->pred who real-type val-t))]) - (cond - [(fx= level 3) - (residualize-seq '() (list ?rtd ?field) ctxt) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) - (list rec-t val-t) - expr)] - [(nanopass-case (Lsrc Expr) rtd-e - [(quote ,d) #t] - [(ref ,maybe-src ,x) #t] - [else #f]) - (residualize-seq '() (list ?rtd ?field) ctxt) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) - (list rec-t val-t) - (make-seq 'value - `(if ,(build-primcall 3 'record? - (list (build-ref rec-t) rtd-e)) - ,void-rec - ,(build-primcall 3 '$record-oops - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - (build-ref rec-t) - rtd-e))) - (if pred - (make-seq 'value - `(if ,pred ,void-rec - ,(build-primcall 3 'assertion-violationf - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - `(quote ,(format "invalid value ~~s for foreign type ~s" type)) - (build-ref val-t)))) - expr) - expr)))] - [else - (let ([rtd-t (cp0-make-temp #t)]) - (residualize-seq (list ?rtd) (list ?field) ctxt) - (build-let (list rtd-t) (list (operand-value ?rtd)) - (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) - (list rec-t val-t) - (make-seq 'value - `(if ,(build-primcall 3 'record? - (list (build-ref rec-t) (build-ref rtd-t))) - ,void-rec - ,(build-primcall 3 '$record-oops - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - (build-ref rec-t) - (build-ref rtd-t)))) - (if pred - (make-seq 'value - `(if ,pred ,void-rec - ,(build-primcall 3 'assertion-violationf - (list (let ([name (app-name ctxt)]) - (if name `(quote ,name) `(moi))) - `(quote ,(format "invalid value ~~s for foreign type ~s" type)) - (build-ref val-t)))) - expr) - expr)))))])))))))) + [val-t (cp0-make-temp #t)] + [val-ref (build-ref val-t)]) + (define (add-lambda rec-t expr) + (build-lambda (preinfo-call->preinfo-lambda (app-preinfo ctxt)) (list rec-t val-t) expr)) + (define (build-record-set! rec-ref) + `(record-set! ,rtd ,type ,index ,rec-ref ,val-ref)) + (define (add-type-check name expr) + (if (memq real-type '(scheme-object boolean)) + expr + `(seq + (if ,(type->pred who real-type val-t) + ,void-rec + ,(build-primcall 3 'assertion-violationf + (list name + `(quote ,(format "invalid value ~~s for foreign type ~s" type)) + val-ref))) + ,expr))) + (if (or (fx= level 3) (not ?rtd)) + (let* ([rec-t (cp0-make-temp #f)] [rec-ref (build-ref rec-t)]) + (residualize-seq '() (maybe-cons ?proxy (maybe-cons ?rtd (list ?field))) ctxt) + (add-lambda rec-t (build-record-set! rec-ref))) + (let* ([rec-t (cp0-make-temp #t)] + [rec-ref (build-ref rec-t)] + [rtd-e (result-exp (value-visit-operand! ?rtd))] + [name (let ([name (app-name ctxt)]) + (if name `(quote ,name) `(moi)))] + [expr (add-type-check name (build-record-set! rec-ref))]) + (if (nanopass-case (Lsrc Expr) rtd-e + [(quote ,d) #t] + [(ref ,maybe-src ,x) #t] + [else #f]) + (begin + (residualize-seq '() (maybe-cons ?proxy (list ?rtd ?field)) ctxt) + (add-lambda rec-t + (add-record-check name rec-ref rtd-e + expr))) + (let* ([rtd-t (cp0-make-temp #t)] [rtd-e (build-ref rtd-t)]) + (residualize-seq (list ?rtd) (maybe-cons ?proxy (list ?field)) ctxt) + (build-let (list rtd-t) (list (operand-value ?rtd)) + (add-lambda rec-t + (add-record-check name rec-ref rtd-e + expr))))))))))))) (define-inline 2 csv7:record-field-mutator - [(?rtd ?field) (finish ctxt sc wd moi (rfm ?rtd ?field level ctxt 'record-field-mutator find-fld))]) + [(?rtd ?field) (finish ctxt sc wd moi (rfm #f ?rtd ?field level ctxt 'record-field-mutator find-fld))]) (define-inline 2 record-mutator - [(?rtd ?field) (finish ctxt sc wd moi (rfm ?rtd ?field level ctxt 'record-mutator r6rs:find-fld))])) + [(?rtd ?field) (finish ctxt sc wd moi (rfm #f ?rtd ?field level ctxt 'record-mutator r6rs:find-fld))]) + (define-inline 2 $record-mutator/proxy + [(?proxy ?field) (finish ctxt sc wd moi (rfm ?proxy #f ?field level ctxt 'record-mutator r6rs:find-fld))] + [(?proxy ?rtd ?field) (finish ctxt sc wd moi (rfm ?proxy ?rtd ?field level ctxt 'record-mutator r6rs:find-fld))])) (define-inline 2 csv7:record-field-accessible? [(?rtd ?field) ; always true, but first verify that rtd & field are valid to avoid suppressing run-time errors (find-rtd-and-field ?rtd ?field find-fld - (lambda (rtd-e rtd fld index) + (lambda (rtd fld index) (residualize-seq '() (list ?rtd ?field) ctxt) true-rec))]) (let () (define (rfm? ?rtd ?field ctxt find-fld) (find-rtd-and-field ?rtd ?field find-fld - (lambda (rtd-e rtd fld index) + (lambda (rtd fld index) (residualize-seq '() (list ?rtd ?field) ctxt) `(quote ,(fld-mutable? fld))))) (define-inline 2 csv7:record-field-mutable? @@ -3310,15 +3481,24 @@ ; could handle record-type forms if ctrtd recorded rtdrtd (a ctrtd's rtd is always base-ctrtd) [(record ,rtd ,rtd-expr ,e* ...) (and (not (record-type-opaque? rtd)) - (if (ctrtd? rtd) - (begin - (residualize-seq (list ?record) '() ctxt) - `(record-type ,rtd - ,(build-primcall (app-preinfo ctxt) level prim-name - (list x)))) - (begin - (residualize-seq '() (list ?record) ctxt) - `(quote ,rtd))))] + (nanopass-case (Lsrc Expr) rtd-expr + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (residualize-seq (list ?record) '() ctxt) + `(record-type ,rtd + ,(build-primcall (app-preinfo ctxt) level prim-name (list x)) + ,maybe-base-rtd + (,e* ...) ,extra* ...)] + [else + (if (ctrtd? rtd) + (begin + (residualize-seq (list ?record) '() ctxt) + `(record-type ,rtd + ,(build-primcall (app-preinfo ctxt) level prim-name + (list x)) + #f ())) + (begin + (residualize-seq '() (list ?record) ctxt) + `(quote ,rtd)))]))] [(quote ,d) (and (record? d) (begin @@ -3330,7 +3510,7 @@ [(?x) (cond [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?x)) - [(record-type ,rtd ,e) #t] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) #t] [(quote ,d) (record-type-descriptor? d)] [else #f]) (residualize-seq '() (list ?x) ctxt) @@ -3351,7 +3531,7 @@ (define-inline 2 record-type-sealed? [(?rtd) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) - [(record-type ,rtd ,e) + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (and (record-type-sealed-known? rtd) (begin (residualize-seq '() (list ?rtd) ctxt) @@ -3366,7 +3546,7 @@ (define-inline 2 record-type-opaque? [(?rtd) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) - [(record-type ,rtd ,e) + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (and (record-type-opaque-known? rtd) (begin (residualize-seq '() (list ?rtd) ctxt) @@ -3388,6 +3568,7 @@ [(fcallable (,conv* ...) ,e (,arg-type* ...) ,result-type) #t] [(record-set! ,rtd ,type ,index ,e1 ,e2) #t] [(immutable-list (,e* ...) ,e) #t] + [(immutable-vector (,e* ...) ,e) #t] [else #f]))) (define one-arg-case (lambda (?x ctxt) @@ -3461,8 +3642,15 @@ (and rtd (f rtd)))))) (residualize-seq '() (list ?x ?rtd) ctxt) true-rec] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (guard (let f ([rtd maybe-base-rtd]) + (and rtd + (or (eq? rtd d0) + (f (record-type-parent rtd)))))) + (residualize-seq '() (list ?x ?rtd) ctxt) + true-rec] [else (abandon-ship xval xres d0)]))))] - [(record-type ,rtd ,e) + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) (cond [(nanopass-case (Lsrc Expr) (result-exp/indirect-ref (value-visit-operand! ?x)) [(record ,rtd2 ,rtd-expr ,e* ...) @@ -3470,15 +3658,21 @@ (or (eq? rtd2 rtd) (let ([rtd2 (record-type-parent rtd2)]) (and rtd2 (f rtd2)))))] + [(record-type ,rtd1 ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (let f ([rtd2 maybe-base-rtd]) + (and rtd2 + (or (eq? rtd2 rtd) + (f (record-type-parent rtd2)))))] [else #f]) (residualize-seq '() (list ?x ?rtd) ctxt) true-rec] [(nanopass-case (Lsrc Expr) (result-exp/indirect-ref (value-visit-operand! ?x)) [(quote ,d1) (and (record? d1) (obviously-incompatible? (record-rtd d1) rtd))] - ; could handle record-type forms if ctrtd recorded rtdrtd (a ctrtd's rtd is always base-ctrtd) [(record ,rtd2 ,rtd-expr ,e* ...) (obviously-incompatible? rtd2 rtd)] + [(record-type ,rtd1 ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (and maybe-base-rtd (obviously-incompatible? maybe-base-rtd rtd))] [else #f]) (residualize-seq '() (list ?x ?rtd) ctxt) false-rec] @@ -3494,7 +3688,7 @@ [(?rtd) (cond [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) - [(record-type ,rtd ,e) rtd] + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) rtd] [(quote ,d) (and (record-type-descriptor? d) d)] [else #f]) => (lambda (rtd) @@ -3506,7 +3700,7 @@ [(?rtd) (cond [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) - [(record-type ,rtd ,e) rtd] + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) rtd] [(quote ,d) (and (record-type-descriptor? d) d)] [else #f]) => (lambda (rtd) @@ -3514,11 +3708,23 @@ `(quote ,(record-type-field-names rtd)))] [else #f])]) + (define-inline 2 $record-type-field-offsets + [(?rtd) + (cond + [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) rtd] + [(quote ,d) (and (record-type-descriptor? d) d)] + [else #f]) => + (lambda (rtd) + (residualize-seq '() (list ?rtd) ctxt) + `(quote ,($record-type-field-offsets rtd)))] + [else #f])]) + (define-inline 2 csv7:record-type-field-decls [(?rtd) (cond [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?rtd)) - [(record-type ,rtd ,e) rtd] + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) rtd] [(quote ,d) (and (record-type-descriptor? d) d)] [else #f]) => (lambda (rtd) @@ -3580,16 +3786,16 @@ (nanopass-case (Lsrc Expr) (result-exp rtd-expr) [(quote ,d) (and (record-type-descriptor? d) - (if (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds d)) - (let ([e* (objs-if-constant (value-visit-operands! ?e*))]) - (and e* - (begin - (residualize-seq '() (cons ?rtd ?e*) ctxt) - `(quote ,(apply $record d e*))))) + (or (and (andmap (lambda (fld) (not (fld-mutable? fld))) (rtd-flds d)) + (let ([e* (objs-if-constant (value-visit-operands! ?e*))]) + (and e* + (begin + (residualize-seq '() (cons ?rtd ?e*) ctxt) + `(quote ,(apply $record d e*)))))) (begin (residualize-seq (cons ?rtd ?e*) '() ctxt) `(record ,d ,rtd-expr ,(map value-visit-operand! ?e*) ...))))] - [(record-type ,rtd ,e) + [(record-type ,rtd ,e ,maybe-base-rtd (,e* ...) ,extra* ...) (begin (residualize-seq (cons ?rtd ?e*) '() ctxt) `(record ,rtd ,rtd-expr ,(map value-visit-operand! ?e*) ...))] @@ -4280,7 +4486,17 @@ (define true (lambda (x) #t)) (define-inline 2 vector-ref - [(?x ?i) (tryref ctxt ?x ?i 'vector #f)]) + [(?x ?i) + (or (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?x)) + [(immutable-vector (,e* ...) ,e) + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?i)) + [(quote ,d) + (guard (fixnum? d) (#%$fxu< d (length e*))) + (residualize-seq '() (app-opnds ctxt) ctxt) + (list-ref e* d)] + [else #f])] + [else #f]) + (tryref ctxt ?x ?i 'vector #f))]) (define-inline 2 string-ref [(?x ?i) (tryref ctxt ?x ?i 'string char?)]) @@ -4543,14 +4759,26 @@ [(seq ,[cp0 : e1 'effect env sc wd #f moi -> e1] ,e2) (make-seq ctxt e1 (cp0 e2 ctxt env sc wd name moi))] [(if ,[cp0 : e1 'test env sc wd #f moi -> e1] ,e2 ,e3) - (nanopass-case (Lsrc Expr) (result-exp e1) - [(quote ,d) - (make-seq ctxt e1 (cp0 (if d e2 e3) ctxt env sc wd name moi))] + (case (truth (result-exp e1)) + [(true) (make-seq ctxt e1 (cp0 e2 ctxt env sc wd name moi))] + [(false) (make-seq ctxt e1 (cp0 e3 ctxt env sc wd name moi))] [else - (let ((noappctxt (if (app? ctxt) 'value ctxt))) - (let ([e2 (cp0 e2 noappctxt env sc wd name moi)] - [e3 (cp0 e3 noappctxt env sc wd name moi)]) - (make-if ctxt sc e1 e2 e3)))])] + (or (nanopass-case (Lsrc Expr) (result-exp e1) + [(ref ,maybe-src ,x) + (and (not (prelex-was-assigned x)) + (let ([opnd (prelex-operand x)]) + (and opnd + (let ([e (result-exp (operand-value opnd))]) + (and e + (case (truth e) + [(true) (make-seq ctxt e1 (cp0 e2 ctxt env sc wd name moi))] + [(false) (make-seq ctxt e1 (cp0 e3 ctxt env sc wd name moi))] + [else #f]))))))] + [else #f]) + (let ((noappctxt (if (app? ctxt) 'value ctxt))) + (let ([e2 (cp0 e2 noappctxt env sc wd name moi)] + [e3 (cp0 e3 noappctxt env sc wd name moi)]) + (make-if ctxt sc e1 e2 e3))))])] [(set! ,maybe-src ,x ,e) (let ((new-id (lookup x env))) (if (prelex-was-referenced new-id) @@ -4729,6 +4957,25 @@ e (make-seq ctxt (make-seq* 'effect e*) e)))) (loop (cdr e*) (cons (car e*) re*) (fx- index 1)))))] + [(record-type ,rtd1 ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) + (and (let f ([rtd2 maybe-base-rtd]) + (and rtd2 + (or (eq? rtd2 rtd) + (f (record-type-parent rtd2)))))) + (let loop ([extra* extra*] [index (fx- index (length (rtd-flds #!base-rtd)))]) + (and (not (null? extra*)) + (if (fx= index 0) + (non-result-exp e0 + (make-seq ctxt rtd-expr + (begin + (nanopass-case (Lsrc Expr) (car extra*) + [(ref ,maybe-src ,x) + (when (prelex-referenced x) + (set-prelex-multiply-referenced! x #t)) + (set-prelex-referenced! x #t)] + [else (void)]) + (car extra*)))) + (loop (cdr extra*) (fx- index 1)))))] [else #f]) (nanopass-case (Lsrc Expr) (result-exp/indirect-ref e0) [(record ,rtd1 ,rtd-expr ,e* ...) @@ -4746,10 +4993,18 @@ (begin (bump sc 1) `(record-ref ,rtd ,type ,index ,e0))))])] [(record-set! ,rtd ,type ,index ,[cp0 : e1 'value env sc wd #f moi -> e1] ,[cp0 : e2 'value env sc wd #f moi -> e2]) `(record-set! ,rtd ,type ,index ,e1 ,e2)] - [(record-type ,rtd ,e) (cp0 e ctxt env sc wd name moi)] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (cp0 rtd-expr ctxt env sc wd name moi)] [(record-cd ,rcd ,rtd-expr ,e) (cp0 e ctxt env sc wd name moi)] [(immutable-list (,[cp0 : e* 'value env sc wd #f moi -> e*] ...) ,[cp0 : e ctxt env sc wd name moi -> e]) - `(immutable-list (,e* ...) ,e)] + (context-case ctxt + [(effect) (make-seq ctxt e void-rec)] + [(test) (make-seq ctxt e true-rec)] + [else `(immutable-list (,e* ...) ,e)])] + [(immutable-vector (,[cp0 : e* 'value env sc wd #f moi -> e*] ...) ,[cp0 : e ctxt env sc wd name moi -> e]) + (context-case ctxt + [(effect) (make-seq ctxt e void-rec)] + [(test) (make-seq ctxt e true-rec)] + [else `(immutable-vector (,e* ...) ,e)])] [(moi) (if moi `(quote ,moi) ir)] [(pariah) ir] [(cte-optimization-loc ,box ,[cp0 : e ctxt env sc wd name moi -> e]) @@ -4787,7 +5042,8 @@ [(x ltbc?) (fluid-let ([likely-to-be-compiled? ltbc?] [opending-list '()] - [cp0-info-hashtable (make-weak-eq-hashtable)]) + [cp0-info-hashtable (make-weak-eq-hashtable)] + [cp0-truth-hashtable (make-weak-eq-hashtable)]) (cp0 x 'value empty-env (new-scorer) (new-watchdog) #f #f))])))) ; check to make sure all required handlers were seen, after expansion of the diff --git a/s/cpcheck.ss b/s/cpcheck.ss index 1ed58cf14..f7188529f 100644 --- a/s/cpcheck.ss +++ b/s/cpcheck.ss @@ -202,6 +202,7 @@ ...)))))))] [(cte-optimization-loc ,box ,[e #f -> e]) e] [(immutable-list (,e* ...) ,[e]) e] + [(immutable-vector (,e* ...) ,[e]) e] [(moi) ir] [(pariah) ir] [(profile ,src) ir] diff --git a/s/cpcommonize.ss b/s/cpcommonize.ss index 6fe043102..1a068b741 100644 --- a/s/cpcommonize.ss +++ b/s/cpcommonize.ss @@ -39,7 +39,7 @@ (define-language Lcommonize1 (extends Lsrc) (terminals (+ (fixnum (size)))) - (Expr (e body rtd-expr) + (Expr (e body rtd-expr extra) (- (letrec ([x* e*] ...) body)) (+ (letrec ([x* e* size] ...) body)))) @@ -47,7 +47,7 @@ (terminals (- (fixnum (size))) (+ (binding (b helper-b)))) - (Expr (e body rtd-expr) + (Expr (e body rtd-expr extra) (- (letrec ([x* e* size] ...) body)) (+ (letrec (helper-b* ...) (b* ...) body)))) @@ -117,6 +117,8 @@ (values `(cte-optimization-loc ,box ,e) size)] [(immutable-list (,[e* size*] ...) ,[e size]) (values `(immutable-list (,e* ...) ,e) (apply fx+ size size*))] + [(immutable-vector (,[e* size*] ...) ,[e size]) + (values `(immutable-vector (,e* ...) ,e) (apply fx+ size size*))] [(quote ,d) (values `(quote ,d) 1)] [(ref ,maybe-src ,x) (values `(ref ,maybe-src ,x) 1)] [,pr (values pr 1)] diff --git a/s/cpletrec.ss b/s/cpletrec.ss index 5231fff78..22454e1b6 100644 --- a/s/cpletrec.ss +++ b/s/cpletrec.ss @@ -367,10 +367,12 @@ Handling letrec and letrec* (and (not (fld-mutable? fld)) (eq? (filter-foreign-type (fld-type fld)) 'scheme-object))) (rtd-flds rtd)))))] - [(record-type ,rtd ,e) (Expr e)] + [(record-type ,rtd ,rtd-expr ,maybe-base-rtd (,e* ...) ,extra* ...) (Expr rtd-expr)] [(record-cd ,rcd ,rtd-expr ,e) (Expr e)] [(immutable-list (,[e* pure?*] ...) ,[e pure?]) (values `(immutable-list (,e* ...) ,e) pure?)] + [(immutable-vector (,[e* pure?*] ...) ,[e pure?]) + (values `(immutable-vector (,e* ...) ,e) pure?)] [,pr (values pr #t)] [(moi) (values ir #t)] [(pariah) (values ir #t)] diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index 8f8291d78..40c886dce 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -12170,6 +12170,60 @@ (set! ,%ac0 ,%xp) (jump ,%ref-ret (,%ac0))) ,(f (cdr reg*) (fx+ i 1))))))))))] + [(immutable-vector-procedure) + (let ([Ltop (make-local-label 'ltop)]) + `(lambda ,(make-info "immutable-vector" '(-1)) 0 () + (if ,(%inline eq? ,%ac0 (immediate 0)) + ,(%seq + (set! ,%ac0 (literal ,(make-info-literal #f 'object (vector->immutable-vector '#()) 0))) + (jump ,%ref-ret (,%ac0))) + ,(%seq + (set! ,%ac0 ,(%inline sll ,%ac0 ,(%constant log2-ptr-bytes))) + (set! ,%td ,(%inline + ,%ac0 (immediate ,(fx+ (constant ptr-bytes) (fx- (constant byte-alignment) 1))))) + (set! ,%td ,(%inline logand ,%td (immediate ,(- (constant byte-alignment))))) + (set! ,%xp (alloc ,(make-info-alloc (constant type-typed-object) #f #f) ,%td)) + ,(let ([delta (fx- (constant vector-length-offset) (constant log2-ptr-bytes))]) + (safe-assert (fx>= delta 0)) + (if (fx= delta 0) + (%seq + (set! ,%td ,(%inline logor ,%ac0 (immediate ,(constant type-immutable-vector)))) + (set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td)) + (%seq + (set! ,%td ,(%inline sll ,%ac0 (immediate ,delta))) + ,(if (fx= (constant type-immutable-vector) 0) + `(set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td) + (%seq + (set! ,%td ,(%inline logor ,%td (immediate ,(constant type-immutable-vector)))) + (set! ,(%mref ,%xp ,(constant vector-type-disp)) ,%td)))))) + ,(let f ([reg* arg-registers] [i 0]) + (if (null? reg*) + (%seq + ; point xp to last element of vector + (set! ,%xp ,(%inline + ,%xp ,%ac0)) + ; point ac0 to last stack argument + (set! ,%ac0 + ,(%lea ,%sfp ,%ac0 + (fx* i (fx- (constant ptr-bytes))))) + (label ,Ltop) + (set! ,(%mref ,%xp ,(fx- (constant vector-data-disp) (constant ptr-bytes))) + ,(%mref ,%ac0 0)) + (set! ,%ac0 ,(%inline - ,%ac0 ,(%constant ptr-bytes))) + (if ,(%inline eq? ,%ac0 ,%sfp) + ,(%seq + (set! ,%ac0 ,(%inline - ,%xp (immediate ,(fx* (fx+ i 1) (constant ptr-bytes))))) + (jump ,%ref-ret (,%ac0))) + ,(%seq + (set! ,%xp ,(%inline - ,%xp ,(%constant ptr-bytes))) + (goto ,Ltop)))) + (%seq + (set! ,(%mref ,%xp + ,(fx+ (fx* i (constant ptr-bytes)) (constant vector-data-disp))) + ,(car reg*)) + (if ,(%inline eq? ,%ac0 (immediate ,(fx* (fx+ i 1) (constant ptr-bytes)))) + ,(%seq + (set! ,%ac0 ,%xp) + (jump ,%ref-ret (,%ac0))) + ,(f (cdr reg*) (fx+ i 1))))))))))] [(list-procedure) (let ([Ltop (make-local-label 'ltop)]) `(lambda ,(make-info "list" '(-1)) 0 () diff --git a/s/cprep.ss b/s/cprep.ss index 9b1f4bd30..04cb16d45 100644 --- a/s/cprep.ss +++ b/s/cprep.ss @@ -199,9 +199,10 @@ [(record-ref ,rtd ,type ,index ,[e]) `(record-ref ,rtd ',type ,e ,index)] [(record-set! ,rtd ,type ,index ,[e1] ,[e2]) `(record-set! ,rtd ',type ,e1 ,index ,e2)] [(record ,rtd ,[rtd-expr] ,[e*] ...) `(record ,rtd ,rtd-expr ,@e*)] - [(record-type ,rtd ,[e]) `(record-type ,rtd ,e)] + [(record-type ,rtd ,[rtd-expr] ,maybe-base-rtd (,[e*] ...) ,[extra*] ...) `(record-type ,rtd ,rtd-expr ,maybe-base-rtd ,extra* ...)] [(record-cd ,rcd ,rtd-expr ,[e]) `(record-cd ,rcd ,e)] [(immutable-list (,e* ...) ,[e]) e] + [(immutable-vector (,e* ...) ,[e]) e] [(moi) ''moi] [(pariah) `(pariah (void))] [(profile ,src) `(void)] diff --git a/s/interpret.ss b/s/interpret.ss index dff79777e..2c454e7f0 100644 --- a/s/interpret.ss +++ b/s/interpret.ss @@ -46,7 +46,7 @@ (- ($prelex (x))) (+ (c-var (x)) (list-of-c-var (free)))) - (Expr (e body rtd-expr) + (Expr (e body rtd-expr extra) (- (case-lambda preinfo cl ...) (call preinfo e0 e1 ...) (moi) diff --git a/s/primdata.ss b/s/primdata.ss index 0c5e5b6d4..a5535ee43 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1085,6 +1085,7 @@ (methods [flags]) (module [flags]) (only [flags]) + (open-interface [flags]) (parameterize [flags]) (pariah [flags]) (predicate [flags]) @@ -1401,6 +1402,7 @@ (ieee-environment [sig [() -> (environment)]] [flags unrestricted alloc]) (immutable-string? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-box? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) + (immutable-vector [sig [(ptr ...) -> (immutable-vector)]] [flags unrestricted pure mifoldable alloc cp02]) (immutable-vector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-fxvector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) (immutable-bytevector? [sig [(ptr) -> (boolean)]] [flags pure unrestricted mifoldable discard]) @@ -2077,6 +2079,7 @@ ($intern3 [flags]) ($intern-gensym [flags]) ($interpret-backend [flags]) + ($invalid-ids-error [flags]) ($invalid-ftype-index [flags]) ($invoke-library [flags]) ($invoke-program [flags]) @@ -2175,6 +2178,7 @@ ($profile-show-database [flags]) ($profile-source-data? [flags]) ($ptr-copy! [flags]) + ($query-interface [flags cp02]) ($quotient-remainder [flags]) ($ratio-denominator [flags]) ($ratio-numerator [flags]) @@ -2188,12 +2192,14 @@ ($recompile-importer-path [flags]) ($record [flags cp02 unrestricted alloc]) ; first arg should be an rtd, but we don't check ($record? [flags pure mifoldable discard]) + ($record-accessor/proxy #;[sig [(rtd sub-index) (rtd rtd sub-index) -> (procedure)]] [flags pure alloc cp02]) ($record-equal-procedure [flags discard]) ($record-hash-procedure [flags discard]) + ($record-mutator/proxy #;[sig [(rtd sub-index) (rtd rtd sub-index) -> (procedure)]] [flags pure alloc cp02]) ($record-oops #;[sig [(who sub-ptr rtd) -> (bottom)]] [flags abort-op]) ($record-type-descriptor [flags pure mifoldable discard true]) ($record-type-interfaces #;[sig [(rtd) -> (vector)]] [flags pure discard true]) - ($record-type-field-offsets [flags pure mifoldable discard true]) + ($record-type-field-offsets [flags pure mifoldable discard true cp02]) ($reloc [flags]) ($remake-rtd [flags]) ($report-string [flags]) @@ -2285,6 +2291,7 @@ ($trans-ftype-set! [flags]) ($trans-ftype-sizeof [flags]) ($trans-make-ftype-pointer [flags]) + ($trans-open-interface [flags]) ($trans-record-type-descriptor [flags]) ($trans-record-constructor-descriptor [flags]) ($unbound-object? [flags pure unrestricted mifoldable discard]) diff --git a/s/prims.ss b/s/prims.ss index 3494589fe..e37d535d9 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -29,6 +29,7 @@ (define list ($hand-coded 'list-procedure)) (define $record ($hand-coded '$record-procedure)) (define vector ($hand-coded 'vector-procedure)) +(define immutable-vector ($hand-coded 'immutable-vector-procedure)) (define cons* ($hand-coded 'cons*-procedure)) (define list* ($hand-coded 'list*-procedure)) (define $apply ($hand-coded '$apply-procedure)) diff --git a/s/record-defn.ss b/s/record-defn.ss index 86a23fba7..a916c4b83 100644 --- a/s/record-defn.ss +++ b/s/record-defn.ss @@ -110,18 +110,37 @@ products: - new (not inherited) method names are bound to method-dispatch procedures define-interface: - definition -> (define-interface interface-name ...) - (define-interface (interface-name predicate-name) ...) + definition -> (define-interface ...) + (define-interface ( ) ...) -> (parent ) (methods *) -> ( ) + -> + -> + products: - the specified interface-name NAME is bound to interface information in the expand-time environment - NAME? (or other specified predicate name) is bound to a predicate procedure - new (not inherited) method names are bound to method-dispatch procedures + +open-interface: + definition -> (open-interface ( ...) ) + + -> ( ) + + -> + + -> + -> + +products: + - each specified local method name is bound to the method named by the corresponding + interface-method-name in the specified interface, specialized to the object that + results from evaluating the given object expression. The specialized method takes + the same arguments as the original method except for the leading object argument. |# (define require-nongenerative-clause @@ -143,40 +162,42 @@ products: (define pred (lambda (x) (and (vector? x) (eq? (vector-length x) n)))) (define accessor (lambda (x) (vector-ref x offset))) ...)))]))) - (module ($make-drtinfo $drtinfo? $drtinfo-minfos $drtinfo-vtable-rtd $drtinfo-maybe-rtd $drtinfo-maybe-rcd + (module ($make-drtinfo $drtinfo? $drtinfo-minfos $drtinfo-base-rtd $drtinfo-maybe-ctrtd $drtinfo-maybe-rtd $drtinfo-maybe-rcd $drtinfo-rtd-expr $drtinfo-rcd-expr $drtinfo-interface-names $drtinfo-sealed? $drtinfo-protocol? unwrap-drtinfo) (define-vector-record ($$make-drtinfo $$drtinfo?) $drtinfo-uid - $drtinfo-minfos - $drtinfo-vtable-rtd + $drtinfo-base-rtd + $drtinfo-maybe-ctrtd $drtinfo-maybe-rtd $drtinfo-maybe-rcd $drtinfo-rtd-expr $drtinfo-rcd-expr $drtinfo-interface-names + $drtinfo-minfos $drtinfo-sealed? $drtinfo-protocol?) (module ($make-drtinfo $drtinfo?) (define the-drtinfo-uid '#{drtinfo cb2hekodjsht6om8o8t9g00vq-0}) - (define ($make-drtinfo minfos vtable-rtd maybe-rtd maybe-rcd rtd-expr rcd-expr interface-names sealed? protocol?) - ($$make-drtinfo (datum->syntax #'* the-drtinfo-uid) minfos vtable-rtd maybe-rtd maybe-rcd rtd-expr rcd-expr interface-names sealed? protocol?)) + (define ($make-drtinfo base-rtd maybe-ctrtd maybe-rtd maybe-rcd rtd-expr rcd-expr interface-names minfos sealed? protocol?) + ($$make-drtinfo (datum->syntax #'* the-drtinfo-uid) base-rtd maybe-ctrtd maybe-rtd maybe-rcd rtd-expr rcd-expr interface-names minfos sealed? protocol?)) (define $drtinfo? (lambda (x) (and ($$drtinfo? x) (eq? (syntax->datum ($drtinfo-uid x)) the-drtinfo-uid))))) (define (unwrap-drtinfo x) (syntax-case x () - [#(uid (mimfo ...) vtable-rtd maybe-rtd maybe-rcd rtd-expr rcd-expr (iface-name ...) sealed? protocol?) + [#(uid base-rtd maybe-ctrtd maybe-rtd maybe-rcd rtd-expr rcd-expr (iface-name ...) (minfo ...) sealed? protocol?) #`#(uid - (mimfo ...) - #,(syntax->datum #'vtable-rtd) + #,(syntax->datum #'base-rtd) + #,(syntax->datum #'maybe-ctrtd) #,(syntax->datum #'maybe-rtd) #,(syntax->datum #'maybe-rcd) rtd-expr rcd-expr (iface-name ...) + (minfo ...) #,(syntax->datum #'sealed?) #,(syntax->datum #'protocol?))] [_ x]))) @@ -197,18 +218,27 @@ products: (define (unwrap-diinfo x) (syntax-case x () - [#(uid rtd (mimfo ...)) + [#(uid rtd (minfo ...)) #`#(uid #,(syntax->datum #'rtd) - (mimfo ...))] + (minfo ...))] [_ x]))) - (define-vector-record (make-minfo minfo?) - minfo-mname - minfo-hidden-mname - minfo-arity - minfo-formals - minfo-flat-formals) + (module (make-minfo minfo? + minfo-mname minfo-hidden-mname minfo-arity minfo-formals minfo-flat-formals + unwrap-minfos) + (define-vector-record (make-minfo minfo?) + minfo-mname + minfo-hidden-mname + minfo-arity + minfo-formals + minfo-flat-formals) + (define unwrap-minfos + (lambda (minfos) + ; need list/vector structure, with arity unwrapped + (with-syntax ([(#(mname hidden-name arity formals flat-formals) ...) minfos]) + (with-syntax ([(arity ...) (syntax->datum #'(arity ...))]) + #'(#(mname hidden-name arity formals flat-formals) ...)))))) (define construct-name (lambda (template-identifier . args) @@ -287,18 +317,6 @@ products: (free-id-union (cdr ls1) ls2) (cons (car ls1) (free-id-union (cdr ls1) ls2)))))) - (define distinct-bound-ids? - (lambda (ids) - (define bound-id-member? - (lambda (x list) - (and (not (null? list)) - (or (bound-identifier=? x (car list)) - (bound-id-member? x (cdr list)))))) - (let distinct? ((ids ids)) - (or (null? ids) - (and (not (bound-id-member? (car ids) (cdr ids))) - (distinct? (cdr ids))))))) - (set! $trans-define-interface (lambda (x) (define src x) @@ -377,25 +395,15 @@ products: #'#,($make-diinfo iface-rtd #`(#,@parent-minfos #,@%minfos)))) - ; this could be put out of line by abstracting over iface-rtd - (define (qi ego) - (let ([rtd (#3%record-rtd ego)]) - (let* ([v ($record-type-interfaces rtd)] [n (vector-length v)]) - (let loop ([i 0]) - (and (fx< i n) - (let ([iface (vector-ref v i)]) - (if (#3%record? iface '#,iface-rtd) - iface - (loop (fx+ i 1))))))))) (define (qi! who ego) - (or (and (or opt3 (record? ego)) (qi ego)) + (or (and (or opt3 (record? ego)) (#3%$query-interface '#,iface-rtd ego)) (errorf who "not applicable to ~s" ego))) (define #,pred-name (lambda (x) - (and (record? x) (qi x) #t))) + (and (record? x) (#3%$query-interface '#,iface-rtd x) #t))) (define generic-name (let ([who 'generic-name]) ; can't ref generic-name pattern vble inside ... below - (define method-accessor (csv7:record-field-accessor '#,iface-rtd generic-index)) + (define method-accessor (#3%csv7:record-field-accessor '#,iface-rtd generic-index)) ... (case-lambda [(ego . generic-formals) @@ -416,6 +424,56 @@ products: (construct-name #'name #'name "?") #'(clause ...))])))) + (set! $query-interface + (lambda (iface-rtd ego) + (let ([rtd (#3%record-rtd ego)]) + (let* ([v ($record-type-interfaces rtd)] [n (vector-length v)]) + (let loop ([i 0]) + (and (fx< i n) + (let ([iface (vector-ref v i)]) + (if (#3%record? iface iface-rtd) + iface + (loop (fx+ i 1)))))))))) + + (set! $trans-open-interface + (lambda (x) + (syntax-case x () + [(_ iface-name ([local-mname iface-mname] ...) obj-expr) + (lambda (env) + (let ([local-mname* #'(local-mname ...)]) + (unless ($distinct-bound-ids? local-mname*) + ($invalid-ids-error local-mname* x "local method name")) + (let* ([diinfo (unwrap-diinfo (env #'iface-name))] + [iface-rtd ($diinfo-rtd diinfo)]) + (unless ($diinfo? diinfo) (syntax-error #'iface-name "unrecognized interface")) + (with-syntax ([(((generic-formals generic-flat-formals generic-index) ...) ...) + (let ([x* (build-generic + (unwrap-minfos ($diinfo-minfos diinfo)) + (enumerate (csv7:record-type-field-names iface-rtd)))]) + (map (lambda (iface-mname) + (let loop ([x* x*]) + (when (null? x*) (syntax-error iface-mname "unrecognized interface method name")) + (syntax-case (car x*) () + [(generic-name . stuff) + (if (free-identifier=? #'generic-name iface-mname) + #'stuff + (loop (cdr x*)))]))) + #'(iface-mname ...)))] + [opt3 (= (optimize-level) 3)]) + #`(begin + (define obj obj-expr) + (define iface + (or (and (or opt3 (record? obj)) (#3%$query-interface '#,iface-rtd obj)) + (errorf 'iface-name "not implemented by ~s" obj))) + (define local-mname + (let () + (define method ((#3%csv7:record-field-accessor '#,iface-rtd generic-index) iface)) + ... + (case-lambda + [generic-formals (method obj . generic-flat-formals)] + ...))) + ...)))))]))) + (set! $trans-define-record-type (lambda (x) (define src x) @@ -443,15 +501,11 @@ products: (syntax-error x (format "no inherited ~s method for ~s in" 'mname 'rtname)))))))]) #'(lambda (i formal ...) + ; NB: assuming i is a proper instance. we should verify if we officially + ; allow users to access and call methods directly out of the vtable (fluid-let-syntax ([ego (identifier-syntax i)]) super-definition body))))) - (define unwrap-minfos - (lambda (minfos) - ; need list/vector structure, with arity unwrapped - (with-syntax ([(#(mname hidden-name arity formals flat-formals) ...) minfos]) - (with-syntax ([(arity ...) (syntax->datum #'(arity ...))]) - #'(#(mname hidden-name arity formals flat-formals) ...))))) (define build-interface-vtable (lambda (minfos) (lambda (iface) @@ -511,9 +565,9 @@ products: (list (reverse all-minfos) (reverse mlambdas) (reverse generics) - ; We need to build a list of minfos that will actually be included in the rtd (vtable), + ; build a list of minfos that will actually be included in the rtd/vtable ; i.e., minfos that appear in this record-type and/or any parent record-type (but not in any interface). - ; That list will match up with the vtable offsets. + ; That list will match up with the rtd/vtable offsets. (let f ([possibly-included-minfos all-minfos] [included-minfos '()]) (if (null? possibly-included-minfos) included-minfos @@ -620,13 +674,14 @@ products: (finish #'field-name public? #f #'accessor #f)] [else (err "invalid field specifier")])) (parse-field0 x)) - (define (parse-method x hidden) + (define (parse-method x) (syntax-case x () [(name formals e1 e2 ...) (let-values ([(arity flat-formals) (parse-formals #'formals)]) - (make-method-desc - (make-minfo #'name hidden arity #'formals flat-formals) - #'(let () e1 e2 ...)))])) + (let ([hidden (car (generate-temporaries (list #'name)))]) + (make-method-desc + (make-minfo #'name hidden arity #'formals flat-formals) + #'(let () e1 e2 ...))))])) (define-syntactic-monad Mclause %fields %methods %interface-names %parent %protocol %sealed? %opaque? %uid %prtd-expr %prcd-expr) (define parse-clauses @@ -649,8 +704,7 @@ products: (when (any-set? keys-seen (clause-key methods)) (syntax-error src "record-type definition has multiple methods clauses")) (Mclause parse-clauses - ([%methods (let ([ls #'(method ...)]) - (map parse-method ls (generate-temporaries ls)))]) + ([%methods (map parse-method #'(method ...))]) (set-flags keys-seen (clause-key methods)) (cdr clause*)))] [(implements iname ...) @@ -735,20 +789,25 @@ products: (set-flags keys-seen (clause-key parent-rtd)) (cdr clause*)))] [_ (syntax-error (car clause*) "invalid define-record-type clause")])))) - (define (build-field-defn field-desc) - (let ([field-name (field-desc-name field-desc)] - [accessor-name (field-desc-accessor field-desc)] - [mutator-name (field-desc-mutator field-desc)]) - #`(define-syntax #,field-name - (make-variable-transformer - (lambda (x) - (syntax-case x (set!) - [id (identifier? #'id) #'(#,accessor-name ego)] - [(set! var val) - #,(if mutator-name - #`#'(#,mutator-name ego val) - #`(syntax-error x "invalid assignment of immutable field"))] - [(id e (... ...)) (identifier? #'id) #'((#,accessor-name ego) e (... ...))])))))) + (define (build-field-defn ctrtd) + (lambda (field-desc) + (let ([field-name (field-desc-name field-desc)] + [index (field-desc-index field-desc)]) + #`(module (#,field-name) + (define get ($record-accessor/proxy '#,ctrtd #,index)) + #,@(if (field-desc-mutator field-desc) + #`((define set ($record-mutator/proxy '#,ctrtd #,index))) + '()) + (define-syntax #,field-name + (make-variable-transformer + (lambda (x) + (syntax-case x (set!) + [id (identifier? #'id) #'(get ego)] + [(set! var val) + #,(if (field-desc-mutator field-desc) + #'#'(set ego val) + #'(syntax-error x "invalid assignment of immutable field"))] + [(id e (... ...)) (identifier? #'id) #'((get ego) e (... ...))])))))))) (call-with-values (lambda () (Mclause parse-clauses @@ -778,231 +837,217 @@ products: (unless ($diinfo? diinfo) (syntax-error x "unrecognized interface")) diinfo)) %all-interface-names)] - [%parent-minfos (if %parent (unwrap-minfos ($drtinfo-minfos %parent)) '())]) - (if (and (null? %interfaces) (null? %methods) (null? %parent-minfos)) - ; this just a record definition - ; construct plain record rtd at expand time iff: - ; - uid is not #f or definition is at top level - ; - %parent is #f or its rtd is not #f (implying it is a compile-time plain record), and - ; - %prtd-expr is #f. - (with-syntax ([primlev (if (= (optimize-level) 3) 3 2)] - [((accessor-name accessor-index) ...) - (fold-right (lambda (field-desc ls) - (if (field-desc-public? field-desc) - `((,(field-desc-accessor field-desc) ,(field-desc-index field-desc)) ,@ls) - ls)) - '() %fields)] - [((mutator-name mutator-index) ...) - (fold-right (lambda (field-desc ls) - (if (field-desc-public? field-desc) - `((,(field-desc-mutator field-desc) ,(field-desc-index field-desc)) ,@ls) - ls)) - '() %mutable-fields)]) - (unless (distinct-bound-ids? `(,rtname ,make-name ,pred-name ,@#'(accessor-name ...) ,@#'(mutator-name ...))) - (syntax-error src "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names")) - (if (and (or %uid ($syntax-top-level?)) - (if %parent ($drtinfo-maybe-rtd %parent) (not %prtd-expr))) - (let ([rtd ($make-record-type-descriptor - #!base-rtd - (syntax->datum rtname) - (and %parent ($drtinfo-maybe-rtd %parent)) - (syntax->datum %uid) - %sealed? - %opaque? - (list->vector (map syntax->datum (map field-desc-spec %fields))) - 'define-record-type)]) - (if %protocol - #`(begin - (define rcd - ($make-record-constructor-descriptor '#,rtd + [%parent-minfos (if %parent (unwrap-minfos ($drtinfo-minfos %parent)) '())] + [maybe-rtd + (and (and (null? %interfaces) (null? %methods) (null? %parent-minfos)) + (or %uid ($syntax-top-level?)) + (if %parent ($drtinfo-maybe-rtd %parent) (not %prtd-expr)) + ($make-record-type-descriptor + #!base-rtd + (syntax->datum rtname) + (and %parent ($drtinfo-maybe-rtd %parent)) + (syntax->datum %uid) + %sealed? + %opaque? + (list->vector (map syntax->datum (map field-desc-spec %fields))) + 'define-record-type))] + [maybe-rcd + (and (and maybe-rtd (not %protocol)) + ($make-record-constructor-descriptor maybe-rtd + (and %parent ($drtinfo-maybe-rcd %parent)) + #f 'define-record-type))] + ; ctrtd is used as a proxy in the creation of field accessors and mutators to avoid unnecessary + ; checks accross library boundaries and to avoid creating unresolvable letrec* cycles among the + ; methods, vtable, and field accessors of a record with methods. + [maybe-ctrtd + (or maybe-rtd + (and (if %parent ($drtinfo-maybe-ctrtd %parent) (not %prtd-expr)) + ($make-record-type-descriptor + #!base-rtd + (syntax->datum rtname) + (and %parent ($drtinfo-maybe-ctrtd %parent)) + #f + %sealed? + %opaque? + (list->vector (map syntax->datum (map field-desc-spec %fields))) + 'define-record-type)))]) + (with-syntax ([primlev (if (= (optimize-level) 3) 3 2)] + [((accessor-name accessor-index) ...) + (fold-right (lambda (field-desc ls) + (if (field-desc-public? field-desc) + `((,(field-desc-accessor field-desc) ,(field-desc-index field-desc)) ,@ls) + ls)) + '() %fields)] + [((mutator-name mutator-index) ...) + (fold-right (lambda (field-desc ls) + (if (field-desc-public? field-desc) + `((,(field-desc-mutator field-desc) ,(field-desc-index field-desc)) ,@ls) + ls)) + '() %mutable-fields)] + [rtd (if maybe-rtd #`'#,maybe-rtd #'rtd)] + [rcd (if maybe-rcd #`'#,maybe-rcd #'rcd)]) + (if (and (null? %interfaces) (null? %methods) (null? %parent-minfos)) + ; this just a record definition + ; construct plain record rtd at expand time iff: + ; - uid is not #f or definition is at top level + ; - %parent is #f or its rtd is not #f (implying it is a compile-time plain record), and + ; - %prtd-expr is #f. + (begin + (unless ($distinct-bound-ids? `(,rtname ,make-name ,pred-name ,@#'(accessor-name ...) ,@#'(mutator-name ...))) + (syntax-error src "record-type definition would result in duplicates among the record, constructor, predicate, accessor, and mutator names")) + #`(begin + #,(if maybe-rtd + #'(begin) + #`(define rtd + ($make-record-type-descriptor + #!base-rtd + '#,rtname + #,(if %parent ($drtinfo-rtd-expr %parent) %prtd-expr) + '#,%uid + #,%sealed? + #,%opaque? + '#,(list->vector (map field-desc-spec %fields)) + 'define-record-type))) + #,(if maybe-rcd + #'(begin) + #`(define rcd + ($make-record-constructor-descriptor rtd #,(if %parent ($drtinfo-rcd-expr %parent) %prcd-expr) #,%protocol - 'define-record-type)) - (define-syntax #,rtname - (make-compile-time-value - #'#,($make-drtinfo - #'() - #!base-rtd - rtd - #f - #`'#,rtd - #'rcd - #'() - %sealed? - #t))) - (indirect-export #,rtname rcd) - (define #,make-name (($primitive primlev r6rs:record-constructor) rcd)) - (define #,pred-name (($primitive primlev record-predicate) '#,rtd)) - (define accessor-name (($primitive primlev record-accessor) '#,rtd accessor-index)) ... - (define mutator-name (($primitive primlev record-mutator) '#,rtd mutator-index)) ...) - (let ([rcd ($make-record-constructor-descriptor rtd - (and %parent ($drtinfo-maybe-rcd %parent)) - #f 'define-record-type)]) - #`(begin + 'define-record-type))) + (define-syntax #,rtname + (make-compile-time-value + #'#,($make-drtinfo + #!base-rtd + maybe-ctrtd + maybe-rtd + maybe-rcd + #'rtd + #'rcd + #'() ; interface-names + #'() ; minfos + %sealed? + (and %protocol #t)))) + #,(if maybe-rtd #'(begin) #`(indirect-export #,rtname rtd)) + #,(if maybe-rcd #'(begin) #`(indirect-export #,rtname rcd)) + (define #,make-name (($primitive primlev r6rs:record-constructor) rcd)) + (define #,pred-name (($primitive primlev record-predicate) rtd)) + #,(let ([proxy (if maybe-ctrtd #`'#,maybe-ctrtd #'rtd)]) + (if (= (optimize-level) 3) + #`(begin + (define accessor-name ($record-accessor/proxy #,proxy accessor-index)) ... + (define mutator-name ($record-mutator/proxy #,proxy mutator-index)) ...) + #`(begin + (define accessor-name ($record-accessor/proxy #,proxy rtd accessor-index)) ... + (define mutator-name ($record-mutator/proxy #,proxy rtd mutator-index)) ...))) + )) + (begin + (when %uid + (syntax-error src "a record type with methods or interfaces cannot be nongenerative")) + (unless maybe-ctrtd + (syntax-error src "all ancestors of a record type with methods or interfaces must be specified statically, i.e., with parent rather than parent-rtd")) + (unless ($distinct-bound-ids? (map field-desc-name %fields)) + (syntax-error src "duplicates among field names would cause ambiguity for references within methods")) + (with-syntax ([(iface-name ...) %all-interface-names] + [(field-defn ...) (map (build-field-defn maybe-ctrtd) %fields)] + [((all-minfo ...) ((new-hidden-mname mlambda) ...) (generic ...) (included-minfo ...)) + (process-methods rtname %interfaces %parent-minfos + (map method-desc-minfo %methods) + (map method-desc-body %methods))] + [self (datum->syntax rtname 'self)]) + (let ([%vtable-rtd (let ([parent-vtable-rtd + (or (and %parent ($drtinfo-base-rtd %parent)) + #!base-rtd)]) + (if (null? #'(generic ...)) + parent-vtable-rtd + ($make-record-type-descriptor + #!base-rtd + 'vtable-rtd + parent-vtable-rtd + (gensym "vtable-rtd") + #f + #f + (vector-map + (lambda (x) `(immutable ,(syntax->datum (minfo-mname x)))) + #'#(generic ...)) + 'define-record-type)))]) + (with-syntax ([((generic-name (generic-formals generic-flat-formals generic-index) ...) ...) + (build-generic + #'(generic ...) + (let ([indices (enumerate (csv7:record-type-field-names %vtable-rtd))] [minfos #'(included-minfo ...)]) + (let f ([indices (list-tail indices (- (length indices) (length minfos)))] + [minfos minfos] + [generics #'(generic ...)]) + (if (null? generics) + '() + (if (eq? (car generics) (car minfos)) + (cons (car indices) (f (cdr indices) (cdr minfos) (cdr generics))) + (f (cdr indices) (cdr minfos) generics))))))]) + (unless ($distinct-bound-ids? `(,rtname ,make-name ,pred-name ,@#'(accessor-name ... mutator-name ...) ,@#'(generic-name ...))) + (syntax-error src "record-type definition would result in duplicates among the record-type, constructor, predicate, accessor, mutator, and generic names")) + (with-syntax ([((method-accessor ...) ...) (map generate-temporaries #'((generic-index ...) ...))]) + #`(begin + (module (#,rtname rtd/vtable rcd new-hidden-mname ...) + (define-syntax ego values) + (module (new-hidden-mname ...) + field-defn ... + (define-syntax self (identifier-syntax ego)) + (define new-hidden-mname mlambda) ...) + (define rtd/vtable + (#3%$make-record-type-descriptor/interfaces + '#,%vtable-rtd + '#,rtname + #,(and %parent ($drtinfo-rtd-expr %parent)) + #f + #,%sealed? + #,%opaque? + '#,(list->vector (map field-desc-spec %fields)) + (immutable-vector #,@(map (build-interface-vtable #'(all-minfo ...)) %interfaces)) + 'define-record-type + #,@(map minfo-hidden-mname #'(included-minfo ...)))) + (define rcd + (#3%$make-record-constructor-descriptor rtd/vtable + #,(and %parent ($drtinfo-rcd-expr %parent)) + #,%protocol + 'define-record-type)) (define-syntax #,rtname (make-compile-time-value #'#,($make-drtinfo - #'() - #!base-rtd - rtd - rcd - #`'#,rtd - #`'#,rcd - #'() + %vtable-rtd + maybe-ctrtd + #f + #f + #'rtd/vtable + #'rcd + #'(iface-name ...) + #'(all-minfo ...) %sealed? - #f))) - (define #,make-name (($primitive primlev r6rs:record-constructor) '#,rcd)) - (define #,pred-name (($primitive primlev record-predicate) '#,rtd)) - (define accessor-name (($primitive primlev record-accessor) '#,rtd accessor-index)) ... - (define mutator-name (($primitive primlev record-mutator) '#,rtd mutator-index)) ...)))) - #`(begin - (define rtd - ($make-record-type-descriptor - #!base-rtd - '#,rtname - #,(if %parent ($drtinfo-rtd-expr %parent) %prtd-expr) - '#,%uid - #,%sealed? - #,%opaque? - '#,(list->vector (map field-desc-spec %fields)) - 'define-record-type)) - (define rcd - ($make-record-constructor-descriptor rtd - #,(if %parent ($drtinfo-rcd-expr %parent) %prcd-expr) - #,%protocol - 'define-record-type)) - (define-syntax #,rtname - (make-compile-time-value - #'#,($make-drtinfo - #'() - #!base-rtd - #f - #f - #'rtd - #'rcd - #'() - %sealed? - (and %protocol #t)))) - (indirect-export #,rtname rtd rcd) - (define #,make-name (($primitive primlev r6rs:record-constructor) rcd)) - (define #,pred-name (($primitive primlev record-predicate) rtd)) - (define accessor-name (($primitive primlev record-accessor) rtd accessor-index)) ... - (define mutator-name (($primitive primlev record-mutator) rtd mutator-index)) ...))) - (with-syntax ([primlev (if (= (optimize-level) 3) 3 2)] - [opt3 (= (optimize-level) 3)] - [(iface-name ...) %all-interface-names] - [(accessor-name ...) (map field-desc-accessor %fields)] - [(accessor-index ...) (map field-desc-index %fields)] - [(mutator-name ...) (map field-desc-mutator %mutable-fields)] - [(mutator-index ...) (map field-desc-index %mutable-fields)] - [(field-defn ...) (map build-field-defn %fields)] - [(public-name ...) - (fold-left - (lambda (ls field-desc) - (if (field-desc-public? field-desc) - (cons (field-desc-accessor field-desc) - (let ([mutator (field-desc-mutator field-desc)]) - (if mutator (cons mutator ls) ls))) - ls)) - '() - %fields)] - [((all-minfo ...) ((new-hidden-mname mlambda) ...) (generic ...) (included-minfo ...)) - (process-methods rtname %interfaces %parent-minfos - (map method-desc-minfo %methods) - (map method-desc-body %methods))] - [self (datum->syntax rtname 'self)]) - (when %uid (syntax-error src "a record type with methods or interfaces cannot be nongenerative")) - (unless (distinct-bound-ids? `(,rtname ,make-name ,pred-name ,@#'(public-name ...))) - (syntax-error src "record-type definition would result in duplicates among the record-type, constructor, predicate, accessor, and mutator names")) - (let ([%vtable-rtd (let ([parent-vtable-rtd - (or (and %parent ($drtinfo-vtable-rtd %parent)) - #!base-rtd)]) - (if (null? #'(generic ...)) - parent-vtable-rtd - ($make-record-type-descriptor - #!base-rtd - 'vtable-rtd - parent-vtable-rtd - (gensym "vtable-rtd") - #f - #f - (vector-map - (lambda (x) `(immutable ,(syntax->datum (minfo-mname x)))) - #'#(generic ...)) - 'define-record-type)))]) - (with-syntax ([((generic-name (generic-formals generic-flat-formals generic-index) ...) ...) - (build-generic - #'(generic ...) - (let ([indices (enumerate (csv7:record-type-field-names %vtable-rtd))] [minfos #'(included-minfo ...)]) - (let f ([indices (list-tail indices (- (length indices) (length minfos)))] - [minfos minfos] - [generics #'(generic ...)]) - (if (null? generics) - '() - (if (eq? (car generics) (car minfos)) - (cons (car indices) (f (cdr indices) (cdr minfos) (cdr generics))) - (f (cdr indices) (cdr minfos) generics))))))]) - (with-syntax ([((method-accessor ...) ...) (map generate-temporaries #'((generic-index ...) ...))]) - (unless (distinct-bound-ids? (map field-desc-name %fields)) - (syntax-error src "duplicates among field names would cause ambiguity for references within methods")) - #`(begin - (define protocol #,%protocol) ; should be scoped where it can't see fields, etc. - (module (#,rtname vtable rcd accessors-and-mutators new-hidden-mname ...) - (define-syntax ego values) - field-defn ... - (module (new-hidden-mname ...) - (define-syntax self (identifier-syntax ego)) - (define new-hidden-mname mlambda) ...) - (define vtable - ($make-record-type-descriptor/interfaces - '#,%vtable-rtd - '#,rtname - #,(if %parent ($drtinfo-rtd-expr %parent) %prtd-expr) - #f - #,%sealed? - #,%opaque? - '#,(list->vector (map field-desc-spec %fields)) - (vector #,@(map (build-interface-vtable #'(all-minfo ...)) %interfaces)) - 'define-record-type - #,@(map minfo-hidden-mname #'(included-minfo ...)))) - (module accessors-and-mutators (accessor-name ... mutator-name ...) - (define accessor-name (($primitive primlev record-accessor) vtable accessor-index)) ... - (define mutator-name (($primitive primlev record-mutator) vtable mutator-index)) ...) - (import accessors-and-mutators) - (define rcd - ($make-record-constructor-descriptor vtable - #,(if %parent ($drtinfo-rcd-expr %parent) %prcd-expr) - protocol - 'define-record-type)) - (define-syntax #,rtname - (make-compile-time-value - #'#,($make-drtinfo - #'(all-minfo ...) - %vtable-rtd - #f - #f - #'vtable - #'rcd - #'(iface-name ...) - %sealed? - (and %protocol #t)))) - (indirect-export #,rtname vtable rcd new-hidden-mname ...)) - (define #,make-name (($primitive primlev r6rs:record-constructor) rcd)) - (define #,pred-name (($primitive primlev record-predicate) vtable)) - (define public-name (let () (import accessors-and-mutators) public-name)) ... - (define generic-name - (let ([who 'generic-name]) ; can't ref generic-name pattern vble inside ... below - (define method-accessor (csv7:record-field-accessor '#,%vtable-rtd generic-index)) - ... - (case-lambda - [(ego . generic-formals) - (unless (or opt3 - (and (#3%record? ego vtable) - (#3%record? (#3%record-rtd ego) '#,%vtable-rtd))) - (errorf who "not applicable to ~s" ego)) - ((method-accessor (#3%record-rtd ego)) ego . generic-flat-formals)] - ...))) - ...)))))))))) + (and %protocol #t)))) + (indirect-export #,rtname rtd/vtable rcd new-hidden-mname ...)) + (define #,make-name (($primitive primlev r6rs:record-constructor) rcd)) + (define #,pred-name (($primitive primlev record-predicate) rtd/vtable)) + #,(let ([proxy (if maybe-ctrtd #`'#,maybe-ctrtd #'rtd/vtable)]) + (if (= (optimize-level) 3) + #`(begin + (define accessor-name ($record-accessor/proxy #,proxy accessor-index)) ... + (define mutator-name ($record-mutator/proxy #,proxy mutator-index)) ...) + #`(begin + (define accessor-name ($record-accessor/proxy #,proxy rtd/vtable accessor-index)) ... + (define mutator-name ($record-mutator/proxy #,proxy rtd/vtable mutator-index)) ...))) + (define generic-name + (let ([who 'generic-name]) ; can't ref generic-name pattern vble inside ... below + (define method-accessor (#3%csv7:record-field-accessor '#,%vtable-rtd generic-index)) + ... + (case-lambda + [(ego . generic-formals) + #,@(if (= (optimize-level) 3) + #'() + #`((unless (and (#3%record? ego rtd/vtable) + (#3%record? (#3%record-rtd ego) '#,%vtable-rtd)) + (errorf who "not applicable to ~s" ego)))) + ((method-accessor (#3%record-rtd ego)) ego . generic-flat-formals)] + ...))) + ...)))))))))))) (syntax-case x () [(_ name clause ...) (identifier? #'name) @@ -1243,6 +1288,7 @@ products: (define-syntax sealed (lambda (x) (syntax-error x "misplaced aux keyword"))) (define-syntax define-interface (lambda (x) ($trans-define-interface x))) +(define-syntax open-interface (lambda (x) ($trans-open-interface x))) (define-syntax define-record-type (lambda (x) ($trans-define-record-type x))) (define-syntax type-descriptor (lambda (x) ($trans-record-type-descriptor x "type-descriptor"))) (define-syntax record-type-descriptor (lambda (x) ($trans-record-type-descriptor x "record-type-descriptor"))) diff --git a/s/record.ss b/s/record.ss index 53b5b873b..e07d5b82e 100644 --- a/s/record.ss +++ b/s/record.ss @@ -432,10 +432,7 @@ ; comparison faster and prevents unwanted machine-dependent ; matches like int and integer-32. it also prevents ; ptr and scheme-object from matching---c'est la vie. - (eq? (fld-type fld1) (fld-type fld2)) - ; following is paranoid; overall size - ; check should suffice - #;(= (fld-byte fld1) (fld-byte fld2))))) + (eq? (fld-type fld1) (fld-type fld2))))) (and (= (length flds1) (length flds2)) (andmap same-field? flds1 flds2)))) (let () @@ -723,55 +720,85 @@ (let () (define (rfa who rtd fld) - (let ((record-err (lambda (x) ($record-oops #f x rtd))) - (offset (fld-byte fld)) - (ty (fld-type fld))) - (define-syntax ref - (syntax-rules () - [(_ type bytes pred) - (rec accessor - (lambda (x) - (unless (record? x rtd) (record-err x)) - (#3%$object-ref 'type x offset)))])) - (record-datatype cases (filter-foreign-type ty) ref - ($oops who "unrecognized type ~s" ty)))) + (let ([offset (fld-byte fld)] [ty (fld-type fld)]) + (if rtd + (let ([record-err (lambda (x rtd) ($record-oops #f x rtd))]) + (define-syntax ref + (syntax-rules () + [(_ type bytes pred) + (rec accessor + (lambda (x) + (unless (record? x rtd) (record-err x rtd)) + (#3%$object-ref 'type x offset)))])) + (record-datatype cases (filter-foreign-type ty) ref + ($oops who "unrecognized type ~s" ty))) + (let () + (define-syntax ref + (syntax-rules () + [(_ type bytes pred) + (rec accessor + (lambda (x) + (#3%$object-ref 'type x offset)))])) + (record-datatype cases (filter-foreign-type ty) ref + ($oops who "unrecognized type ~s" ty)))))) (set-who! #(csv7: record-field-accessor) (lambda (rtd field-spec) (rfa who rtd (find-fld who rtd field-spec)))) (set-who! record-accessor (lambda (rtd field-spec) - (rfa who rtd (r6rs:find-fld who rtd field-spec))))) + (rfa who rtd (r6rs:find-fld who rtd field-spec)))) + (set-who! $record-accessor/proxy + (case-lambda + [(proxy field-spec) + (rfa who #f (r6rs:find-fld who proxy field-spec))] + [(proxy rtd field-spec) + (rfa who rtd (r6rs:find-fld who proxy field-spec))]))) (let () - (define (rfm who rtd fld field-spec) + (define (rfm who proxy rtd fld field-spec) (if (fld-mutable? fld) - (let ((record-err (lambda (x t) ($record-oops #f x t))) - (value-err (lambda (x t) ($oops #f "invalid value ~s for foreign type ~s" x t))) - (offset (fld-byte fld)) - (ty (fld-type fld))) - (define-syntax set - (syntax-rules (scheme-object) - [(_ scheme-object bytes pred) - (rec mutator - (lambda (x v) - (unless (record? x rtd) (record-err x rtd)) - (#3%$object-set! 'scheme-object x offset v)))] - [(_ type bytes pred) - (rec mutator - (lambda (x v) - (unless (record? x rtd) (record-err x rtd)) - (unless (pred v) (value-err v ty)) - (#3%$object-set! 'type x offset v)))])) - (record-datatype cases (filter-foreign-type ty) set - ($oops who "unrecognized type ~s" ty))) + (let ([offset (fld-byte fld)] [ty (fld-type fld)]) + (if rtd + (let ([record-err (lambda (x rtd) ($record-oops #f x rtd))] + [value-err (lambda (x ty) ($oops #f "invalid value ~s for foreign type ~s" x ty))]) + (define-syntax set + (syntax-rules (scheme-object) + [(_ scheme-object bytes pred) + (rec mutator + (lambda (x v) + (unless (record? x rtd) (record-err x rtd)) + (#3%$object-set! 'scheme-object x offset v)))] + [(_ type bytes pred) + (rec mutator + (lambda (x v) + (unless (record? x rtd) (record-err x rtd)) + (unless (pred v) (value-err v ty)) + (#3%$object-set! 'type x offset v)))])) + (record-datatype cases (filter-foreign-type ty) set + ($oops who "unrecognized type ~s" ty))) + (let () + (define-syntax set + (syntax-rules () + [(_ type bytes pred) + (rec mutator + (lambda (x v) + (#3%$object-set! 'type x offset v)))])) + (record-datatype cases (filter-foreign-type ty) set + ($oops who "unrecognized type ~s" ty))))) ($oops who "field ~s of ~s is immutable" - field-spec rtd))) + field-spec proxy))) (set-who! #(csv7: record-field-mutator) (lambda (rtd field-spec) - (rfm who rtd (find-fld who rtd field-spec) field-spec))) + (rfm who rtd rtd (find-fld who rtd field-spec) field-spec))) (set-who! record-mutator (lambda (rtd field-spec) - (rfm who rtd (r6rs:find-fld who rtd field-spec) field-spec)))) + (rfm who rtd rtd (r6rs:find-fld who rtd field-spec) field-spec))) + (set-who! $record-mutator/proxy + (case-lambda + [(proxy field-spec) + (rfm who proxy #f (r6rs:find-fld who proxy field-spec) field-spec)] + [(proxy rtd field-spec) + (rfm who proxy rtd (r6rs:find-fld who proxy field-spec) field-spec)]))) (set-who! #(csv7: record-field-accessible?) ; if this is ever made to do anything reasonable, revisit handlers in diff --git a/s/syntax.ss b/s/syntax.ss index 3af07d958..7cb45d853 100644 --- a/s/syntax.ss +++ b/s/syntax.ss @@ -7229,38 +7229,34 @@ (lambda (x) (strip x empty-wrap))) -(let () - (set-who! generate-temporaries - (lambda (x) - (define push-outer - (lambda (x) - (if (syntax-object? x) - (syntax-case x () - [() '()] - [(x . r) #'(x . r)] - [else x]) - x))) - (define (gen-temp x) - (let ([x (syntax->datum x)]) - (let ([x (if (symbol? x) (symbol->string x) x)]) - (wrap (if (string? x) (gensym x) (gensym)) top-wrap)))) - (let f ([fast x] [slow x]) - (let ([fast (push-outer fast)]) - (cond - [(null? fast) '()] - [(pair? fast) - (cons (gen-temp (car fast)) - (let ([fast (push-outer (cdr fast))]) - (cond - [(null? fast) '()] - [(pair? fast) - (cons (gen-temp (car fast)) - (let ([slow (push-outer slow)]) - (if (eq? fast slow) - ($oops who "cyclic list structure ~s" x) - (f (cdr fast) (cdr slow)))))] - [else ($oops who "improper list structure ~s" x)])))] - [else ($oops who "improper list structure ~s" x)])))))) +(set-who! generate-temporaries + (lambda (x) + (define strip-outer + (lambda (x) + (cond + [(syntax-object? x) (strip-outer (syntax-object-expression x))] + [(annotation? x) (annotation-stripped x)] + [else x]))) + (define (gen-temp x) + (let ([x (if (id? x) (symbol->string (id-sym-name x)) (and (string? x) #f))]) + (wrap (if x (gensym x) (gensym)) top-wrap))) + (let f ([fast x] [slow x]) + (let ([fast (strip-outer fast)]) + (cond + [(null? fast) '()] + [(pair? fast) + (cons (gen-temp (car fast)) + (let ([fast (strip-outer (cdr fast))]) + (cond + [(null? fast) '()] + [(pair? fast) + (cons (gen-temp (car fast)) + (let ([slow (strip-outer slow)]) + (if (eq? fast slow) + ($oops who "cyclic list structure ~s" x) + (f (cdr fast) (cdr slow)))))] + [else ($oops who "improper list structure ~s" x)])))] + [else ($oops who "improper list structure ~s" x)]))))) (set-who! free-identifier=? (lambda (x y) @@ -7284,6 +7280,10 @@ (lambda (ids) (distinct-bound-ids? ids))) +(set! $invalid-ids-error + (lambda (ids exp class) + (invalid-ids-error ids exp class))) + (set-who! make-variable-transformer (lambda (proc) (unless (procedure? proc) ($oops who "~s is not a procedure" proc)) @@ -8259,7 +8259,7 @@ #,(if (or (= (optimize-level) 3) (identifier? #'formals)) #'(lambda formals (vector ffml ...)) #`(case-lambda - [formals (vector ffml ...)] + [formals (immutable-vector ffml ...)] [args #,($make-source-oops #'define-values "incorrect number of values from rhs" #'expr)])))))