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

Get rid of pseudo-syntax.

Browse Source
This commit is contained in:
Vincent St-Amour 2011-07-29 18:31:10 -04:00
parent 4164b04324
commit 5f4c577d5b
3 changed files with 19 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
collects/typed-scheme/optimizer/logging.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(require racket/set racket/string racket/match racket/list racket/serialize
unstable/syntax unstable/logging syntax/to-string
(require racket/set racket/string racket/match racket/list
unstable/syntax unstable/logging
"../utils/tc-utils.rkt")
(provide log-optimization log-missed-optimization
@ -10,8 +10,7 @@
with-intercepted-tr-logging with-tr-logging-to-port
(struct-out log-entry)
(struct-out opt-log-entry)
(struct-out missed-opt-log-entry)
(struct-out pseudo-syntax))
(struct-out missed-opt-log-entry))
;;--------------------------------------------------------------------
@ -27,29 +26,11 @@
(define log-so-far '())
;; msg is for consumption by the DrRacket tool
;; mutability is there only to replace syntax with pseudo-syntax before
;; printing at the end
(struct log-entry (kind msg (stx #:mutable) (located-stx #:mutable) pos)
#:prefab)
(struct log-entry (kind msg stx located-stx pos) #:prefab)
;; for optimizations only (not missed optimizations, those are below)
(struct opt-log-entry log-entry () #:prefab)
;; syntax objects are not serializable.
;; this is a prefab struct that holds the information we need from syntax
;; objects while still being serializable
;; rep : string (result of syntax->string)
(struct pseudo-syntax (rep line column position span
source-directory source-file-name)
#:prefab)
(define (syntax->pseudo-syntax stx)
(pseudo-syntax (syntax->string #`(#,stx)) ; takes a list of stxs
(syntax-line stx) (syntax-column stx)
(syntax-position stx) (syntax-span stx)
(serialize (syntax-source-directory stx))
(serialize (syntax-source-file-name stx))))
(define (log-optimization kind msg stx)
(let ([new-entry
(opt-log-entry kind msg
@ -72,7 +53,7 @@
;; that got merged into this miss. we need to keep them around to detect
;; future potential merges.
(struct missed-opt-log-entry log-entry
((irritants #:mutable) (merged-irritants #:mutable) badness)
(irritants merged-irritants badness)
#:prefab)
(define missed-optimizations-log '())
@ -233,18 +214,8 @@
(define logger (current-logger))
(add-missed-opts-to-log)
(for ([x (sort-log)])
(define out (format-log-entry x))
(set-log-entry-stx! x (syntax->pseudo-syntax (log-entry-stx x)))
(set-log-entry-located-stx! x (syntax->pseudo-syntax
(log-entry-located-stx x)))
(when (missed-opt-log-entry? x)
(set-missed-opt-log-entry-irritants!
x (map syntax->pseudo-syntax
(missed-opt-log-entry-irritants x)))
(set-missed-opt-log-entry-merged-irritants!
x (map syntax->pseudo-syntax
(missed-opt-log-entry-merged-irritants x))))
(log-message logger 'warning out
(log-message logger 'warning
(format-log-entry x)
(cons optimization-log-key x))))
(define (clear-log)

19
collects/typed-scheme/optimizer/tool/display.rkt
View File

@ -1,10 +1,9 @@
#lang racket/base
(require racket/string racket/class racket/gui/base racket/match racket/port
framework
framework syntax/to-string
"report.rkt"
unstable/sequence unstable/pretty
typed-scheme/optimizer/logging) ; for pseudo-syntax utils
unstable/sequence unstable/pretty)
(provide popup-callback make-color-table)
@ -33,9 +32,7 @@
;; the location, the syntax and the message are in separate editors
(define location-text (new text:basic% [auto-wrap #t]))
(define location (format "~a:~a:"
(pseudo-syntax-line stx)
(pseudo-syntax-column stx)))
(define location (format "~a:~a:" (syntax-line stx) (syntax-column stx)))
(send location-text insert-port (open-input-string location))
(send location-text lock #t)
;; add to the main editor
@ -46,14 +43,14 @@
(define syntax-text (new text:basic%))
;; typeset the syntax as code
(send syntax-text change-style tt-style-delta)
(send syntax-text insert-port (open-input-string (pseudo-syntax-rep stx)))
(send syntax-text insert-port
(open-input-string (syntax->string #`(#,stx)))) ; takes a list of stxs
;; circle irritants, if necessary
(when (missed-opt-report-entry? s)
(for ([i (in-list (missed-opt-report-entry-irritants s))]
#:when (pseudo-syntax-position i))
(define start (- (pseudo-syntax-position i)
(pseudo-syntax-position stx)))
(define len (pseudo-syntax-span i))
#:when (syntax-position i))
(define start (- (syntax-position i) (syntax-position stx)))
(define len (syntax-span i))
;; will be off if there are comments inside an irritant (span will be
;; higher than what's actually displayed), but unless we make the
;; located version of irritants available, this is the best we can do

8
collects/typed-scheme/optimizer/tool/report.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base
(require racket/class racket/gui/base racket/match racket/port racket/serialize
(require racket/class racket/gui/base racket/match racket/port
unstable/syntax unstable/port racket/sandbox
typed-scheme/optimizer/logging
(prefix-in tr: typed-scheme/typed-reader))
@ -38,8 +38,8 @@
(define (right-file? l) ; does the log-entry refer to the file we're in?
(define stx (log-entry-stx l))
(define path
(let ([dir (deserialize (pseudo-syntax-source-directory stx))]
[file (deserialize (pseudo-syntax-source-file-name stx))])
(let ([dir (syntax-source-directory stx)]
[file (syntax-source-file-name stx)])
(if (and dir file)
(build-path dir file)
#f)))
@ -82,7 +82,7 @@
(match l
[(log-entry kind msg stx located-stx (? number? pos))
(define start (sub1 pos))
(define end (+ start (pseudo-syntax-span stx)))
(define end (+ start (syntax-span stx)))
(report-entry (list (if (opt-log-entry? l)
(opt-report-entry located-stx msg)
(missed-opt-report-entry