mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Implement read-syntax

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2021-02-21 20:48:15 +01:00
parent 1bba859000
commit a04a024f20
4 changed files with 55 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

10
doc/ref/api-macros.texi
View file

@ -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

8
module/ice-9/psyntax-pp.scm
View file

@ -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)

8
module/ice-9/psyntax.scm
View file

@ -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

61
module/ice-9/read.scm
View file

@ -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,8 +734,7 @@
(define (read-expr ch)
(let ((line (port-line port))
(column (port-column port)))
(annotate
line
(annotate line
column
(if (zero? neoteric)
(read-expr* ch)
@ -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))