diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index d4b6e95c..d8e79c55 100644 --- a/lib/scheme/base.sld +++ b/lib/scheme/base.sld @@ -25,7 +25,8 @@ error-object-irritants error-object-message error-object? even? exact exact-integer-sqrt exact-integer? exact? expt features floor flush-output-port for-each gcd get-output-bytevector get-output-string - guard if import inexact inexact? input-port? integer->char + guard if import include include-ci inexact inexact? input-port? + integer->char integer? lambda lcm length let let* let*-values let-syntax let-values letrec letrec* letrec-syntax list list->string list->vector list-copy list-ref list-set! list-tail list? make-bytevector make-list diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index c203403b..a7caa833 100644 --- a/lib/scheme/extras.scm +++ b/lib/scheme/extras.scm @@ -1,4 +1,28 @@ +(define (read-sexps file . o) + (let ((in (open-input-file file))) + (if (and (pair? o) (car o)) + (set-port-fold-case! in #t)) + (let lp ((res '())) + (let ((x (read in))) + (if (eof-object? x) res (lp (cons x 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)))))))) + +(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)))))))) + (define (features) *features*) (define exact inexact->exact)