164 lines
6.3 KiB
Scheme
164 lines
6.3 KiB
Scheme
#lang scheme/base
|
|
|
|
(require "find-version.ss"
|
|
"encode-name.ss"
|
|
(for-template scheme/base))
|
|
|
|
(provide parse-import)
|
|
|
|
(define (symbolic-identifier=? a b)
|
|
(eq? (syntax-e a) (syntax-e b)))
|
|
|
|
(define (is-sub-version-reference? stx)
|
|
(syntax-case* stx (<= >= and or not) symbolic-identifier=?
|
|
[n (exact-nonnegative-integer? (syntax-e #'n)) #t]
|
|
[(>= n) (exact-nonnegative-integer? (syntax-e #'n))]
|
|
[(<= n) (exact-nonnegative-integer? (syntax-e #'n))]
|
|
[(and sv ...) (andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
|
[(or sv ...) (andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
|
[(not sv) (is-sub-version-reference? #'sv)]
|
|
[_ #f]))
|
|
|
|
(define (is-version-reference? stx)
|
|
(syntax-case* stx (and or not) symbolic-identifier=?
|
|
[(and vr ...)
|
|
(andmap is-version-reference? (syntax->list #'(vr ...)))]
|
|
[(or vr ...)
|
|
(andmap is-version-reference? (syntax->list #'(vr ...)))]
|
|
[(not vr)
|
|
(is-version-reference? #'vr)]
|
|
[(sv ...)
|
|
(andmap is-sub-version-reference? (syntax->list #'(sv ...)))]
|
|
[_ #f]))
|
|
|
|
(define (parse-library-reference stx err)
|
|
(syntax-case stx ()
|
|
[(id1 id2 ... (vers ...))
|
|
(and (identifier? #'id1)
|
|
(andmap identifier? (syntax->list #'(id2 ...)))
|
|
(is-version-reference? #'(vers ...)))
|
|
(let-values ([(coll file)
|
|
(let* ([strs (map (lambda (id)
|
|
(symbol->string (syntax-e id)))
|
|
(syntax->list #'(id1 id2 ...)))]
|
|
[len (length strs)]
|
|
[strs (map
|
|
encode-name
|
|
(if (and (= 2 len) (regexp-match? #rx"^main_*$" (cadr strs)))
|
|
;; rename (X main_*) => (X main__*)
|
|
(list (car strs)
|
|
(string-append (cadr strs) "_"))
|
|
;; no rename
|
|
strs))])
|
|
(if (= 1 len)
|
|
(values (list (car strs)) "main")
|
|
(values (reverse (cdr (reverse strs)))
|
|
(car (reverse strs)))))])
|
|
(let ([base (build-path (with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
(err
|
|
(format
|
|
"cannot find suitable library installed (exception: ~a)"
|
|
(if (exn? exn)
|
|
(exn-message exn)
|
|
exn))))])
|
|
(apply collection-path coll))
|
|
file)])
|
|
(let ([vers.ext (find-version (path->bytes base) (syntax->datum #'(vers ...)))])
|
|
(if vers.ext
|
|
(apply string-append
|
|
(car coll)
|
|
(append
|
|
(map (lambda (s)
|
|
(string-append "/" s))
|
|
(append (cdr coll) (list file)))
|
|
(map (lambda (v)
|
|
(format "-~a" v))
|
|
(car vers.ext))
|
|
(list (cdr vers.ext))))
|
|
(err "cannot find suitable installed library")))))]
|
|
[(id1 id2 ...)
|
|
(and (identifier? #'id1)
|
|
(andmap identifier? (syntax->list #'(id2 ...))))
|
|
(parse-library-reference #'(id1 id2 ... ()) err)]
|
|
[_
|
|
(err "ill-formed library reference")]))
|
|
|
|
(define (convert-library-reference orig stx stx-err)
|
|
(datum->syntax
|
|
orig
|
|
`(,#'lib
|
|
,(parse-library-reference stx
|
|
(lambda (msg)
|
|
(stx-err msg orig stx))))
|
|
orig))
|
|
|
|
(define (parse-import-set orig stx stx-err)
|
|
(define (bad)
|
|
(stx-err (format "bad `~a' form"
|
|
(syntax-e (car (syntax-e stx))))
|
|
orig
|
|
stx))
|
|
(define (check-id id)
|
|
(unless (identifier? id)
|
|
(stx-err (format "not an identifier in `~a' form"
|
|
(syntax-e (car (syntax-e stx))))
|
|
orig
|
|
id)))
|
|
(syntax-case* stx (library only except prefix rename) symbolic-identifier=?
|
|
[(library lib)
|
|
(convert-library-reference orig #'lib stx-err)]
|
|
[(library . _) (bad)]
|
|
[(only im id ...)
|
|
(for-each check-id (syntax->list #'(id ...)))
|
|
#`(only-in #,(parse-import-set orig #'im stx-err) id ...)]
|
|
[(only . _) (bad)]
|
|
[(except im id ...)
|
|
(for-each check-id (syntax->list #'(id ...)))
|
|
#`(except-in #,(parse-import-set orig #'im stx-err) id ...)]
|
|
[(except . _) (bad)]
|
|
[(prefix im id)
|
|
(check-id #'id)
|
|
#`(prefix-in id #,(parse-import-set orig #'im stx-err))]
|
|
[(prefix . _) (bad)]
|
|
[(rename im (id id2) ...)
|
|
(for-each check-id
|
|
(apply
|
|
append
|
|
(map syntax->list
|
|
(syntax->list #'((id id2) ...)))))
|
|
#`(rename-in #,(parse-import-set orig #'im stx-err) [id id2] ...)]
|
|
[(rename . _) (bad)]
|
|
[_ (convert-library-reference orig stx stx-err)]))
|
|
|
|
(define (parse-import orig im stx-err)
|
|
(syntax-case* im (for) symbolic-identifier=?
|
|
[(for base-im level ...)
|
|
(let* ([levels
|
|
(cons
|
|
#f
|
|
(map (lambda (level)
|
|
(syntax-case* level (run expand meta) symbolic-identifier=?
|
|
[run #'0]
|
|
[expand #'1]
|
|
[(meta 0) #'0]
|
|
[(meta n) #'n]
|
|
[_
|
|
(stx-err
|
|
"bad `for' level"
|
|
orig
|
|
level)]))
|
|
(syntax->list #'(level ...))))])
|
|
(with-syntax ([is (parse-import-set orig #'base-im stx-err)])
|
|
(with-syntax ([(level ...) levels]
|
|
[prelims (datum->syntax orig
|
|
'r6rs/private/prelims)])
|
|
#`((for-meta level is prelims) ...))))]
|
|
[(for . _)
|
|
(stx-err
|
|
"bad `for' import form"
|
|
orig
|
|
im)]
|
|
[_ (let ([m (parse-import-set orig im stx-err)])
|
|
(list m `(for-label ,m)))]))
|