suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

another scribble/lp/lang/lang repair

Browse Source 
svn: r13767

original commit: 327fa47487930554e1dd2537a8fcb9ab5793f67b
This commit is contained in:
Matthew Flatt 2009-02-21 14:15:29 +00:00
parent d33566e09f
commit a6002db1ec
1 changed files with 30 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

61
collects/scribble/lp/lang/lang.ss
View File

@ -70,37 +70,36 @@
(define-syntax (literate-begin stx)
(syntax-case stx ()
[(module-begin expr ...)
(with-syntax
([(body-code ...)
(let loop ([exprs (syntax->list #'(expr ...))])
(cond
[(null? exprs) null]
[else
(let ([expanded
(local-expand (car exprs)
'module
(append (kernel-form-identifier-list)
(syntax->list #'(provide
require
#%provide
#%require))))])
(syntax-case expanded (begin)
[(begin rest ...)
(append (loop (syntax->list #'(rest ...)))
(loop (cdr exprs)))]
[(id . rest)
(ormap (lambda (kw) (free-identifier=? #'id kw))
(syntax->list #'(require
provide
chunk
#%require
#%provide)))
(cons expanded (loop (cdr exprs)))]
[else (loop (cdr exprs))]))]))])
#'(begin
body-code ...
(tangle)))]))
[(_ . exprs)
(let loop ([exprs #'exprs])
(syntax-case exprs ()
[() #'(tangle)]
[(expr . exprs)
(let ([expanded
(local-expand #'expr
'module
(append (kernel-form-identifier-list)
(syntax->list #'(provide
require
chunk
#%provide
#%require))))])
(syntax-case expanded (begin chunk require/chunk)
[(begin rest ...)
(loop (datum->syntax
expanded
(append
(syntax->list #'(rest ...))
#'exprs)))]
[(id . _)
(ormap (lambda (kw) (free-identifier=? #'id kw))
(syntax->list #'(require
provide
chunk
#%require
#%provide)))
#`(begin #,expanded (literate-begin . exprs))]
[else (loop #'exprs)]))]))]))
(define-syntax (module-begin stx)
(syntax-case stx ()