Support R7RS define-library

* module/Makefile.am (ice-9/boot-9.go, NOCOMP_SOURCES): Add
  r7rs-libraries.
* module/ice-9/boot-9.scm ("ice-9/r7rs-libraries"): Include file.
* module/ice-9/psyntax.scm (call-with-include-port): New definition.
  (include): Use call-with-include-port.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/r7rs-libraries.scm: New file.
* module/scheme/base.scm (r7:include, r7:include-ci): Fix mistaken use
  of core "include".  Use include-ci from core.
  (features): Remove features that are already part of core.
* NEWS: Update.

NEWS

@@ -73,6 +73,12 @@ targets.  This has been fixed.
 
 Thanks for Stefan Israelsson Tampe for the report.
 
+** Fix omission in R7RS support
+
+Somewhat embarrassingly, the R7RS support added earlier in 2.9 failed to
+include an implementation of `define-library'.  This oversight has been
+corrected :)
+
 
 Changes in alpha 2.9.x (since the stable 2.2 series):
 

module/Makefile.am

@@ -1,6 +1,6 @@
 ## Process this file with automake to produce Makefile.in.
 ##
-##   Copyright (C) 2009-2019 Free Software Foundation, Inc.
+##   Copyright (C) 2009-2020 Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
 ##
@@ -27,7 +27,7 @@ modpath =
 VM_TARGETS := system/vm/assembler.go system/vm/disassembler.go
 $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h
 
-ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm
+ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm
 ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm
 srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
 $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go
@@ -391,6 +391,7 @@ NOCOMP_SOURCES =				\
   ice-9/match.upstream.scm			\
   ice-9/psyntax.scm				\
   ice-9/r6rs-libraries.scm			\
+  ice-9/r7rs-libraries.scm			\
   ice-9/quasisyntax.scm				\
   srfi/srfi-42/ec.scm				\
   srfi/srfi-64/testing.scm			\

module/ice-9/boot-9.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 1995-2014, 2016-2019  Free Software Foundation, Inc.
+;;;; Copyright (C) 1995-2014, 2016-2020  Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -3933,6 +3933,7 @@ but it fails to load."
              *unspecified*))))))
 
 (include-from-path "ice-9/r6rs-libraries")
+(include-from-path "ice-9/r7rs-libraries")
 
 (define-syntax-rule (define-private foo bar)
   (define foo bar))

module/ice-9/psyntax-pp.scm

@@ -3316,53 +3316,50 @@
                   "source expression failed to match any pattern"
                   tmp-1)))))))))
 
+(define call-with-include-port
+  (let ((syntax-dirname
+          (lambda (stx)
+            (letrec*
+              ((src (syntax-source stx))
+               (filename (if src (assq-ref src filename) #f)))
+              (if (string? filename) (dirname filename) #f)))))
+    (lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname))
+      "Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory.  Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames."
+      (let ((filename (syntax->datum filename)))
+        (let ((p (open-input-file
+                   (if (absolute-file-name? filename)
+                     filename
+                     (if dirname
+                       (in-vicinity dirname filename)
+                       (error "attempt to include relative file name but could not determine base dir"))))))
+          (let ((enc (file-encoding p)))
+            (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
+            (call-with-values
+              (lambda () (proc p))
+              (lambda results (close-port p) (apply values results)))))))))
+
 (define include
   (let ((make-syntax make-syntax))
     (make-syntax-transformer
       'include
       'macro
-      (lambda (x)
+      (lambda (stx)
-        (letrec*
+        (let ((tmp-1 stx))
-          ((read-file
+          (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
-             (lambda (fn dir k)
-               (let ((p (open-input-file
-                          (if (absolute-file-name? fn)
-                            fn
-                            (if dir
-                              (in-vicinity dir fn)
-                              (syntax-violation
-                                'include
-                                "relative file name only allowed when the include form is in a file"
-                                x))))))
-                 (let ((enc (file-encoding p)))
-                   (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
-                   (let f ((x (read p)) (result '()))
-                     (if (eof-object? x)
-                       (begin (close-port p) (reverse result))
-                       (f (read p) (cons (datum->syntax k x) result)))))))))
-          (let ((src (syntax-source x)))
-            (let ((file (if src (assq-ref src 'filename) #f)))
-              (let ((dir (if (string? file) (dirname file) #f)))
-                (let ((tmp-1 x))
-                  (let ((tmp ($sc-dispatch tmp-1 '(any any))))
             (if tmp
-                      (apply (lambda (k filename)
+              (apply (lambda (filename)
-                               (let ((fn (syntax->datum filename)))
+                       (call-with-include-port
-                                 (let ((tmp-1 (read-file fn dir filename)))
+                         filename
-                                   (let ((tmp ($sc-dispatch tmp-1 'each-any)))
+                         (lambda (p)
-                                     (if tmp
+                           (cons (make-syntax 'begin '((top)) '(hygiene guile))
-                                       (apply (lambda (exp)
+                                 (let lp ()
-                                                (cons (make-syntax 'begin '((top)) '(hygiene guile)) exp))
+                                   (let ((x (read p)))
+                                     (if (eof-object? x) '() (cons (datum->syntax filename x) (lp)))))))))
                      tmp)
               (syntax-violation
                 #f
                 "source expression failed to match any pattern"
-                                         tmp-1))))))
+                tmp-1))))))))
-                             tmp)
-                      (syntax-violation
-                        #f
-                        "source expression failed to match any pattern"
-                        tmp-1))))))))))))
 
 (define include-from-path
   (let ((make-syntax make-syntax))

module/ice-9/psyntax.scm

@@ -1,6 +1,6 @@
 ;;;; -*-scheme-*-
 ;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2019
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2020
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -3231,41 +3231,52 @@
         ;; Scheme code corresponding to the intermediate language forms.
         ((_ e) (emit (quasi #'e 0))))))) 
 
-(define-syntax include
+(define call-with-include-port
-  (lambda (x)
+  (let ((syntax-dirname (lambda (stx)
-    (define read-file
+                          (define src (syntax-source stx))
-      (lambda (fn dir k)
+                          (define filename (and src (assq-ref src filename)))
-        (let* ((p (open-input-file
+                          (and (string? filename)
-                   (cond ((absolute-file-name? fn)
+                               (dirname filename)))))
-                          fn)
+    (lambda* (filename proc #:key (dirname (syntax-dirname filename)))
-                         (dir
+      "Like @code{call-with-input-file}, except relative paths are
-                          (in-vicinity dir fn))
+searched relative to the @var{dirname} instead of the current working
+directory.  Also, @var{filename} can be a syntax object; in that case,
+and if @var{dirname} is not specified, the @code{syntax-source} of
+@var{filename} is used to obtain a base directory for relative file
+names."
+      (let* ((filename (syntax->datum filename))
+             (p (open-input-file
+                 (cond ((absolute-file-name? filename)
+                        filename)
+                       (dirname
+                        (in-vicinity dirname filename))
                        (else
-                          (syntax-violation
+                        (error
-                           'include
+                         "attempt to include relative file name but could not determine base dir")))))
-                           "relative file name only allowed when the include form is in a file"
-                           x)))))
              (enc (file-encoding p)))
 
         ;; Choose the input encoding deterministically.
         (set-port-encoding! p (or enc "UTF-8"))
 
-          (let f ((x (read p))
+        (call-with-values (lambda () (proc p))
-                  (result '()))
+          (lambda results
-            (if (eof-object? x)
-                (begin
             (close-port p)
-                  (reverse result))
+            (apply values results)))))))
-                (f (read p)
+
-                   (cons (datum->syntax k x) result)))))))
+(define-syntax include
-    (let* ((src (syntax-source x))
+  (lambda (stx)
-           (file (and src (assq-ref src 'filename)))
+    (syntax-case stx ()
-           (dir (and (string? file) (dirname file))))
+      ((_ filename)
-      (syntax-case x ()
+       (call-with-include-port
-        ((k filename)
+        #'filename
-         (let ((fn (syntax->datum #'filename)))
+        (lambda (p)
-           (with-syntax (((exp ...) (read-file fn dir #'filename)))
+          ;; In Guile, (cons #'a #'b) is the same as #'(a . b).
-             #'(begin exp ...))))))))
+          (cons #'begin
+                (let lp ()
+                  (let ((x (read p)))
+                    (if (eof-object? x)
+                        #'()
+                        (cons (datum->syntax #'filename x) (lp))))))))))))
 
 (define-syntax include-from-path
   (lambda (x)

module/ice-9/r7rs-libraries.scm

@@ -0,0 +1,105 @@
+;; R7RS library support
+;;      Copyright (C) 2020 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+;; This file is included from boot-9.scm and assumes the existence of (and
+;; expands into) procedures and syntactic forms defined therein.
+
+(define-syntax include-library-declarations
+  (lambda (x)
+    (syntax-violation
+     'include-library-declarations
+     "use of 'include-library-declarations' outside define-library" x x)))
+
+;; FIXME: Implement properly!
+(define-syntax-rule (include-ci filename)
+  (include filename))
+
+(define-syntax define-library
+  (lambda (stx)
+    (define (handle-includes filenames)
+      (syntax-case filenames ()
+        (() #'())
+        ((filename . filenames)
+         (append (call-with-include-port
+                  #'filename
+                  (lambda (p)
+                    (let lp ()
+                      (let ((x (read p)))
+                        (if (eof-object? x)
+                            #'()
+                            (cons (datum->syntax #'filename x) (lp)))))))
+                 (handle-includes #'filenames)))))
+
+    (define (handle-cond-expand clauses)
+      (define (has-req? req)
+        (syntax-case req (and or not library)
+          ((and req ...)
+           (and-map has-req? #'(req ...)))
+          ((or req ...)
+           (or-map has-req? #'(req ...)))
+          ((not req)
+           (not (has-req? #'req)))
+          ((library lib-name)
+           (->bool (resolve-interface (syntax->datum #'lib-name))))
+          (id
+           (identifier? #'id)
+           ;; FIXME: R7RS (features) isn't quite the same as
+           ;; %cond-expand-features; see scheme/base.scm.
+           (memq (syntax->datum #'id) %cond-expand-features))))
+      (syntax-case clauses ()
+        (() #'())  ; R7RS says this is not specified :-/
+        (((test decl ...) . clauses)
+         (if (has-req? #'test)
+             #'(decl ...)
+             (handle-cond-expand #'clauses)))))
+
+    (define (partition-decls decls exports imports code)
+      (syntax-case decls (export import begin include include-ci
+                                 include-library-declarations cond-expand)
+        (() (values exports imports (reverse code)))
+        (((export clause ...) . decls)
+         (partition-decls #'decls (append exports #'(clause ...)) imports code))
+        (((import clause ...) . decls)
+         (partition-decls #'decls exports (append imports #'(clause ...)) code))
+        (((begin expr ...) . decls)
+         (partition-decls #'decls exports imports
+                          (cons #'(begin expr ...) code)))
+        (((include filename ...) . decls)
+         (partition-decls #'decls exports imports
+                          (cons #'(begin (include filename) ...) code)))
+        (((include-ci filename ...) . decls)
+         (partition-decls #'decls exports imports
+                          (cons #'(begin (include-ci filename) ...) code)))
+        (((include-library-declarations filename ...) . decls)
+         (syntax-case (handle-includes #'(filename ...)) ()
+           ((decl ...)
+            (partition-decls #'(decl ... decls) exports imports code))))
+        (((cond-expand clause ...) . decls)
+         (syntax-case (handle-cond-expand #'(clause ...)) ()
+           ((decl ...)
+            (partition-decls #'(decl ... decls) exports imports code))))))
+
+    (syntax-case stx ()
+      ((_ name decl ...)
+       (call-with-values (lambda ()
+                           (partition-decls #'(decl ...) '() '() '()))
+         (lambda (exports imports code)
+           #`(library name
+               (export . #,exports)
+               (import . #,imports)
+               . #,code)))))))

module/scheme/base.scm

@@ -1,5 +1,5 @@
 ;;; R7RS compatibility libraries
-;;; Copyright (C) 2019 Free Software Foundation, Inc.
+;;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
 ;;;
 ;;; This library is free software: you can redistribute it and/or modify
 ;;; it under the terms of the GNU Lesser General Public License as
@@ -297,12 +297,11 @@
            #'(begin body ...)
            #'(r7:cond-expand more-clauses ...))))))
 
-(define-syntax-rule (r7:include k fn* ...)
+(define-syntax-rule (r7:include fn* ...)
-  (begin (include k fn*) ...))
+  (begin (include fn*) ...))
 
-;; FIXME
+(define-syntax-rule (r7:include-ci fn* ...)
-(define-syntax-rule (r7:include-ci k fn* ...)
+  (begin (include-ci fn*) ...))
-  (r7:include k fn* ...))
 
 (define-syntax-rule (r7:let-syntax ((vars trans) ...) . expr)
   (let-syntax ((vars trans) ...)
@@ -577,14 +576,11 @@ defaults to 0 and SEND defaults to the length of SOURCE."
 
 (define (features)
   (append
-   %cond-expand-features
    (case (native-endianness)
      ((big) '(big-endian))
      ((little) '(little-endian))
      (else '()))
-   '(r6rs
+   %cond-expand-features))
-     syntax-case
-     r7rs exact-closed ieee-float full-unicode ratios)))
 
 (define (input-port-open? port)
   (and (not (port-closed? port)) (input-port? port)))