;;;; 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 base))
(define-syntax autoload
(er-macro-transformer
(lambda (expr rename compare)
(let ((module (cadr expr))
(procs (cddr expr))
(_import (rename 'import))
(_define (rename 'define))
(_let (rename 'let))
(_set! (rename 'set!))
(_begin (rename 'begin))
(_apply (rename 'apply))
(_args (rename 'args))
(_tmp (rename 'tmp))
(_eval (rename 'eval))
(_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)
(,_let ((,_tmp (,_condition-case
(,_begin
(,_eval
(begin (require-library ,module)
#f))
(,_eval ',full-name))
(exn () ,default))))
(,_set! ,alias ,_tmp)
(,_apply ,_tmp ,_args)))
`(,_define (,alias . ,_args)
(,_let ((,_tmp (,_begin
(,_eval
(begin (require-library ,module)
#f))
(,_eval ',full-name))))
(,_set! ,alias ,_tmp)
(,_apply ,_tmp ,_args))))))
procs))))))
)