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

cs: fill in procedure-name and srcloc interaction

Browse Source 
Infer procedure names based on source locations, and suppress a
procedure name when it has #<void> for its 'inferred-name property.

Threading this information through the Chez Scheme layer involves a
hack, where a name starting with "[" indicates either "no name" or
"inferred from path".
This commit is contained in:
Matthew Flatt 2019-01-13 08:31:16 -07:00
parent 3b76e44730
commit 6b52f9eedb
6 changed files with 111 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
racket/src/cs/rumble/error.ss
View File

@ -493,7 +493,9 @@
(string->symbol (format "body of ~a" n))))
(let* ([c (#%$continuation-return-code k)]
[n (#%$code-name c)])
n))]
(if (special-procedure-name-string? n)
#f
n)))]
[desc
(let* ([ci (#%$code-info (#%$continuation-return-code k))]
[src (and

17
racket/src/cs/rumble/object-name.ss
View File

@ -40,7 +40,15 @@
[else
(let ([name (#%$code-name (#%$closure-code v))])
(and name
(string->symbol 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))))]
[else
(string->symbol name)])))])]
[(impersonator? v)
(object-name (impersonator-val v))]
[(procedure? v)
@ -63,3 +71,10 @@
(or (hashtable-contains? rtd-props rtd)
(getprop (record-type-uid rtd) 'prefab-key+count #f)))
(object-name (record-rtd v)))))
;; name starting with a square bracket is meant to
;; encode a path or "no name"
(define (special-procedure-name-string? n)
(and (string? n)
(fx> (string-length n) 0)
(char=? #\[ (string-ref n 0))))

16
racket/src/cs/schemify.sls
View File

@ -20,7 +20,11 @@
[correlated? rumble:correlated?]
[correlated-e rumble:correlated-e]
[correlated-property rumble:correlated-property]
[datum->correlated rumble:datum->correlated])
[datum->correlated rumble:datum->correlated]
[correlated-source rumble:correlated-source]
[correlated-line rumble:correlated-line]
[correlated-column rumble:correlated-column]
[correlated-position rumble:correlated-position])
(regexp)
(io))
@ -34,7 +38,11 @@
(hash 'syntax? rumble:correlated?
'syntax-e rumble:correlated-e
'syntax-property rumble:correlated-property
'datum->syntax rumble:datum->correlated)]
'datum->syntax rumble:datum->correlated
'syntax-source rumble:correlated-source
'syntax-line rumble:correlated-line
'syntax-column rumble:correlated-column
'syntax-position rumble:correlated-position)]
[else #f]))
;; For direct access by schemified schemify:
@ -42,6 +50,10 @@
(define syntax-e rumble:correlated-e)
(define syntax-property rumble:correlated-property)
(define datum->syntax rumble:datum->correlated)
(define syntax-source rumble:correlated-source)
(define syntax-line rumble:correlated-line)
(define syntax-column rumble:correlated-column)
(define syntax-position rumble:correlated-position)
(include "include.ss")
(include-generated "schemify.scm")

49
racket/src/schemify/infer-name.rkt Normal file
View File

@ -0,0 +1,49 @@
#lang racket/base
(require "wrap.rkt")
(provide infer-procedure-name)
(define (infer-procedure-name orig-s new-s)
(cond
[(wrap-property orig-s 'inferred-name)
=> (lambda (v)
(if (void? v)
(wrap-property-set (reannotate orig-s new-s)
'inferred-name
;; Hack: "[" means "no name"
'|[|)
new-s))]
[else
(define-values (src line col pos) (wrap-source orig-s))
(define (add-property str)
(wrap-property-set (reannotate orig-s new-s)
'inferred-name
;; Hack: starting with "[" means
;; "derived from path"
(string->symbol (string-append "[" str))))
(cond
[(and (or (path? src) (string? src)) line col)
(add-property
(string-append (source->string src)
":"
(number->string line)
":"
(number->string col)))]
[(and (or (path? src) (string? src)) src pos)
(add-property
(string-append (source->string src)
"::"
(number->string pos)))]
[else new-s])]))
(define (source->string src)
(define str (if (string? src) src (path->string src)))
(define short-str
(cond
[((string-length str) . < . 20) (string-copy str)]
[else (string-append "..." (substring str (- (string-length str) 19)))]))
(for ([i (in-range (string-length short-str))])
(when (char=? #\\ (string-ref short-str i))
(string-set! short-str i #\/)))
short-str)

15
racket/src/schemify/schemify.rkt
View File

@ -17,7 +17,8 @@
"find-known.rkt"
"infer-known.rkt"
"inline.rkt"
"letrec.rkt")
"letrec.rkt"
"infer-name.rkt")
(provide schemify-linklet
schemify-body)
@ -366,11 +367,15 @@
v
(match v
[`(lambda ,formals ,body ...)
`(lambda ,formals ,@(schemify-body body))]
(infer-procedure-name
v
`(lambda ,formals ,@(schemify-body body)))]
[`(case-lambda [,formalss ,bodys ...] ...)
`(case-lambda ,@(for/list ([formals (in-list formalss)]
[body (in-list bodys)])
`[,formals ,@(schemify-body body)]))]
(infer-procedure-name
v
`(case-lambda ,@(for/list ([formals (in-list formalss)]
[body (in-list bodys)])
`[,formals ,@(schemify-body body)])))]
[`(define-values (,struct:s ,make-s ,s? ,acc/muts ...)
(let-values (((,struct: ,make ,?1 ,-ref ,-set!) ,mk))
(values ,struct:2

20
racket/src/schemify/wrap.rkt
View File

@ -7,6 +7,8 @@
wrap-eq? wrap-equal?
in-wrap-list
wrap-property
wrap-property-set
wrap-source
reannotate)
(import-from-primitive-table
@ -14,7 +16,11 @@
[syntax? correlated?]
[syntax-e correlated-e]
[syntax-property correlated-property]
[datum->syntax datum->correlated])
[datum->syntax datum->correlated]
[syntax-source correlated-source]
[syntax-line correlated-line]
[syntax-column correlated-column]
[syntax-position correlated-position])
(define (unwrap v)
(if (correlated? v)
@ -71,6 +77,18 @@
(and (correlated? a)
(correlated-property a key)))
(define (wrap-property-set a key val)
(correlated-property a key val))
(define (wrap-source a)
(cond
[(correlated? a)
(values (correlated-source a)
(correlated-line a)
(correlated-column a)
(correlated-position a))]
[else (values #f #f #f #f)]))
(define (reannotate old-term new-term)
(if (correlated? old-term)
(datum->correlated #f new-term old-term)