From bc4d01eac0ea4d1d87225ab6444938d4c6d2c3cb Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 14 Oct 2012 22:37:46 +0900 Subject: [PATCH] Adding include and include-ci to (scheme base). The cwd is undefined - these macros are useless. --- lib/scheme/base.sld | 3 ++- lib/scheme/extras.scm | 24 ++++++++++++++++++++++++ 2 files changed, 26 insertions(+), 1 deletion(-) 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)