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