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

.

Browse Source 
original commit: 0f289e6be219405304897fa8a2e8f57b51a9a481
This commit is contained in:
Matthew Flatt 2001-10-30 04:07:45 +00:00
parent 06f9d4d900
commit d3e4d22472
1 changed files with 50 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/mzlib/include.ss
View File

@ -2,24 +2,27 @@
(module include mzscheme
(require-for-syntax (lib "stx.ss" "syntax"))
(define-syntax include
(define-syntax include-at/relative-to
(lambda (stx)
;; Parse the file name
(let ([file
(syntax-case* stx (build-path) module-or-top-identifier=?
[(_ fn)
(string? (syntax-e (syntax fn)))
(syntax-e (syntax fn))]
[(_ (build-path elem1 elem ...))
(andmap
(lambda (e)
(or (string? (syntax-e e))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
(apply build-path (syntax-object->datum (syntax (elem1 elem ...))))])])
(let-values ([(ctx loc file)
(syntax-case* stx (build-path) module-or-top-identifier=?
[(_ ctx loc fn)
(string? (syntax-e (syntax fn)))
(values (syntax ctx) (syntax loc) (syntax-e (syntax fn)))]
[(_ ctx loc (build-path elem1 elem ...))
(andmap
(lambda (e)
(or (string? (syntax-e e))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
(values
(syntax ctx)
(syntax loc)
(apply build-path (syntax-object->datum (syntax (elem1 elem ...)))))])])
;; Complete the file name
(let ([c-file
(if (complete-path? file)
@ -28,12 +31,12 @@
file
(cond
;; Src of include expression is a path?
[(and (string? (syntax-source stx))
(complete-path? (syntax-source stx)))
[(and (string? (syntax-source loc))
(complete-path? (syntax-source loc)))
(let-values ([(base name dir?)
(split-path (syntax-source stx))])
(split-path (syntax-source loc))])
(if dir?
(syntax-source stx)
(syntax-source loc)
base))]
;; Load relative?
[(current-load-relative-directory)]
@ -86,7 +89,7 @@
[else
(let ([v (syntax-e content)])
(datum->syntax-object
stx
ctx
(cond
[(pair? v)
(loop v)]
@ -102,7 +105,32 @@
`(begin ,@lexed-content)
stx))))))))
(provide include))
(define-syntax include
(lambda (stx)
(syntax-case stx ()
[(_ fn)
;; Check form of fn:
(syntax-case* (syntax fn) (build-path) module-or-top-identifier=?
[fn
(string? (syntax-e (syntax fn)))
'ok]
[(build-path elem1 elem ...)
(andmap
(lambda (e)
(or (string? (syntax-e e))
(and (identifier? e)
(or
(module-identifier=? e (quote-syntax up))
(module-identifier=? e (quote-syntax same))))))
(syntax->list (syntax (elem1 elem ...))))
'ok]
[_else (raise-syntax-error #f "bad syntax" stx (syntax fn))])
;; Expand to include-at/relative-to:
(with-syntax ([_stx stx])
(syntax/loc stx (include-at/relative-to _stx _stx fn)))])))
(provide include
include-at/relative-to))