Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

error on recursive includes (issue #557)

Browse source
This commit is contained in:
Alex Shinn 2020-06-16 11:44:10 +09:00
parent 5b7729fbfc
commit 278bb48b00
1 changed files with 45 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

58
lib/scheme/extras.scm
View file

@ -5,23 +5,55 @@
(set-port-fold-case! in #t))
(let lp ((res '()))
(let ((x (read in)))
(if (eof-object? x) res (lp (cons x res)))))))
(if (eof-object? x)
(reverse res)
(lp (cons x res)))))))
(define current-includes
'())
(define-syntax push-includes!
(er-macro-transformer
(lambda (expr rename compare)
(set! current-includes (cons (cadr expr) current-includes))
#f)))
(define-syntax pop-includes!
(er-macro-transformer
(lambda (expr rename compare)
(set! current-includes (cdr current-includes))
#f)))
(define-syntax include/aux
(er-macro-transformer
(lambda (expr rename compare)
(let ((ci? (cadr expr)))
(let lp ((files (cddr expr)) (res '()))
(cond
((null? files)
(cons (rename 'begin) (reverse res)))
((not (string? (car files)))
(error "include requires a string"))
((member (car files) current-includes)
(error "recursive include" (car files)))
(else
(let ((includes current-includes))
(lp (cdr files)
(cons `(,(rename 'begin)
(,(rename 'push-includes!) ,(car files))
,@(read-sexps (car files) ci?)
(,(rename 'pop-includes!)))
res))))))))))
(define-syntax include
(er-macro-transformer
(lambda (expr rename compare)
(let lp ((files (cdr expr)) (res '()))
(cond
((null? files) (cons (rename 'begin) (reverse res)))
(else (lp (cdr files) (append (read-sexps (car files)) res))))))))
(syntax-rules ()
((include file ...)
(include/aux #f file ...))))
(define-syntax include-ci
(er-macro-transformer
(lambda (expr rename compare)
(let lp ((files (cdr expr)) (res '()))
(cond
((null? files) (cons (rename 'begin) (reverse res)))
(else (lp (cdr files) (append (read-sexps (car files) #t) res))))))))
(syntax-rules ()
((include file ...)
(include/aux #t file ...))))
(define (read-error? x)
(and (error-object? x) (memq (exception-kind x) '(read read-incomplete)) #t))