1;; R7RS library support 2;; Copyright (C) 2020, 2021 Free Software Foundation, Inc. 3;; 4;; This library is free software; you can redistribute it and/or 5;; modify it under the terms of the GNU Lesser General Public 6;; License as published by the Free Software Foundation; either 7;; version 3 of the License, or (at your option) any later version. 8;; 9;; This library is distributed in the hope that it will be useful, 10;; but WITHOUT ANY WARRANTY; without even the implied warranty of 11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 12;; Lesser General Public License for more details. 13;; 14;; You should have received a copy of the GNU Lesser General Public 15;; License along with this library; if not, write to the Free Software 16;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA 17 18 19;; This file is included from boot-9.scm and assumes the existence of (and 20;; expands into) procedures and syntactic forms defined therein. 21 22(define-syntax include-library-declarations 23 (lambda (x) 24 (syntax-violation 25 'include-library-declarations 26 "use of 'include-library-declarations' outside define-library" x x))) 27 28;; FIXME: Implement properly! 29(define-syntax-rule (include-ci filename) 30 (include filename)) 31 32(define-syntax define-library 33 (lambda (stx) 34 (define (handle-includes filenames) 35 (syntax-case filenames () 36 (() #'()) 37 ((filename . filenames) 38 (append (call-with-include-port 39 #'filename 40 (lambda (p) 41 (let lp () 42 (let ((x (read p))) 43 (if (eof-object? x) 44 #'() 45 (cons (datum->syntax #'filename x) (lp))))))) 46 (handle-includes #'filenames))))) 47 48 (define (handle-cond-expand clauses) 49 (define (has-req? req) 50 (syntax-case req (and or not library) 51 ((and req ...) 52 (and-map has-req? #'(req ...))) 53 ((or req ...) 54 (or-map has-req? #'(req ...))) 55 ((not req) 56 (not (has-req? #'req))) 57 ((library lib-name) 58 (->bool (resolve-interface (syntax->datum #'lib-name)))) 59 (id 60 (identifier? #'id) 61 ;; FIXME: R7RS (features) isn't quite the same as 62 ;; %cond-expand-features; see scheme/base.scm. 63 (memq (syntax->datum #'id) %cond-expand-features)))) 64 (syntax-case clauses () 65 (() #'()) ; R7RS says this is not specified :-/ 66 (((test decl ...) . clauses) 67 (if (has-req? #'test) 68 #'(decl ...) 69 (handle-cond-expand #'clauses))))) 70 71 (define (partition-decls decls exports imports code) 72 (syntax-case decls (export import begin include include-ci 73 include-library-declarations cond-expand) 74 (() (values exports imports (reverse code))) 75 (((export clause ...) . decls) 76 (partition-decls #'decls (append exports #'(clause ...)) imports code)) 77 (((import clause ...) . decls) 78 (partition-decls #'decls exports (append imports #'(clause ...)) code)) 79 (((begin expr ...) . decls) 80 (partition-decls #'decls exports imports 81 (cons #'(begin expr ...) code))) 82 (((include filename ...) . decls) 83 (partition-decls #'decls exports imports 84 (cons #'(begin (include filename) ...) code))) 85 (((include-ci filename ...) . decls) 86 (partition-decls #'decls exports imports 87 (cons #'(begin (include-ci filename) ...) code))) 88 (((include-library-declarations filename ...) . decls) 89 (syntax-case (handle-includes #'(filename ...)) () 90 ((decl ...) 91 (partition-decls #'(decl ... . decls) exports imports code)))) 92 (((cond-expand clause ...) . decls) 93 (syntax-case (handle-cond-expand #'(clause ...)) () 94 ((decl ...) 95 (partition-decls #'(decl ... . decls) exports imports code)))))) 96 97 (syntax-case stx () 98 ((_ name decl ...) 99 (call-with-values (lambda () 100 (partition-decls #'(decl ...) '() '() '())) 101 (lambda (exports imports code) 102 #`(library name 103 (export . #,exports) 104 (import . #,imports) 105 . #,code))))))) 106