Gauche で R6RS ライブラリを読もうとしたときの残骸

library.scm

;;;
;;; - (export (rename ...)) できない
;;; - import のセマンティクスが違うので他のライブラリから
;;;   import したものを export できない
;;;
;;; - ライブラリのバージョンは無視
;;; - import の for も無視
;;; - import 中の名前の衝突はエラーにしない（Gauche に任せる）
;;; - (rnrs . _) ライブラリはとりあえず null モジュールへ
;;; - (import (rnrs)) しないプログラムはとりあえず考えない
;;;

(define-module rnrs.library
  (export library import add-module-alias-proc!)
  (use srfi-1)
  (use srfi-13)
  (use util.match))

(select-module rnrs.library)

(define-macro library
  (match-lambda*
   (((name ...) ('export exports ...) ('import imports ...) . body)
    `(define-module ,(r6rs-library-name->gauche-module-name name)
       (export ,@(r6rs-exports->gauche-exports exports))
       (use srfi-11)
       ,@(r6rs-imports->gauche-uses imports)

       ,@body
       (if #f #f)))
   (x (error "malformed library: " `(library ,@x)))))

(define module-alias-procs '())

(define (add-module-alias-proc! proc)
  (push! module-alias-procs proc))

(define (resolve-user-defined-module-alias name)
  (any (cut <> name) module-alias-procs))

;; (some library name) -> some.library.name
(define (r6rs-library-name->gauche-module-name name)
  (define (parse-r6rs-library-name name)
    (let loop ((ns name)
               (rs '()))
      (cond ((null? ns)
             (values (reverse! rs) #f))
            ((and (pair? (car ns)) (every number? (car ns)))
             (values (reverse! rs) (car ns)))
            ((symbol? (car ns))
             (loop (cdr ns) (cons (car ns) rs)))
            (else
             (error "malformed library name: " name (car ns))))))
  (receive (syms _ver) (parse-r6rs-library-name name)
    ;; ignore library version
    (or (resolve-user-defined-module-alias name)
          (string->symbol
           (string-join (map x->string name) ".")))))

(define (r6rs-exports->gauche-exports exports)
  (map (match-lambda
        ([? symbol? s] s)
        ([and ('rename [? symbol?] [? symbol?]) form]
         (error "rename on export is not supported: " form))
        (x
         (error "malformed export spec: " x)))
       exports))

(define (r6rs-imports->gauche-uses specs)
  (define (r6rs-import->gauche-use spec)
    (match spec
      (('only s [? symbol? syms] ...)
       `(,@(r6rs-import->gauche-use s) :only ,syms))
      (('except s [? symbol? syms] ...)
       `(,@(r6rs-import->gauche-use s) :except ,syms))
      (('rename s [and spec ([? symbol?] [? symbol?])] ...)
       `(,@(r6rs-import->gauche-use s) :rename ,spec))
      (('prefix s [? symbol? pfx])
       `(,@(r6rs-import->gauche-use s) :prefix ,pfx))
      (('library s)
       (r6rs-import->gauche-use s))
      ;; ignore `for'
      (('for s . _)
       (r6rs-import->gauche-use s))
      ([and s ([? symbol?] ...)]
       `(,(r6rs-library-name->gauche-module-name s)))
      (_ (error "malformed import spec: " spec))))
  (map (lambda (e)
         (match (r6rs-import->gauche-use e)
           ((name . opts)
            (if (find-module name)
                `((with-module gauche import) (,name ,@opts))
                `((with-module gauche use) ,name ,@opts)))))
       specs))

(define-macro (import . specs)
  `(begin ,@(r6rs-imports->gauche-uses specs)))

;; (srfi :n) -> srfi-n
(add-module-alias-proc!
 (lambda (name)
   (match name
     (('srfi [and [? keyword?] n] . _)
      (string->symbol (format "srfi-~A" n)))
     (_ #f))))

;; (rnrs . _) -> null
(add-module-alias-proc!
 (lambda (name)
   (match name
     (('rnrs . _)
      'null)
     (_ #f))))