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

make procedure-arity-mask reliable for record constructors

Browse Source 
When a record-type constructor is formed dynamically,
and when it had more than 6 arguments, use a wrapper
to explicitly set the constructor's arity.

Relevant to racket/racket#2390

original commit: 0a8d335b4f479681dc6dcb5e67126aa3a97357c3
This commit is contained in:
Matthew Flatt 2018-11-19 19:53:22 -07:00
parent 31b7c8fd7a
commit f635d5da42
1 changed files with 14 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
s/record.ss
View File

@ -826,10 +826,12 @@
[(5) (nlambda 5)] [(5) (nlambda 5)]
[(6) (nlambda 6)] [(6) (nlambda 6)]
[else (rec constructor [else (rec constructor
($make-arity-wrapper-procedure
(lambda xr (lambda xr
(unless (fx= (length xr) nflds) (unless (fx= (length xr) nflds)
($oops #f "incorrect number of arguments to ~s" constructor)) ($oops #f "incorrect number of arguments to ~s" constructor))
(apply $record rtd xr)))])) (apply $record rtd xr))
(ash 1 nflds)))]))
(let* ([args (make-record-call-args flds (rtd-size rtd) (let* ([args (make-record-call-args flds (rtd-size rtd)
(map (lambda (x) 0) flds))] (map (lambda (x) 0) flds))]
[nargs (length args)] [nargs (length args)]
@ -923,12 +925,14 @@
[else #f])] [else #f])]
[else #f])]) [else #f])])
(rec constructor (rec constructor
($make-arity-wrapper-procedure
(lambda xr (lambda xr
(unless (fx= (length xr) nflds) (unless (fx= (length xr) nflds)
($oops #f "incorrect number of arguments to ~s" constructor)) ($oops #f "incorrect number of arguments to ~s" constructor))
(let ([x (apply $record rtd args)]) (let ([x (apply $record rtd args)])
(for-each (lambda (setter v) (setter x v)) setters xr) (for-each (lambda (setter v) (setter x v)) setters xr)
x))))))))) x))
(ash 1 nflds)))))))))
(define ($rcd->record-constructor rcd) (define ($rcd->record-constructor rcd)
(let ([rtd (rcd-rtd rcd)] [protocol (rcd-protocol rcd)]) (let ([rtd (rcd-rtd rcd)] [protocol (rcd-protocol rcd)])