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

cs: fix procedure-name problems

Browse Source
This commit is contained in:
Matthew Flatt 2018-10-13 16:42:43 -04:00
parent 2166c56179
commit 7ecb663a6f
2 changed files with 48 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/racket-test-core/tests/racket/procs.rktl
View File

@ -57,7 +57,8 @@
(define f1:+ (make-keyword-procedure (define f1:+ (make-keyword-procedure
(lambda (kws kw-args x) (lambda (kws kw-args x)
(cons x kw-args)) (cons x kw-args))
(lambda (x) (list x)))) (let ([f1:+ (lambda (x) (list x))])
f1:+)))
(define f1:+/drop (make-keyword-procedure (define f1:+/drop (make-keyword-procedure
(lambda (kws kw-args x) (lambda (kws kw-args x)
kw-args) kw-args)

76
racket/src/cs/rumble/procedure.ss
View File

@ -140,6 +140,11 @@
(cond (cond
[(procedure? v) (object-name v)] [(procedure? v) (object-name v)]
[else (struct-object-name f)]))] [else (struct-object-name f)]))]
[(eq? v 'unsafe)
(extract-procedure-name
(if (chaperone? f)
(unsafe-procedure-chaperone-replace-proc f)
(unsafe-procedure-impersonator-replace-proc f)))]
[else (struct-object-name f)]))] [else (struct-object-name f)]))]
[else #f])) [else #f]))
@ -253,7 +258,7 @@
(if (not (bitwise-bit-set? m 0)) (if (not (bitwise-bit-set? m 0))
(mask->arity (bitwise-arithmetic-shift-right m 1)) (mask->arity (bitwise-arithmetic-shift-right m 1))
(mask->arity m))) (mask->arity m)))
(cdr args))] (if (null? args) '() (cdr args)))]
[else [else
(chez:apply raise-arity-error f (procedure-arity f) args)]))) (chez:apply raise-arity-error f (procedure-arity f) args)])))
@ -320,29 +325,41 @@
[(proc mask) (procedure-reduce-arity-mask proc mask #f)])) [(proc mask) (procedure-reduce-arity-mask proc mask #f)]))
(define (do-procedure-reduce-arity-mask proc mask name) (define (do-procedure-reduce-arity-mask proc mask name)
(case mask (cond
[(1) (make-arity-wrapper-procedure (if (#%procedure? proc) [(and (arity-wrapper-procedure? proc)
(lambda () (proc)) (#%vector? (arity-wrapper-procedure-data proc)))
(lambda () (|#%app| proc))) (let ([v (arity-wrapper-procedure-data proc)])
mask (do-procedure-reduce-arity-mask (#%vector-ref v 1)
name)] mask
[(2) (make-arity-wrapper-procedure (if (#%procedure? proc) (or name (#%vector-ref v 0))))]
(lambda (x) (proc x)) [(reduced-arity-procedure? proc)
(lambda (x) (|#%app| proc x))) (do-procedure-reduce-arity-mask (reduced-arity-procedure-proc proc)
mask mask
name)] (or name (reduced-arity-procedure-name proc)))]
[(4) (make-arity-wrapper-procedure (if (#%procedure? proc) [else
(lambda (x y) (proc x y)) (case mask
(lambda (x y) (|#%app| proc x y))) [(1) (make-arity-wrapper-procedure (if (#%procedure? proc)
mask (lambda () (proc))
name)] (lambda () (|#%app| proc)))
[(8) (make-arity-wrapper-procedure (if (#%procedure? proc) mask
(lambda (x y z) (proc x y z)) (vector name proc))]
(lambda (x y z) (|#%app| proc x y z))) [(2) (make-arity-wrapper-procedure (if (#%procedure? proc)
mask (lambda (x) (proc x))
name)] (lambda (x) (|#%app| proc x)))
[else mask
(make-reduced-arity-procedure proc mask name)])) (vector name proc))]
[(4) (make-arity-wrapper-procedure (if (#%procedure? proc)
(lambda (x y) (proc x y))
(lambda (x y) (|#%app| proc x y)))
mask
(vector name proc))]
[(8) (make-arity-wrapper-procedure (if (#%procedure? proc)
(lambda (x y z) (proc x y z))
(lambda (x y z) (|#%app| proc x y z)))
mask
(vector name proc))]
[else
(make-reduced-arity-procedure proc mask name)])]))
;; ---------------------------------------- ;; ----------------------------------------
@ -389,9 +406,11 @@
(define (extract-jit-procedure-name p) (define (extract-jit-procedure-name p)
(let ([name (arity-wrapper-procedure-data p)]) (let ([name (arity-wrapper-procedure-data p)])
(if (#%box? name) (cond
(#%unbox name) [(#%box? name) (#%unbox name)]
name))) [(#%vector? name) (or (#%vector-ref name 0)
(object-name (#%vector-ref name 1)))]
[else name])))
;; ---------------------------------------- ;; ----------------------------------------
@ -818,9 +837,6 @@
(struct-property-set! prop:procedure-arity (struct-property-set! prop:procedure-arity
(record-type-descriptor reduced-arity-procedure) (record-type-descriptor reduced-arity-procedure)
1) 1)
(struct-property-set! prop:object-name
(record-type-descriptor reduced-arity-procedure)
2)
(struct-property-set! prop:procedure (struct-property-set! prop:procedure
(record-type-descriptor method-procedure) (record-type-descriptor method-procedure)