[Guile-commits] 07/07: Read-in-scheme replaces boot "read" definition

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 8edf1dc6231eb7b574cc63176e55ac25c0e71330
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Mar 2 21:54:42 2021 +0100

    Read-in-scheme replaces boot "read" definition
    
    Instead of defining a separate module, given that "read" calls are quite
    all over the place, we're just going to replace the boot "read" binding
    with read.scm.  This way, we'll be able to remove support for reader
    options in the boot reader, as it will only ever be used for a finite
    set of files.
    
    * NEWS: Update.
    * module/Makefile.am (ice-9/boot-9.go): Depend on read.scm.
    (SOURCES):
    * am/bootstrap.am (SOURCES): Don't build a ice-9/read.go, as we include
    it.
    * module/ice-9/boot-9.scm (read-syntax): Define here, as "include" now
    uses it.
    (read-hash-procedures, read-hash-procedure, read-hash-extend): New
    procedures.  Will replace C variants.
    (read, read-syntax): Include read.scm to define these.
    * module/ice-9/psyntax-pp.scm (include): Regenerate.
    * module/ice-9/psyntax.scm (include): Use read-syntax, so we get better
    source information.
    * module/ice-9/read.scm (let*-values): New local definition, to avoid
    loading srfi-11.
    (%read): Use list->typed-array instead of u8-list->bytevector.
    * module/language/scheme/spec.scm: Remove (ice-9 read) import;
    read-syntax is there in the boot environment
---
 NEWS                              |  2 +-
 am/bootstrap.am                   |  1 -
 module/Makefile.am                |  3 +--
 module/ice-9/boot-9.scm           | 33 +++++++++++++++++++++++++++++++++
 module/ice-9/psyntax-pp.scm       |  2 +-
 module/ice-9/psyntax.scm          |  2 +-
 module/ice-9/read.scm             | 35 ++++++++++++-----------------------
 module/language/scheme/spec.scm   |  3 +--
 test-suite/tests/bytevectors.test |  6 +++---
 test-suite/tests/chars.test       |  9 +++------
 test-suite/tests/reader.test      | 12 ++++++------
 11 files changed, 62 insertions(+), 46 deletions(-)

diff --git a/NEWS b/NEWS
index c42896a..54cee9a 100644
--- a/NEWS
+++ b/NEWS
@@ -109,7 +109,7 @@ See the newly reorganized "Foreign Function Interface", for 
details.
 These new interfaces replace `dynamic-link', `dynamic-pointer' and
 similar, which will eventually be deprecated.
 
-** `read-syntax' and the `(ice-9 read)' module
+** `read-syntax'
 ** `syntax-sourcev'
 ** `quote-syntax'
 
diff --git a/am/bootstrap.am b/am/bootstrap.am
index 2f5804f..acc00c7 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -102,7 +102,6 @@ SOURCES =                                   \
   ice-9/match.scm                              \
   ice-9/networking.scm                         \
   ice-9/posix.scm                              \
-  ice-9/read.scm                               \
   ice-9/rdelim.scm                             \
   ice-9/receive.scm                            \
   ice-9/regex.scm                              \
diff --git a/module/Makefile.am b/module/Makefile.am
index 516fb3a..b836812 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -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/r7rs-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/read.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
@@ -146,7 +146,6 @@ SOURCES =                                   \
   ice-9/q.scm                                  \
   ice-9/r5rs.scm                               \
   ice-9/rdelim.scm                             \
-  ice-9/read.scm                               \
   ice-9/receive.scm                            \
   ice-9/regex.scm                              \
   ice-9/runq.scm                               \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index f49516d..126459d 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -375,6 +375,13 @@ If returning early, return the return value of F."
 (define (resolve-module . args)
   #f)
 
+;; The definition of "include" needs read-syntax.  Replaced later.
+(define (read-syntax port)
+  (let ((datum (read port)))
+    (if (eof-object? datum)
+        datum
+        (datum->syntax #f datum))))
+
 ;; API provided by psyntax
 (define syntax-violation #f)
 (define datum->syntax #f)
@@ -2216,6 +2223,19 @@ name extensions listed in %load-extensions."
 ;;; Reader code for various "#c" forms.
 ;;;
 
+(define read-hash-procedures
+  (fluid->parameter %read-hash-procedures))
+
+(define (read-hash-procedure ch)
+  (assq-ref (read-hash-procedures) ch))
+
+(define (read-hash-extend ch proc)
+  (let ((alist (read-hash-procedures)))
+    (read-hash-procedures
+     (if proc
+         (assq-set! alist ch proc)
+         (assq-remove! alist ch)))))
+
 (define read-eval? (make-fluid #f))
 (read-hash-extend #\.
                   (lambda (c port)
@@ -4621,6 +4641,19 @@ R7RS."
 
 
 
+;;; {`read' implementation in Scheme.}
+;;;
+;;;
+
+(call-with-values (lambda ()
+                    (include-from-path "ice-9/read.scm")
+                    (values read read-syntax))
+  (lambda (read* read-syntax*)
+    (set! read read*)
+    (set! read-syntax read-syntax*)))
+
+
+
 ;;; {Threads}
 ;;;
 
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 1e30a98..554ae0e 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -3428,7 +3428,7 @@
                          (lambda (p)
                            (cons (make-syntax 'begin '((top)) '(hygiene guile))
                                  (let lp ()
-                                   (let ((x (read p)))
+                                   (let ((x (read-syntax p)))
                                      (if (eof-object? x) '() (cons 
(datum->syntax filename x) (lp)))))))))
                      tmp)
               (syntax-violation
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 57ac6a6..b52bb39 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -3267,7 +3267,7 @@ names."
           ;; In Guile, (cons #'a #'b) is the same as #'(a . b).
           (cons #'begin
                 (let lp ()
-                  (let ((x (read p)))
+                  (let ((x (read-syntax p)))
                     (if (eof-object? x)
                         #'()
                         (cons (datum->syntax #'filename x) (lp))))))))))))
diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm
index 7ce4b41..7f79bf9 100644
--- a/module/ice-9/read.scm
+++ b/module/ice-9/read.scm
@@ -39,24 +39,12 @@
 ;; #@-(1 2 3) => #(1 2 3)
 ;; (#*10101010102) => (#*1010101010 2)
 
-(define-module (ice-9 read)
-  #:use-module (srfi srfi-11)
-  #:use-module (rnrs bytevectors)
-  #:replace (read)
-  #:export (read-syntax))
-
-(define read-hash-procedures
-  (fluid->parameter %read-hash-procedures))
-
-(define (read-hash-procedure ch)
-  (assq-ref (read-hash-procedures) ch))
-
-(define (read-hash-extend ch proc)
-  (let ((alist (read-hash-procedures)))
-    (read-hash-procedures
-     (if proc
-         (assq-set! alist ch proc)
-         (assq-remove! alist ch)))))
+(define-syntax let*-values
+  (syntax-rules ()
+    ((_ () . body) (let () . body))
+    ((_ ((vars expr) . binds) . body)
+     (call-with-values (lambda () expr)
+       (lambda vars (let*-values binds . body))))))
 
 (define bitfield:record-positions? 0)
 (define bitfield:case-insensitive? 2)
@@ -437,7 +425,8 @@
     (expect #\u)
     (expect #\8)
     (expect #\()
-    (u8-list->bytevector (map strip-annotation (read-parenthesized #\)))))
+    (list->typed-array 'vu8 1
+                       (map strip-annotation (read-parenthesized #\)))))
 
   ;; FIXME: We should require a terminating delimiter.
   (define (read-bitvector)
@@ -478,9 +467,9 @@
         (and (not (eof-object? ch))
              (let ((digit (- (char->integer ch) (char->integer #\0))))
                (and (<= 0 digit 9) digit))))
-      (let-values (((sign ch) (if (eqv? ch #\-)
-                                  (values -1 (next))
-                                  (values 1 ch))))
+      (let*-values (((sign ch) (if (eqv? ch #\-)
+                                   (values -1 (next))
+                                   (values 1 ch))))
         (let lp ((ch ch) (res #f))
           (cond
            ((decimal-digit ch)
@@ -489,7 +478,7 @@
            (else
             (values ch (if res (* res sign) alt)))))))
     (define (read-rank ch)
-      (let-values (((ch rank) (read-decimal-integer ch 1)))
+      (let*-values (((ch rank) (read-decimal-integer ch 1)))
         (when (< rank 0)
           (error "array rank must be non-negative"))
         (when (eof-object? ch)
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index b150053..18af552 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -1,6 +1,6 @@
 ;;; Guile Scheme specification
 
-;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012, 2021 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
@@ -21,7 +21,6 @@
 (define-module (language scheme spec)
   #:use-module (system base compile)
   #:use-module (system base language)
-  #:use-module (ice-9 read)
   #:use-module (language scheme compile-tree-il)
   #:use-module (language scheme decompile-tree-il)
   #:export (scheme))
diff --git a/test-suite/tests/bytevectors.test 
b/test-suite/tests/bytevectors.test
index 5d4568d..9ae040f 100644
--- a/test-suite/tests/bytevectors.test
+++ b/test-suite/tests/bytevectors.test
@@ -1,6 +1,6 @@
 ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; 
-*-
 ;;;;
-;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2015, 2018, 2021 Free Software Foundation, Inc.
 ;;;;
 ;;;; Ludovic Courtès
 ;;;;
@@ -645,11 +645,11 @@
     (with-input-from-string "#vu8 (1 2 3)" read))
 
   (pass-if-exception "negative integers"
-    exception:wrong-type-arg
+    exception:out-of-range
     (with-input-from-string "#vu8(-1 -2 -3)" read))
 
   (pass-if-exception "out-of-range integers"
-    exception:wrong-type-arg
+    exception:out-of-range
     (with-input-from-string "#vu8(0 256)" read)))
 
 
diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test
index 55cfead..0a3b314 100644
--- a/test-suite/tests/chars.test
+++ b/test-suite/tests/chars.test
@@ -1,7 +1,7 @@
 ;;;; chars.test --- Characters.       -*- coding: utf-8; mode: scheme; -*-
 ;;;; Greg J. Badros <gjb@cs.washington.edu>
 ;;;;
-;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2000, 2006, 2009, 2010, 2013, 2021 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
@@ -25,9 +25,6 @@
 (define exception:unknown-character-name
   (cons #t "unknown character"))
 
-(define exception:out-of-range-octal
-  (cons #t "out-of-range"))
-
 
 (with-test-prefix "basic char handling"
 
@@ -237,11 +234,11 @@
       (integer->char #x110000))
 
     (pass-if-exception "octal out of range, surrrogate" 
-                       exception:out-of-range-octal
+                       exception:out-of-range
       (with-input-from-string "#\\154000" read))
 
     (pass-if-exception "octal out of range, too big" 
-                       exception:out-of-range-octal
+                       exception:out-of-range
       (with-input-from-string "#\\4200000" read)))
 
   (with-test-prefix "case"
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index ef11a4a..203d406 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,6 @@
 ;;;; reader.test --- Reader test.    -*- coding: iso-8859-1; mode: scheme -*-
 ;;;;
-;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020
+;;;; Copyright (C) 1999,2001-2003,2007-2011,2013-2015,2020,2021
 ;;;;   Free Software Foundation, Inc.
 ;;;;
 ;;;; Jim Blandy <jimb@red-bean.com>
@@ -25,7 +25,7 @@
 
 
 (define exception:eof
-  (cons 'read-error "end of file$"))
+  (cons 'read-error "unexpected end of input"))
 (define exception:unexpected-rparen
   (cons 'read-error "unexpected \")\"$"))
 (define exception:unexpected-rsqbracket
@@ -37,9 +37,9 @@
 (define exception:unknown-sharp-object
   (cons 'read-error "Unknown # object: .*$"))
 (define exception:eof-in-string
-  (cons 'read-error "end of file in string constant$"))
+  (cons 'read-error "end of input while reading string$"))
 (define exception:eof-in-symbol
-  (cons 'read-error "end of file while reading symbol$"))
+  (cons 'read-error "end of input while reading symbol$"))
 (define exception:invalid-escape
   (cons 'read-error "invalid character in escape sequence: .*$"))
 (define exception:missing-expression
@@ -174,10 +174,10 @@
   (pass-if "square brackets are parens"
     (equal? '() (read-string "[]")))
 
-  (pass-if-exception "paren mismatch" exception:unexpected-rparen
+  (pass-if-exception "paren mismatch" exception:mismatched-paren
                      (read-string "'[)"))
 
-  (pass-if-exception "paren mismatch (2)" exception:unexpected-rsqbracket
+  (pass-if-exception "paren mismatch (2)" exception:mismatched-paren
                      (read-string "'(]"))
 
   (pass-if-exception "paren mismatch (3)" exception:mismatched-paren