;;;; autoload.scm -- load modules lazily
;;
;; Copyright (c) 2005-2009 Alex Shinn
;; All rights reserved.
;;
;; BSD-style license: http://www.debian.org/misc/bsd.license

;; Provides an Emacs-style autoload facility which takes the basic form
;;
;;   (autoload unit procedure-name ...)
;;
;; such that the first time procedure-name is called, it will perform a
;; runtime require of 'unit and then apply the procedure from the newly
;; loaded unit to the args it was passed.  Subsequent calls to
;; procedure-name will thereafter refer to the new procedure and will
;; thus not incur any overhead.
;;
;; You may also specify an alias for the procedure, and a default
;; procedure if the library can't be loaded:
;;
;;   (autoload unit (name alias default) ...)
;;
;; In this case, although the procedure name from the unit is "name,"
;; the form defines the autoload procedure as "alias."
;;
;; If the library can't be loaded then an error is signalled, unless
;; default is given, in which case the values are passed to that.
;;
;; Examples:
;;
;; ;; load iconv procedures lazily
;; (autoload iconv iconv iconv-open)
;;
;; ;; load some sqlite procedures lazily with "-" names
;; (autoload sqlite (sqlite:open sqlite-open)
;;                  (sqlite:execute sqlite-execute))
;;
;; ;; load md5 library, falling back on slower scheme version
;; (autoload scheme-md5 (md5:digest scheme-md5:digest))
;; (autoload md5 (md5:digest #f scheme-md5:digest))

(require-library lolevel)

(module autoload
  ((autoload global-ref))

(import scheme chicken lolevel)

(define-syntax autoload
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((unit (cadr expr))
           (procs (cddr expr)))
       (cons
        (rename 'begin)
        (map
         (lambda (x)
           (let* ((x (if (pair? x) x (list x)))
                  (name (car x))
                  (full-name
                   (string->symbol
                    (string-append (symbol->string unit) "#"
                                   (symbol->string name))))
                  (alias (or (and (pair? (cdr x)) (cadr x)) name))
                  (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x))))
             (if default
                 `(,(rename 'define) (,alias . ,(rename 'args))
                    (,(rename 'condition-case)
                     (,(rename 'begin)
                       (,(rename 'require) ',unit)
                       (,(rename 'let) ((,(rename 'tmp)
                                         (,(rename 'global-ref) ',full-name)))
                         (,(rename 'set!) ,alias ,(rename 'tmp))
                         (,(rename 'apply)
                          ,(rename 'tmp)
                          ,(rename 'args))))
                     (exn ()
                          (,(rename 'let) ((,(rename 'tmp) ,default))
                           (,(rename 'set!) ,alias ,(rename 'tmp))
                           (,(rename 'apply)
                            ,(rename 'tmp)
                            ,(rename 'args))))))
                 `(,(rename 'define) (,alias . ,(rename 'args))
                   (,(rename 'require) ',unit)
                   (,(rename 'let) ((,(rename 'tmp)
                                     (,(rename 'global-ref) ',full-name)))
                    (,(rename 'set!) ,alias ,(rename 'tmp))
                    (,(rename 'apply)
                     ,(rename 'tmp)
                     ,(rename 'args)))))))
             procs))))))

)