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

cs & schemfiy: avoid crash with 1 extra argument to make-struct-type

Browse Source
This commit is contained in:
Matthew Flatt 2021-02-12 19:45:08 -07:00
parent ae80c890e9
commit 1f68962d67
3 changed files with 778 additions and 733 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test-core/tests/racket/struct.rktl
View File

@ -1563,6 +1563,27 @@
(struct exn:foo exn () #:constructor-name make-exn:foo)
(test "foo" exn-message (make-exn:foo "foo" (current-continuation-marks))))
;; ----------------------------------------
(err/rt-test
(let ()
;; Should be arity error (as opposed to a crash)
(define-values (struct:y y y? y-z)
(let-values ([(struct:_1 make-_2 ?_3 -ref_4 -set!_5)
(let-values ()
(let-values ()
(make-struct-type 'y #f 1 0 #f
(list)
(current-inspector)
#f '() #f 'y 'extra)))])
(values
struct:_1
make-_2
?_3
(make-struct-field-accessor -ref_4 0 'z))))
5))
;; ----------------------------------------
(report-errs)

63
racket/src/cs/schemified/schemify.scm
View File

@ -7599,6 +7599,7 @@
2
args))))))))
(if (exact-nonnegative-integer? fields_0)
(if (<= (length rest_0) 6)
(let ((prefab-imms_0
(if (begin-unsafe
(let ((app_0 (unwrap '())))
@ -7672,9 +7673,11 @@
(let ((a_0 (cdr p_0)))
(let ((p_1 (unwrap a_0)))
(if (pair? p_1)
(if (let ((a_1 (car p_1)))
(if (let ((a_1
(car p_1)))
(let ((p_2
(unwrap a_1)))
(unwrap
a_1)))
(if (pair? p_2)
(if (let ((a_2
(car
@ -7726,11 +7729,13 @@
(unwrap a_1)))
(if (pair? p_2)
(let ((a_2
(cdr p_2)))
(cdr
p_2)))
(let ((p_3
(unwrap
a_2)))
(if (pair? p_3)
(if (pair?
p_3)
(if (let ((a_3
(car
p_3)))
@ -7785,13 +7790,15 @@
(let ((d_1
(cdr (unwrap d_0))))
(let ((d_2
(cdr (unwrap d_1))))
(cdr
(unwrap d_1))))
(let ((a_0
(car
(unwrap d_2))))
(let ((d_3
(cdr
(unwrap a_0))))
(unwrap
a_0))))
(let ((a_1
(car
(unwrap
@ -7854,9 +7861,11 @@
#f)))
#f)
#f)))
(let ((a_1 (cdr p_1)))
(let ((a_1
(cdr p_1)))
(let ((p_2
(unwrap a_1)))
(unwrap
a_1)))
(if (pair? p_2)
(let ((a_2
(cdr
@ -7880,11 +7889,13 @@
(let ((p_1 (unwrap a_0)))
(if (pair? p_1)
(if (let ((a_1
(car p_1)))
(car
p_1)))
(let ((p_2
(unwrap
a_1)))
(if (pair? p_2)
(if (pair?
p_2)
(if (let ((a_2
(car
p_2)))
@ -8084,7 +8095,8 @@
(call-with-values
(lambda ()
(let ((d_0
(cdr (unwrap v_1))))
(cdr
(unwrap v_1))))
(call-with-values
(lambda ()
(begin
@ -8216,7 +8228,8 @@
(lambda (result_0
lst_0)
(begin
(if (pair? lst_0)
(if (pair?
lst_0)
(let ((prop_0
(unsafe-car
lst_0)))
@ -8298,7 +8311,8 @@
v_1
imms_0)
#f))
(if (known-procedure? k_0)
(if (known-procedure?
k_0)
imms_0
#f))))
#f)))))))))
@ -8310,7 +8324,9 @@
(if (eq? prefab-imms_1 'non-prefab)
(if (begin-unsafe
(let ((app_0 (unwrap '())))
(eq? app_0 (unwrap rest_0))))
(eq?
app_0
(unwrap rest_0))))
'()
(if (let ((p_0 (unwrap rest_0)))
(if (pair? p_0)
@ -8323,14 +8339,17 @@
(unwrap a_0)))))
#f))
'()
(if (let ((p_0 (unwrap rest_0)))
(if (let ((p_0
(unwrap rest_0)))
(if (pair? p_0)
(let ((a_0 (cdr p_0)))
(let ((p_1
(unwrap a_0)))
(unwrap
a_0)))
(if (pair? p_1)
(let ((a_1
(cdr p_1)))
(cdr
p_1)))
(begin-unsafe
(let ((app_0
(unwrap
@ -8345,7 +8364,8 @@
(if (let ((p_0
(unwrap rest_0)))
(if (pair? p_0)
(let ((a_0 (cdr p_0)))
(let ((a_0
(cdr p_0)))
(let ((p_1
(unwrap
a_0)))
@ -8390,14 +8410,16 @@
proc-spec_0
'()))
(if (let ((p_0
(unwrap rest_0)))
(unwrap
rest_0)))
(if (pair? p_0)
(let ((a_0
(cdr p_0)))
(let ((p_1
(unwrap
a_0)))
(if (pair? p_1)
(if (pair?
p_1)
(let ((a_1
(cdr
p_1)))
@ -8567,6 +8589,7 @@
#f))))))))
#f)
#f)
#f)
#f)))))
(args (raise-binding-result-arity-error 4 args))))
(if (if (eq? 'let-values hd_0)

1
racket/src/schemify/struct-type-info.rkt
View File

@ -39,6 +39,7 @@
(known-struct-type?
(find-known u-parent prim-knowns knowns imports mutated)))
(exact-nonnegative-integer? fields)
((length rest) . <= . 6)
(let ([prefab-imms
;; The inspector argument needs to be missing or duplicable,
;; and if it's not known to produce a value other than 'prefab,