106 lines
3.3 KiB
Racket
106 lines
3.3 KiB
Racket
#lang racket/base
|
|
;; owner: ryanc (and cce and stamourv, where noted)
|
|
(require racket/syntax
|
|
syntax/stx
|
|
(for-syntax racket/base)
|
|
(for-template racket/base))
|
|
|
|
(provide (rename-out [stx-map syntax-map])
|
|
|
|
;; by cce:
|
|
syntax-source-file-name
|
|
syntax-source-directory
|
|
|
|
;; by stamourv:
|
|
format-unique-id
|
|
syntax-within?
|
|
|
|
;; by ryanc
|
|
explode-module-path-index
|
|
phase-of-enclosing-module
|
|
make-variable-like-transformer)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; By Carl Eastlund, below
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Syntax Locations
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (syntax-source-directory stx)
|
|
(let* ([source (syntax-source stx)])
|
|
(and (path-string? source)
|
|
(let-values ([(base file dir?) (split-path source)])
|
|
(and (path? base)
|
|
(path->complete-path base
|
|
(or (current-load-relative-directory)
|
|
(current-directory))))))))
|
|
|
|
(define (syntax-source-file-name stx)
|
|
(let* ([f (syntax-source stx)])
|
|
(and (path-string? f)
|
|
(let-values ([(base file dir?) (split-path f)]) file))))
|
|
|
|
;; by stamourv:
|
|
|
|
(define (format-unique-id lctx
|
|
#:source [src #f]
|
|
#:props [props #f]
|
|
#:cert [cert #f]
|
|
fmt . args)
|
|
((make-syntax-introducer) (apply format-id
|
|
lctx #:source src #:props props #:cert cert
|
|
fmt args)))
|
|
|
|
;; is syntax a contained within syntax b, inclusively
|
|
(define (syntax-within? a b)
|
|
(let ([pos-a (syntax-position a)]
|
|
[span-a (syntax-span a)]
|
|
[pos-b (syntax-position b)]
|
|
[span-b (syntax-span b)])
|
|
(and pos-a span-a pos-b span-b
|
|
(<= pos-b pos-a)
|
|
(>= (+ pos-b span-b) (+ pos-a span-a)))))
|
|
|
|
|
|
;; by ryanc
|
|
|
|
(define (explode-module-path-index mpi)
|
|
(let-values ([(x y) (module-path-index-split mpi)])
|
|
(cons x
|
|
(if (module-path-index? y)
|
|
(explode-module-path-index y)
|
|
(list y)))))
|
|
|
|
(define-syntax-rule (phase-of-enclosing-module)
|
|
(variable-reference->module-base-phase
|
|
(#%variable-reference)))
|
|
|
|
(define (make-variable-like-transformer ref-stx [set!-handler #f])
|
|
(unless (syntax? ref-stx)
|
|
(raise-type-error 'make-variable-like-transformer "syntax?" ref-stx))
|
|
(unless (or (syntax? set!-handler) (procedure? set!-handler) (eq? set!-handler #f))
|
|
(raise-type-error 'make-variable-like-transformer "(or/c syntax? procedure? #f)" set!-handler))
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[id
|
|
(identifier? #'id)
|
|
ref-stx]
|
|
[(set! id val)
|
|
(cond [(procedure? set!-handler)
|
|
(set!-handler stx)]
|
|
[(syntax? set!-handler)
|
|
(with-syntax ([setter set!-handler])
|
|
(syntax/loc stx (setter val)))]
|
|
[else
|
|
(raise-syntax-error #f "cannot mutate identifier" stx #'id)])]
|
|
[(id . args)
|
|
(let ([stx* (cons #'(#%expression id) (cdr (syntax-e stx)))])
|
|
(datum->syntax stx stx* stx))]))))
|