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

Change it so that it uses strings instead of symbols here.

Browse Source 
svn: r11697
This commit is contained in:
Stevie Strickland 2008-09-12 19:01:13 +00:00
parent 19cfe4e49e
commit 4e8064e8a5
2 changed files with 12 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/scheme/private/contract-helpers.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(provide module-source-as-symbol build-src-loc-string (provide module-source-as-string build-src-loc-string
mangle-id mangle-id-for-maker mangle-id mangle-id-for-maker
build-struct-names build-struct-names
nums-up-to nums-up-to
@ -111,27 +111,27 @@
(define o (current-output-port)) (define o (current-output-port))
;; module-source-as-symbol : syntax -> symbol ;; module-source-as-string : syntax -> symbol
;; constructs a symbol for use in the blame error messages ;; constructs a string for use in the blame error messages
;; when blaming the module where stx's occurs. ;; when blaming the module where stx's occurs.
(define (module-source-as-symbol stx) (define (module-source-as-string stx)
(let ([mpi (syntax-source-module stx)]) (let ([mpi (syntax-source-module stx)])
(cond (cond
[(not mpi) [(not mpi)
'top-level] "tthe top level"]
[else [else
;; note: the directory passed to collapse-module-path-index should be irrelevant ;; note: the directory passed to collapse-module-path-index should be irrelevant
(let ([collapsed (let ([collapsed
(with-handlers ((exn:fail? (λ (x) 'top-level))) ;; this with-handlers works around a bug elsewhere (with-handlers ((exn:fail? (λ (x) "the top level"))) ;; this with-handlers works around a bug elsewhere
(collapse-module-path-index mpi (current-directory)))]) (collapse-module-path-index mpi (current-directory)))])
(cond (cond
[(path? collapsed) [(path? collapsed)
(let ([resolved (resolved-module-path-name (module-path-index-resolve mpi))]) (let ([resolved (resolved-module-path-name (module-path-index-resolve mpi))])
(cond (cond
[(symbol? resolved) resolved] [(symbol? resolved) (format "module ~a" resolved)]
[else `(file ,(path->string resolved))]))] [else (format "module ~a" `(file ,(path->string resolved)))]))]
[else [else
collapsed]))]))) (format "module ~a" collapsed)]))])))
(define build-struct-names (define build-struct-names
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx) (lambda (name-stx fields omit-sel? omit-set? srcloc-stx)

6
collects/scheme/private/contract.ss
View File

@ -132,7 +132,7 @@ improve method arity mismatch contract violation error messages?
(make-set!-transformer (make-set!-transformer
(lambda (stx) (lambda (stx)
(with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region) (with-syntax ([neg-blame-id (or (syntax-parameter-value #'current-contract-region)
#`(quote #,(a:module-source-as-symbol id)))] (a:module-source-as-string id))]
[pos-blame-id pos-blame-id] [pos-blame-id pos-blame-id]
[contract-id contract-id] [contract-id contract-id]
[id id]) [id id])
@ -303,7 +303,7 @@ improve method arity mismatch contract violation error messages?
#`(-contract contract-id #`(-contract contract-id
id id
pos-module-source pos-module-source
(module-source-as-symbol #'name) (module-source-as-string #'name)
#,(id->contract-src-info #'id))))))]) #,(id->contract-src-info #'id))))))])
(when key (when key
(hash-set! saved-id-table key lifted-id)) (hash-set! saved-id-table key lifted-id))
@ -802,7 +802,7 @@ improve method arity mismatch contract violation error messages?
(with-syntax ([code (with-syntax ([code
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
(define pos-module-source (module-source-as-symbol #'pos-stx)) (define pos-module-source (module-source-as-string #'pos-stx))
#,@(if no-need-to-check-ctrct? #,@(if no-need-to-check-ctrct?
(list) (list)