Gauche-init/init.body.scm

;; Copyright (C) 2999 Your name.

(define work-dir "")

(define (set-work-dir! new-location)
  (set! work-dir new-location))

(define (get-work-dir)
  work-dir)

(define (initialize-module mod-name)
  ;; module name is a list, such as
  ;; '(a b c)
  ;; which will be created in workdir/a/b/c.sld
  (define (all-symbols? l)
    (equal? l (filter symbol? l)))

  (define (create-library-files path lib)
    (define sld-target (string-append path lib ".sld"))
    (define body-target (string-append path lib ".body.scm"))

    (define sld-contents
      `((define-library ,mod-name
         (import (scheme base))
         (export)
         (include ,(string-append lib ".body.scm")))))

    (define body-contents
      ";; Copyright (C) 2999 Your name.\n\n")

    (sexp-list->file sld-target sld-contents)
    (string->file body-target body-contents))

  (unless (and (pair? mod-name)
               (list? mod-name)
               (all-symbols? mod-name))
    (error "mod-name is not a non-empty list of symbols" mod-name))
  (let loop ((path work-dir)
             (rest mod-name))
    (cond
     ((null? (cdr rest))
      (create-library-files path (symbol->string (car rest))))
     (else
      (let ((new-path (string-append path
                                     (symbol->string (car rest))
                                     "/")))
        (make-directory* new-path)
        (loop new-path (cdr rest)))))))

(define-syntax create-module
  (syntax-rules ()
    ((_ (a b ...))
     (initialize-module '(a b ...)))))