7d50e61c7f
* Another big chunk of v4-require-isms * Allow `#lang framework/keybinding-lang' for keybinding files * Move hierlist sources into "mrlib/hierlist", leave stub behind svn: r10689
68 lines
2.7 KiB
Scheme
68 lines
2.7 KiB
Scheme
|
|
;; Defines a language to be used by info.ss files
|
|
|
|
#lang mzscheme
|
|
|
|
(define-syntax info-module-begin
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(mod-beg defn ...)
|
|
(let ([names (let loop ([defns (syntax->list (syntax (defn ...)))]
|
|
[r '()])
|
|
(if (null? defns)
|
|
(reverse r)
|
|
(loop (cdr defns)
|
|
(syntax-case (car defns) (define)
|
|
[(define var val)
|
|
(cons (syntax var) r)]
|
|
;; In case it gets expanded:
|
|
[(define-values (var) val)
|
|
(cons (syntax var) r)]
|
|
[(require lib) r] ; ignore these (see below)
|
|
[_else (raise-syntax-error
|
|
'infotab-module
|
|
"not a well-formed definition"
|
|
stx (car defns))]))))])
|
|
(let ([dup (check-duplicate-identifier names)])
|
|
(when dup
|
|
(raise-syntax-error 'infotab-module "duplicate definition" stx dup)))
|
|
(with-syntax ([(name ...) names])
|
|
(syntax
|
|
(#%plain-module-begin
|
|
defn ...
|
|
(define #%info-lookup
|
|
(case-lambda
|
|
[(n) (#%info-lookup n (lambda () (error 'info.ss "no info for ~a" n)))]
|
|
[(n fail)
|
|
(unless (and (procedure? fail)
|
|
(procedure-arity-includes? fail 0))
|
|
(error
|
|
'info.ss
|
|
"expected second argument to be a procedure that takes no arguments, got: ~e"
|
|
fail))
|
|
(case n
|
|
[(name) name]
|
|
...
|
|
[else (fail)])]))
|
|
(define (#%info-domain) '(name ...))
|
|
(provide #%info-lookup #%info-domain)))))])))
|
|
|
|
(define-syntax (limited-require stx)
|
|
(syntax-case stx ()
|
|
[(_ lib) (member (syntax-object->datum #'lib)
|
|
'((lib "string-constant.ss" "string-constants")
|
|
(lib "string-constants/string-constant.ss")
|
|
string-constants/string-constant
|
|
string-constants))
|
|
(syntax/loc stx (require lib))]))
|
|
|
|
(provide (rename info-module-begin #%module-begin)
|
|
#%app #%datum #%top
|
|
define quote
|
|
list cons car cdr quasiquote unquote unquote-splicing
|
|
list* append reverse
|
|
string-append
|
|
path->string build-path collection-path
|
|
system-library-subpath
|
|
(rename limited-require require))
|