chibi-scheme/config.scm

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; modules

(define *modules* '())
(define *this-module* '())
(define *load-path* (list "./lib" (string-append *module-directory* "/lib")))

(define (make-module exports env meta) (vector exports env meta))
(define (module-exports mod) (vector-ref mod 0))
(define (module-env mod) (vector-ref mod 1))
(define (module-meta-data mod) (vector-ref mod 2))
(define (module-env-set! mod env) (vector-set! mod 1 env))

(define (find-module-file name file)
  (let lp ((ls *load-path*))
    (and (pair? ls)
         (let ((path (string-append (car ls) "/" file)))
           (if (file-exists? path) path (lp (cdr ls)))))))

(define (module-name->strings ls res)
  (if (null? ls)
      res
      (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls)))
                       ((number? (car ls)) (number->string (car ls)))
                       ((string? (car ls)) (car ls))
                       (else (error "invalid module name" (car ls))))))
        (module-name->strings (cdr ls) (cons "/" (cons str res))))))

(define (module-name->file name)
  (string-concatenate
   (reverse (cons ".module" (cdr (module-name->strings name '()))))))

(define (module-name-prefix name)
  (string-concatenate (reverse (cdr (cdr (module-name->strings name '()))))))

(define (load-module-definition name)
  (let* ((file (module-name->file name))
         (path (find-module-file name file)))
    (if path (load path *config-env*))))

(define (find-module name)
  (cond
   ((assoc name *modules*) => cdr)
   (else
    (load-module-definition name)
    (cond ((assoc name *modules*) => cdr)
          (else #f)))))

(define (symbol-append a b)
  (string->symbol (string-append (symbol->string a) (symbol->string b))))

(define (to-id id) (if (pair? id) (car id) id))
(define (from-id id) (if (pair? id) (cdr id) id))
(define (id-filter pred ls)
  (cond ((null? ls) '())
        ((pred (to-id (car ls))) (cons (car ls) (id-filter pred (cdr ls))))
        (else (id-filter pred (cdr ls)))))

(define (resolve-import x)
  (cond
   ((not (and (pair? x) (list? x)))
    (error "invalid module syntax" x))
   ((and (pair? (cdr x)) (pair? (cadr x)))
    (if (memq (car x) '(only except renams))
        (let* ((mod-name+imports (resolve-import (cadr x)))
               (imp-ids (cdr mod-name+imports)))
          (cons (car mod-name+imports)
                (case (car x)
                  ((only)
                   (id-filter (lambda (i) (memq i (cddr x))) imp-ids))
                  ((except)
                   (id-filter (lambda (i) (not (memq i (cddr x)))) imp-ids))
                  ((rename)
                   (map (lambda (i)
                          (let ((rename (assq (to-id i) (cddr x))))
                            (if rename (cons (cdr rename) (from-id i)) i)))
                        imp-ids)))))
        (error "invalid import modifier" x)))
   ((and (eq? 'prefix (car x)) (symbol? (cadr x)) (list? (caddr x)))
    (let ((mod-name+imports (resolve-import (caddr x))))
      (cons (car mod-name+imports)
            (map (lambda (i)
                   (cons (symbol-append (cadr x) (if (pair? i) (car i) i))
                         (if (pair? i) (cdr i) i)))
                 (cdr mod-name+imports)))))
   ((find-module x)
    => (lambda (mod) (cons x (module-exports mod))))
   (else
    (error "couldn't find import" x))))

(define (eval-module name mod)
  (let ((env (make-environment))
        (dir (module-name-prefix name)))
    (for-each
     (lambda (x)
       (case (and (pair? x) (car x))
         ((import)
          (for-each
           (lambda (x)
             (let* ((mod2-name+imports (resolve-import x))
                    (mod2 (load-module (car mod2-name+imports))))
               (%env-copy! env (module-env mod2) (cdr mod2-name+imports))))
           (cdr x)))
         ((include include-shared)
          (for-each
           (lambda (f)
             (let ((f (string-append
                       dir f
                       (if (eq? (car x) 'include) "" *shared-object-extension*))))
               (cond
                ((find-module-file name f) => (lambda (x) (load x env)))
                (else (error "couldn't find include" f)))))
           (cdr x)))
         ((body)
          (for-each (lambda (expr) (eval expr env)) (cdr x)))))
     (module-meta-data mod))
    env))

(define (load-module name)
  (let ((mod (find-module name)))
    (if (and mod (not (module-env mod)))
        (module-env-set! mod (eval-module name mod)))
    mod))

(define-syntax define-module
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((name (cadr expr))
           (body (cddr expr)))
       `(let ((tmp *this-module*))
          (set! *this-module* '())
          ,@body
          (set! *this-module* (reverse *this-module*))
          (let ((exports
                 (cond ((assq 'export *this-module*) => cdr)
                       (else '()))))
            (set! *modules*
                  (cons (cons ',name (make-module exports #f *this-module*))
                        *modules*)))
          (set! *this-module* tmp))))))

(define-syntax define-config-primitive
  (er-macro-transformer
   (lambda (expr rename compare)
     `(define-syntax ,(cadr expr)
        (er-macro-transformer
         (lambda (expr rename compare)
           `(set! *this-module* (cons ',expr *this-module*))))))))

(define-config-primitive import)
(define-config-primitive export)
(define-config-primitive include)
(define-config-primitive include-shared)
(define-config-primitive body)

(let ((exports
       '(define set! let let* letrec lambda if cond case delay
         and or begin do quote quasiquote
         define-syntax let-syntax letrec-syntax syntax-rules eqv? eq? equal?
         not boolean? number? complex? real? rational? integer? exact? inexact?
         = < > <= >= zero? positive? negative? odd? even? max min + * - / abs
         quotient remainder modulo gcd lcm numerator denominator floor ceiling
         truncate round exp log sin cos tan asin acos atan sqrt
         expt real-part imag-part magnitude angle
         exact->inexact inexact->exact number->string string->number pair? cons
         car cdr set-car! set-cdr! caar cadr cdar cddr caaar caadr cadar caddr
         cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr
         caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
         null? list? list length append reverse reverse!
         list-tail list-ref memq memv
         member assq assv assoc symbol? symbol->string string->symbol char?
         char=? char<? char>? char<=? char>=? char-ci=? char-ci<? char-ci>?
         char-ci<=? char-ci>=? char-alphabetic? char-numeric? char-whitespace?
         char-upper-case? char-lower-case? char->integer integer->char
         char-upcase char-downcase string? make-string string string-length
         string-ref string-set! string=? string-ci=? string<? string>?
         string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
         substring string-append string->list list->string string-copy
         string-fill! vector? make-vector vector vector-length vector-ref
         vector-set! vector->list list->vector vector-fill! procedure? apply
         map for-each force call-with-current-continuation values
         call-with-values interaction-environment scheme-report-environment
         null-environment call-with-input-file call-with-output-file
         input-port? output-port? current-input-port current-output-port
         with-input-from-file with-output-to-file open-input-file
         open-output-file close-input-port close-output-port read read-char
         peek-char eof-object? char-ready? write display newline write-char
         load eval
         *current-input-port* *current-output-port* *current-error-port*
         error current-error-port file-exists? string-concatenate
         open-input-string open-output-string get-output-string
         sc-macro-transformer rsc-macro-transformer er-macro-transformer
         identifier? identifier=? identifier->symbol make-syntactic-closure
         syntax-quote
         register-simple-type make-constructor make-type-predicate
         make-getter make-setter
         )))
  (set! *modules*
        (list (cons '(scheme) (make-module exports
                                           (interaction-environment)
                                           (list (cons 'export exports))))
              (cons '(srfi 0) (make-module (list 'cond-expand)
                                           (interaction-environment)
                                           (list (list 'export 'cond-expand)))))))