cs: encode procedure methodness statically
When a `lambda` form is marked as a method (for arity error reporting) through a property, translate that to a static flag on the procedure, instead of a call to `procedure->method`. The only way we have to attach static information is through the procedure name, so the encoding already in place for "no name" and "path-based name" is extended to support a method flag.
This commit is contained in:
Matthew Flatt
parent
5412a4c5fa
commit
c7059c7c94
|
|
@ -548,9 +548,9 @@
|
|||
(string->symbol (format "body of ~a" n))))
|
||||
(let* ([c (#%$continuation-return-code k)]
|
||||
[n (#%$code-name c)])
|
||||
(if (special-procedure-name-string? n)
|
||||
(if (path-or-empty-procedure-name-string? n)
|
||||
#f
|
||||
n)))]
|
||||
(procedure-name-string->visible-name-string n))))]
|
||||
[desc
|
||||
(let* ([ci (#%$code-info (#%$continuation-return-code k))]
|
||||
[src (and
|
||||
|
|
|
|||
|
|
@ -40,19 +40,8 @@
|
|||
[else
|
||||
(let ([name (#%$code-name (#%$closure-code v))])
|
||||
(and name
|
||||
(cond
|
||||
[(special-procedure-name-string? name)
|
||||
;; "[" is "no name", and any other
|
||||
;; "["-prefixed name is derived from the path
|
||||
(let ([len (string-length name)])
|
||||
(and (fx> len 1)
|
||||
(string->symbol (substring name 1 len))))]
|
||||
[(and (fx> (string-length name) 0)
|
||||
(char=? #\] (string-ref name 0)))
|
||||
;; Strip escape character
|
||||
(string->symbol (substring name 1 (string-length name)))]
|
||||
[else
|
||||
(string->symbol name)])))])]
|
||||
(let ([n (procedure-name-string->visible-name-string name)])
|
||||
(and n (string->symbol n)))))])]
|
||||
[(impersonator? v)
|
||||
(object-name (impersonator-val v))]
|
||||
[(procedure? v)
|
||||
|
|
@ -76,9 +65,45 @@
|
|||
(getprop (record-type-uid rtd) 'prefab-key+count #f)))
|
||||
(object-name (record-rtd v)))))
|
||||
|
||||
;; Since a procedure name is the one way we have to attach static
|
||||
;; information to `lambda` forms, it can encode more than just a name:
|
||||
;; * Starting with "[" means a path-derived name, where that
|
||||
;; distinction is used instack trace.
|
||||
;; * Starting with "]" means that some other starting character
|
||||
;; ws escaped.
|
||||
;; * After "[" or "]", "!" means a method, and "^" means not-a-method.
|
||||
(define (procedure-name-string->visible-name-string n)
|
||||
(cond
|
||||
[(not (string? n)) n]
|
||||
[else
|
||||
(let ([len (string-length n)])
|
||||
(cond
|
||||
[(fx= 0 len) n]
|
||||
[else
|
||||
(let ([strip-prefix
|
||||
(lambda ()
|
||||
(cond
|
||||
[(fx= 1 len) ""]
|
||||
[(char=? #\; (string-ref n 0))
|
||||
(substring n 2 len)]
|
||||
[(char=? #\^ (string-ref n 0))
|
||||
(substring n 2 len)]
|
||||
[else
|
||||
(substring n 1 len)]))])
|
||||
(cond
|
||||
[(char=? #\[ (string-ref n 0))
|
||||
(let ([n (strip-prefix)])
|
||||
;; Empty means no name
|
||||
(if (eqv? "" n)
|
||||
#f
|
||||
n))]
|
||||
[(char=? #\] (string-ref n 0))
|
||||
(strip-prefix)]
|
||||
[else n]))]))]))
|
||||
|
||||
;; name starting with a square bracket is meant to
|
||||
;; encode a path or "no name"
|
||||
(define (special-procedure-name-string? n)
|
||||
(define (path-or-empty-procedure-name-string? n)
|
||||
(and (string? n)
|
||||
(fx> (string-length n) 0)
|
||||
(char=? #\[ (string-ref n 0))))
|
||||
|
|
|
|||
|
|
@ -376,7 +376,7 @@
|
|||
(let ([name (wrapper-procedure-data f)])
|
||||
(and (#%vector? name)
|
||||
(method-wrapper-vector? name)))
|
||||
#f)]
|
||||
(procedure-is-method-by-name? f))]
|
||||
[(record? f)
|
||||
(or (method-arity-error? f)
|
||||
(let ([v (struct-property-ref prop:procedure (record-rtd f) #f)])
|
||||
|
|
@ -391,8 +391,47 @@
|
|||
[else (procedure-is-method? v)])))]
|
||||
[else #f]))
|
||||
|
||||
(define-syntax-rule (|#%method-arity| e)
|
||||
(procedure->method e))
|
||||
(define (procedure-is-method-by-name? proc)
|
||||
(let ([n (#%$code-name (#%$closure-code proc))])
|
||||
(and n
|
||||
(fx>= (string-length n) 2)
|
||||
(or (char=? #\[ (string-ref n 0))
|
||||
(char=? #\] (string-ref n 0)))
|
||||
(char=? #\! (string-ref n 1)))))
|
||||
|
||||
(define-syntax (|#%method-arity| stx)
|
||||
(syntax-case stx (|#%name|)
|
||||
[(_ (|#%name| name e))
|
||||
;; Encode method-arity property in the procedure name; see
|
||||
;; "object-name.ss" for more information about encoding
|
||||
(let ([n (#%symbol->string (#%syntax->datum #'name))])
|
||||
(let ([new-name
|
||||
(#%string->symbol
|
||||
(cond
|
||||
[(= 0 (string-length n))
|
||||
;; "]" indicates encoded, and "!" indicates method
|
||||
"]!"]
|
||||
[(or (char=? #\[ (string-ref n 0))
|
||||
(char=? #\] (string-ref n 0)))
|
||||
;; Path-based, no name, or escaped:
|
||||
(cond
|
||||
[(= 1 (string-length n))
|
||||
;; No name or empty, so change to method
|
||||
(string-append n "!")]
|
||||
[(char=? #\! (string-ref n 1))
|
||||
;; Already marked as a method
|
||||
n]
|
||||
[(char=? #\^ (string-ref n 1))
|
||||
;; Currently marked as "not a method"
|
||||
(string-append (#%substring n 0 1) "!" (#%substring n 2 (string-length n)))]
|
||||
[else
|
||||
;; Currently a path-based name or escaped name
|
||||
(string-append (#%substring n 0 1) "!" (#%substring n 1 (string-length n)))])]
|
||||
[else
|
||||
;; Add an escape so we can mark as a method:
|
||||
(string-append "]!" n)]))])
|
||||
#`(|#%name| #,(#%datum->syntax #'name new-name) e)))]
|
||||
[(_ e) #'(procedure->method e)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -462,13 +501,15 @@
|
|||
(vector (or name (#%vector-ref v 0))
|
||||
(#%vector-ref v 1)
|
||||
'method)]
|
||||
[name (vector name
|
||||
[name (vector (or name (#%vector-ref v 0))
|
||||
(#%vector-ref v 1))]
|
||||
[else v])))]
|
||||
[(#%procedure? proc)
|
||||
(make-arity-wrapper-procedure proc
|
||||
mask
|
||||
(vector name proc))]
|
||||
(if (procedure-is-method-by-name? proc)
|
||||
(vector name proc 'method)
|
||||
(vector name proc)))]
|
||||
[(reduced-arity-procedure? proc)
|
||||
(do-procedure-reduce-arity-mask (reduced-arity-procedure-proc proc)
|
||||
mask
|
||||
|
|
|
|||
|
|
@ -30,11 +30,17 @@
|
|||
(define (add-property str)
|
||||
(wrap-property-set (reannotate orig-s new-s)
|
||||
'inferred-name
|
||||
;; Hack: starting with "[" means
|
||||
;; "derived from path". This distinction
|
||||
;; is used when printing function names
|
||||
;; in a stack trace.
|
||||
(string->symbol (string-append-immutable "[" str))))
|
||||
;; Starting with "[" means "derived from
|
||||
;; path". This distinction is used when
|
||||
;; printing function names in a stack trace.
|
||||
;; Furthermore, "!" or "^" after "[" indicates
|
||||
;; methodness or not, so add an explicit "^"
|
||||
;; if necessary.
|
||||
(let ([prefix (if (or (char=? (string-ref str 0) #\!)
|
||||
(char=? (string-ref str 0) #\^))
|
||||
"[^"
|
||||
"[")])
|
||||
(string->symbol (string-append-immutable prefix str)))))
|
||||
(cond
|
||||
[(and (or (path? src) (string? src)) line col)
|
||||
(add-property
|
||||
|
|
@ -54,7 +60,7 @@
|
|||
;; suppress any other inferred name:
|
||||
(wrap-property-set (reannotate orig-s new-s)
|
||||
'inferred-name
|
||||
;; Hack: "[" means "no name"
|
||||
;; "[" means "no name"
|
||||
'|[|)]
|
||||
[else new-s])]))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user