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 a04a024 Implement read-syntax
a04a024 is described below
commit a04a024f205e1e2cd04e80c1eece649acf6e2fa8
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Sun Feb 21 20:48:15 2021 +0100
Implement read-syntax
* doc/ref/api-macros.texi (Syntax Case): Update documentation for
datum->syntax.
* module/ice-9/psyntax.scm (datum->syntax): Use #:source keyword for
source location info instead of an optional, and allow an alist.
* module/ice-9/psyntax-pp.scm: Regenerate.
* module/ice-9/read.scm (%read, read): Refactor to allow read and
read-syntax to share an implementation.
(read-syntax): New function.
---
doc/ref/api-macros.texi | 10 +++----
module/ice-9/psyntax-pp.scm | 8 +++---
module/ice-9/psyntax.scm | 8 +++---
module/ice-9/read.scm | 69 +++++++++++++++++++++++++++------------------
4 files changed, 55 insertions(+), 40 deletions(-)
diff --git a/doc/ref/api-macros.texi b/doc/ref/api-macros.texi
index 7bcca7a..90cba24 100644
--- a/doc/ref/api-macros.texi
+++ b/doc/ref/api-macros.texi
@@ -638,18 +638,18 @@ won't have access to the binding of @code{it}.
But they can, if we explicitly introduce a binding via @code{datum->syntax}.
-@deffn {Scheme Procedure} datum->syntax template-id datum [srcloc]
+@deffn {Scheme Procedure} datum->syntax template-id datum [#:source=#f]
Create a syntax object that wraps @var{datum}, within the lexical
context corresponding to the identifier @var{template-id}. If
@var{template-id} is false, the datum will have no lexical context
information.
Syntax objects have an associated source location. @xref{Source
-Properties}. If a syntax object is passed as @var{srcloc}, the
-resulting syntax object will have the source properties of @var{srcloc}.
-Otherwise if @var{srcloc} is a source properties alist, those will be
+Properties}. If a syntax object is passed as @var{source}, the
+resulting syntax object will have the source properties of @var{source}.
+Otherwise if @var{source} is a source properties alist, those will be
the source properties of the resulting syntax object. Otherwise if
-@var{srcloc} is false, the source properties are computed as
+@var{source} is false, the source properties are computed as
@code{(source-properties @var{datum})}.
@end deffn
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index da14453..f0ee5eb 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2421,16 +2421,16 @@
(cons 'hygiene (module-name (current-module))))))
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
- (lambda* (id datum #:optional (srcloc #f))
+ (lambda* (id datum #:key (source #f #:source))
(make-syntax
datum
(if id (syntax-wrap id) '((top)))
(if id
(syntax-module id)
(cons 'hygiene (module-name (current-module))))
- (cond ((not srcloc) (source-properties datum))
- ((and (list? srcloc) (and-map pair? srcloc)) srcloc)
- (else (syntax-source srcloc))))))
+ (cond ((not source) (source-properties datum))
+ ((and (list? source) (and-map pair? source)) source)
+ (else (syntax-source source))))))
(set! syntax->datum (lambda (x) (strip x '(()))))
(set! generate-temporaries
(lambda (ls)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index c5c85fd..061beb9 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -2763,7 +2763,7 @@
(nonsymbol-id? x)))
(set! datum->syntax
- (lambda* (id datum #:optional srcloc)
+ (lambda* (id datum #:key source)
(make-syntax datum
(if id
(syntax-wrap id)
@@ -2772,9 +2772,9 @@
(syntax-module id)
(cons 'hygiene (module-name (current-module))))
(cond
- ((not srcloc) (source-properties datum))
- ((and (list? srcloc) (and-map pair? srcloc)) srcloc)
- (else (syntax-source srcloc))))))
+ ((not source) (source-properties datum))
+ ((and (list? source) (and-map pair? source)) source)
+ (else (syntax-source source))))))
(set! syntax->datum
;; accepts any object, since syntax objects may consist partially
diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm
index 9683744..5b375e1 100644
--- a/module/ice-9/read.scm
+++ b/module/ice-9/read.scm
@@ -43,7 +43,8 @@
#:use-module (srfi srfi-11)
#:use-module (ice-9 textual-ports)
#:use-module (rnrs bytevectors)
- #:replace (read))
+ #:replace (read)
+ #:export (read-syntax))
(define read-hash-procedures
(fluid->parameter %read-hash-procedures))
@@ -110,7 +111,7 @@
read-options-inherit-all)
field value)))
-(define* (read #:optional (port (current-input-port)))
+(define (%read port annotate strip-annotation)
;; init read options
(define opts (compute-reader-options port))
(define (enabled? field)
@@ -118,7 +119,6 @@
(define (set-reader-option! field value)
(set! opts (set-option opts field value))
(set-port-read-option! port field value))
- (define (record-positions?) (enabled? bitfield:record-positions?))
(define (case-insensitive?) (enabled? bitfield:case-insensitive?))
(define (keyword-style) (logand read-option-mask
(ash opts (- bitfield:keyword-style))))
@@ -134,21 +134,6 @@
(define (get-pos) (cons (port-line port) (port-column port)))
;; We are only ever interested in whether an object is a char or not.
(define (eof-object? x) (not (char? x)))
- (define (annotate line column datum)
- ;; FIXME: Return a syntax object instead, so we can avoid the
- ;; srcprops side table.
- (when (and (record-positions?)
- (supports-source-properties? datum)
- ;; Line or column can be invalid via set-port-column! or
- ;; ungetting chars beyond start of line.
- (<= 0 line)
- (<= 1 column))
- ;; We always capture the column after one char of lookahead;
- ;; subtract off that lookahead value.
- (set-source-properties! datum `((filename . ,filename)
- (line . ,line)
- (column . ,(1- column)))))
- datum)
(define (input-error msg args)
(scm-error 'read-error #f
@@ -248,7 +233,7 @@
;; Note that it is possible for scm_read_expression to
;; return `.', but not as part of a dotted pair: as in
;; #{.}#. Indeed an example is here!
- (if (and (eqv? ch #\.) (eq? expr '#{.}#))
+ (if (and (eqv? ch #\.) (eq? (strip-annotation expr) '#{.}#))
(let* ((tail (read-expr (next-non-whitespace)))
(close (next-non-whitespace)))
(unless (eqv? close rdelim)
@@ -481,7 +466,7 @@
(let ((ch (next-non-whitespace)))
(when (eof-object? ch)
(error "end of input while reading keyword"))
- (let ((expr (read-expr ch)))
+ (let ((expr (strip-annotation (read-expr ch))))
(unless (symbol? expr)
(error "keyword prefix #: not followed by a symbol: ~a" expr))
(symbol->keyword expr))))
@@ -716,7 +701,7 @@
(let ((ch (next-non-whitespace)))
(when (eof-object? ch)
(error "unexpected end of input while reading :keyword"))
- (symbol->keyword (read-expr ch)))
+ (symbol->keyword (strip-annotation (read-expr ch))))
(read-mixed-case-symbol ch)))
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\+ #\- #\.)
(read-number ch))
@@ -749,12 +734,11 @@
(define (read-expr ch)
(let ((line (port-line port))
(column (port-column port)))
- (annotate
- line
- column
- (if (zero? neoteric)
- (read-expr* ch)
- (read-neoteric ch)))))
+ (annotate line
+ column
+ (if (zero? neoteric)
+ (read-expr* ch)
+ (read-neoteric ch)))))
(define (read-directive)
(let ((ch (next)))
@@ -871,3 +855,34 @@
(if (eof-object? ch)
ch
(read-expr ch))))
+
+(define* (read #:optional (port (current-input-port)))
+ (define filename (port-filename port))
+ (define annotate
+ (if (memq 'positions (read-options))
+ (lambda (line column datum)
+ (when (and (supports-source-properties? datum)
+ ;; Line or column can be invalid via
+ ;; set-port-column! or ungetting chars beyond start
+ ;; of line.
+ (<= 0 line)
+ (<= 1 column))
+ ;; We always capture the column after one char of lookahead;
+ ;; subtract off that lookahead value.
+ (set-source-properties! datum
+ `((filename . ,filename)
+ (line . ,line)
+ (column . ,(1- column)))))
+ datum)
+ identity))
+ (%read port annotate identity))
+
+(define* (read-syntax #:optional (port (current-input-port)))
+ (define filename (port-filename port))
+ (define (annotate line column datum)
+ (datum->syntax #f ; No lexical context.
+ datum
+ #:source `((filename . ,filename)
+ (line . ,line)
+ (column . ,(1- column)))))
+ (%read port annotate syntax->datum))
