diff options
author | Andy Wingo <wingo@pobox.com> | 2020-01-12 20:14:30 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2020-01-12 20:31:47 +0100 |
commit | fd2ffc649c2d08639c2ac41c25e4ebdbeb4b151d (patch) | |
tree | 6597b90a6cdc77d949608b379c9a9c493e3daf69 | |
parent | 639d0b37687d0cc66202b1d6e60286c843fb3ffd (diff) | |
download | guile-fd2ffc649c2d08639c2ac41c25e4ebdbeb4b151d.tar.gz |
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.
-rw-r--r-- | NEWS | 6 | ||||
-rw-r--r-- | module/Makefile.am | 5 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 3 | ||||
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 81 | ||||
-rw-r--r-- | module/ice-9/psyntax.scm | 81 | ||||
-rw-r--r-- | module/ice-9/r7rs-libraries.scm | 105 | ||||
-rw-r--r-- | module/scheme/base.scm | 16 |
7 files changed, 207 insertions, 90 deletions
@@ -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): diff --git a/module/Makefile.am b/module/Makefile.am index c6dff76e3..3586ad505 100644 --- a/module/Makefile.am +++ b/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 \ diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index b602de228..5d7df5edd 100644 --- a/module/ice-9/boot-9.scm +++ b/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)) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 167e15c4e..ca9a0da56 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/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) - (letrec* - ((read-file - (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) - (let ((fn (syntax->datum filename))) - (let ((tmp-1 (read-file fn dir filename))) - (let ((tmp ($sc-dispatch tmp-1 'each-any))) - (if tmp - (apply (lambda (exp) - (cons (make-syntax 'begin '((top)) '(hygiene guile)) exp)) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))))))))) + (lambda (stx) + (let ((tmp-1 stx)) + (let ((tmp ($sc-dispatch tmp-1 '(_ any)))) + (if tmp + (apply (lambda (filename) + (call-with-include-port + filename + (lambda (p) + (cons (make-syntax 'begin '((top)) '(hygiene guile)) + (let lp () + (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)))))))) (define include-from-path (let ((make-syntax make-syntax)) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 902eceaf9..0c5082d73 100644 --- a/module/ice-9/psyntax.scm +++ b/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 call-with-include-port + (let ((syntax-dirname (lambda (stx) + (define src (syntax-source stx)) + (define filename (and src (assq-ref src filename))) + (and (string? filename) + (dirname filename))))) + (lambda* (filename proc #:key (dirname (syntax-dirname filename))) + "Like @code{call-with-input-file}, except relative paths are +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 + (error + "attempt to include relative file name but could not determine base dir"))))) + (enc (file-encoding p))) + + ;; Choose the input encoding deterministically. + (set-port-encoding! p (or enc "UTF-8")) + + (call-with-values (lambda () (proc p)) + (lambda results + (close-port p) + (apply values results))))))) + (define-syntax include - (lambda (x) - (define read-file - (lambda (fn dir k) - (let* ((p (open-input-file - (cond ((absolute-file-name? fn) - fn) - (dir - (in-vicinity dir fn)) - (else - (syntax-violation - 'include - "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)) - (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)) - (file (and src (assq-ref src 'filename))) - (dir (and (string? file) (dirname file)))) - (syntax-case x () - ((k filename) - (let ((fn (syntax->datum #'filename))) - (with-syntax (((exp ...) (read-file fn dir #'filename))) - #'(begin exp ...)))))))) + (lambda (stx) + (syntax-case stx () + ((_ filename) + (call-with-include-port + #'filename + (lambda (p) + ;; In Guile, (cons #'a #'b) is the same as #'(a . b). + (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) diff --git a/module/ice-9/r7rs-libraries.scm b/module/ice-9/r7rs-libraries.scm new file mode 100644 index 000000000..6db9de873 --- /dev/null +++ b/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))))))) diff --git a/module/scheme/base.scm b/module/scheme/base.scm index aec90d231..5a366f846 100644 --- a/module/scheme/base.scm +++ b/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* ...) - (begin (include k fn*) ...)) +(define-syntax-rule (r7:include fn* ...) + (begin (include fn*) ...)) -;; FIXME -(define-syntax-rule (r7:include-ci k fn* ...) - (r7:include k fn* ...)) +(define-syntax-rule (r7:include-ci fn* ...) + (begin (include-ci 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 - syntax-case - r7rs exact-closed ieee-float full-unicode ratios))) + %cond-expand-features)) (define (input-port-open? port) (and (not (port-closed? port)) (input-port? port))) |