1;;  Filename : srfi-55.scm
2;;  About    : SRFI-55 require-extension
3;;
4;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
5;;
6;;  All rights reserved.
7;;
8;;  Redistribution and use in source and binary forms, with or without
9;;  modification, are permitted provided that the following conditions
10;;  are met:
11;;
12;;  1. Redistributions of source code must retain the above copyright
13;;     notice, this list of conditions and the following disclaimer.
14;;  2. Redistributions in binary form must reproduce the above copyright
15;;     notice, this list of conditions and the following disclaimer in the
16;;     documentation and/or other materials provided with the distribution.
17;;  3. Neither the name of authors nor the names of its contributors
18;;     may be used to endorse or promote products derived from this software
19;;     without specific prior written permission.
20;;
21;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
22;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
23;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
24;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
25;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
26;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
27;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
34(define %require-extension-handler-srfi
35  (lambda numbers
36    (for-each (lambda (n)
37                (let ((srfi-n (string-append "srfi-" (number->string n))))
38                  (or (%%require-module srfi-n)
39                      (%require-sysfile srfi-n))))
40              numbers)))
41
42;; Be quasiquote free to allow --disable-quasiquote
43(define %require-extension-alist
44  (list
45   (cons 'srfi %require-extension-handler-srfi)))
46
47(define %require-sysfile
48  (lambda (ext-id)
49    (or (provided? ext-id)
50        (let* ((file (string-append ext-id ".scm"))
51               (path (string-append (%%system-load-path) "/" file)))
52          (load path)
53          (provide ext-id)))))
54
55(define %require-extension
56  (lambda clauses
57    (for-each (lambda (clause)
58                (let* ((id (car clause))
59                       (args (cdr clause))
60                       (id-str (symbol->string id))
61                       (default-handler (lambda ()
62                                          (or (%%require-module id-str)
63                                              (%require-sysfile id-str))))
64                       (handler (cond
65                                 ((assq id %require-extension-alist) => cdr)
66                                 (else
67                                  default-handler))))
68                  (apply handler args)))
69              clauses)))
70