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