;;;; 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))

(module autoload (autoload)

(import scheme chicken)

(define-syntax autoload
  (er-macro-transformer
   (lambda (expr rename compare)
     (let ((module (cadr expr))
           (procs (cddr expr))
           (_define (rename 'define))
           (_let (rename 'let))
           (_set! (rename 'set!))
           (_begin (rename 'begin))
           (_apply (rename 'apply))
           (_args (rename 'args))
           (_tmp (rename 'tmp))
           (_require-library (rename 'require-library))
           (_condition-case (rename 'condition-case)))
       `(,_begin
         ,@(map
            (lambda (x)
              (let* ((x (if (pair? x) x (list x)))
                     (name (car x))
                     (full-name
                      (string->symbol
                       (string-append (symbol->string module) "#"
                                      (symbol->string name))))
                     (alias (or (and (pair? (cdr x)) (cadr x)) name))
                     (default (and (pair? (cdr x)) (pair? (cddr x)) (caddr x))))
                (if default
                    `(,_define (,alias . ,_args)
                       (,_condition-case
                        (,_begin
                         (,_require-library ,module)
                         (,_let ((,_tmp ,full-name))
                           (,_set! ,alias ,_tmp)
                           (,_apply ,_tmp ,_args)))
                        (exn ()
                             (,_let ((,_tmp ,default))
                               (,_set! ,alias ,_tmp)
                               (,_apply ,_tmp ,_args)))))
                    `(,_define (,alias . ,_args)
                       (,_require-library ,module)
                       (,_let ((,_tmp ,full-name))
                         (,_set! ,alias ,_tmp)
                         (,_apply ,_tmp ,_args))))))
            procs))))))

)