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

Combine two let's into a let*', use some #'s.

Browse Source
This commit is contained in:
Eli Barzilay 2011-07-01 15:51:47 -04:00
parent f86687de9c
commit 1276568558
1 changed files with 50 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
collects/racket/contract/private/provide.rkt
View File

@ -1,18 +1,18 @@
#lang racket/base #lang racket/base
(provide provide/contract (provide provide/contract
(for-syntax make-provide/contract-transformer)) (for-syntax make-provide/contract-transformer))
(require (for-syntax racket/base (require (for-syntax racket/base
racket/list racket/list
racket/struct-info racket/struct-info
unstable/dirs
(prefix-in a: "helpers.rkt")) (prefix-in a: "helpers.rkt"))
"arrow.rkt" "arrow.rkt"
"base.rkt" "base.rkt"
"guts.rkt" "guts.rkt"
"misc.rkt" "misc.rkt"
"exists.rkt" "exists.rkt"
(for-syntax unstable/dirs)
syntax/location syntax/location
syntax/srcloc) syntax/srcloc)
@ -46,57 +46,54 @@
(let ([saved-id-table (make-hasheq)]) (let ([saved-id-table (make-hasheq)])
(λ (stx) (λ (stx)
(if (eq? 'expression (syntax-local-context)) (if (eq? 'expression (syntax-local-context))
;; In an expression context: ;; In an expression context:
(let ([key (syntax-local-lift-context)]) (let* ([key (syntax-local-lift-context)]
;; Already lifted in this lifting context? ;; Already lifted in this lifting context?
(let ([lifted-id [lifted-id
(or (hash-ref saved-id-table key #f) (or (hash-ref saved-id-table key #f)
;; No: lift the contract creation: ;; No: lift the contract creation:
(with-syntax ([contract-id contract-id] (with-syntax ([contract-id contract-id]
[id id] [id id]
[external-id external-id] [external-id external-id]
[pos-module-source pos-module-source] [pos-module-source pos-module-source]
[loc-id (identifier-prune-to-source-module id)]) [loc-id (identifier-prune-to-source-module id)])
(let ([srcloc-code (let ([srcloc-code
(with-syntax (with-syntax
([src ([src
(or (and (or (and (path-string? (syntax-source #'id))
(path-string? (syntax-source #'id)) (path->directory-relative-string
(path->directory-relative-string (syntax-source #'id) #:default #f))
(syntax-source #'id) #:default #f)) (syntax-source #'id))]
(syntax-source #'id))] [line (syntax-line #'id)]
[line (syntax-line #'id)] [col (syntax-column #'id)]
[col (syntax-column #'id)] [pos (syntax-position #'id)]
[pos (syntax-position #'id)] [span (syntax-span #'id)])
[span (syntax-span #'id)]) #'(make-srcloc 'src 'line 'col 'pos 'span))])
#'(make-srcloc 'src 'line 'col 'pos 'span))]) (syntax-local-introduce
(syntax-local-introduce (syntax-local-lift-expression
(syntax-local-lift-expression #`(contract contract-id
#`(contract contract-id id
id pos-module-source
pos-module-source (quote-module-path)
(quote-module-path) 'external-id
'external-id #,srcloc-code))))))])
#,srcloc-code))))))]) (when key (hash-set! saved-id-table key lifted-id))
(when key ;; Expand to a use of the lifted expression:
(hash-set! saved-id-table key lifted-id)) (with-syntax ([saved-id (syntax-local-introduce lifted-id)])
;; Expand to a use of the lifted expression: (syntax-case stx (set!)
(with-syntax ([saved-id (syntax-local-introduce lifted-id)]) [name (identifier? #'name) #'saved-id]
(syntax-case stx (set!) [(set! id arg)
[name (raise-syntax-error
(identifier? (syntax name)) 'provide/contract
(syntax saved-id)] "cannot set! a provide/contract variable"
[(set! id arg) stx #'id)]
(raise-syntax-error 'provide/contract [(name . more)
"cannot set! a provide/contract variable" (with-syntax ([app (datum->syntax stx '#%app)])
stx (syntax/loc stx (app saved-id . more)))])))
(syntax id))] ;; In case of partial expansion for module-level and internal-defn
[(name . more) ;; contexts, delay expansion until it's a good time to lift
(with-syntax ([app (datum->syntax stx '#%app)]) ;; expressions:
(syntax/loc stx (app saved-id . more)))])))) (quasisyntax/loc stx (#%expression #,stx)))))))
;; In case of partial expansion for module-level and internal-defn contexts,
;; delay expansion until it's a good time to lift expressions:
(quasisyntax/loc stx (#%expression #,stx)))))))
(define-for-syntax (true-provide/contract provide-stx) (define-for-syntax (true-provide/contract provide-stx)
(syntax-case provide-stx (struct) (syntax-case provide-stx (struct)