[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] branch master updated: Support R7RS define-library
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] branch master updated: Support R7RS define-library |
|
Date: |
Sun, 12 Jan 2020 14:32:03 -0500 |
This is an automated email from the git hooks/post-receive script.
wingo pushed a commit to branch master
in repository guile.
The following commit(s) were added to refs/heads/master by this push:
new fd2ffc6 Support R7RS define-library
fd2ffc6 is described below
commit fd2ffc649c2d08639c2ac41c25e4ebdbeb4b151d
Author: Andy Wingo <address@hidden>
AuthorDate: Sun Jan 12 20:14:30 2020 +0100
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 | 6 +++
module/Makefile.am | 5 +-
module/ice-9/boot-9.scm | 3 +-
module/ice-9/psyntax-pp.scm | 81 +++++++++++++++----------------
module/ice-9/psyntax.scm | 81 +++++++++++++++++--------------
module/ice-9/r7rs-libraries.scm | 105 ++++++++++++++++++++++++++++++++++++++++
module/scheme/base.scm | 16 +++---
7 files changed, 207 insertions(+), 90 deletions(-)
diff --git a/NEWS b/NEWS
index 97ad2ea..16ebc64 100644
--- a/NEWS
+++ b/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):
diff --git a/module/Makefile.am b/module/Makefile.am
index c6dff76..3586ad5 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 b602de2..5d7df5e 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 167e15c..ca9a0da 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 902ecea..0c5082d 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 0000000..6db9de8
--- /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 aec90d2..5a366f8 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)))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] branch master updated: Support R7RS define-library,
Andy Wingo <=