1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
#lang racket/base
;; Provides raise-read-error and raise-read-eof-error
(require syntax/readerr)
(require "private/syntax-properties.rkt")
(define (skip-whitespace port)
;; Skips whitespace characters, sensitive to the current
;; readtable's definition of whitespace
(let ([ch (peek-char port)])
(unless (eof-object? ch)
;; Consult current readtable:
(let-values ([(like-ch/sym proc dispatch-proc)
(readtable-mapping (current-readtable) ch)])
;; If like-ch/sym is whitespace, then ch is whitespace
(when (and (char? like-ch/sym)
(char-whitespace? like-ch/sym))
(read-char port)
(skip-whitespace port))))))
(define (skip-comments read-one port src)
;; Recursive read, but skip comments and detect EOF
(let loop ()
(let ([v (read-one)])
(cond
[(special-comment? v) (loop)]
[(eof-object? v)
(let-values ([(l c p) (port-next-location port)])
(raise-read-eof-error "unexpected EOF in type annotation" src l c p 1))]
[else v]))))
(define (parse port read-one src)
(skip-whitespace port)
(let ([name (read-one)])
(begin0
(begin (skip-whitespace port)
(let ([next (read-one)])
(case (syntax-e next)
;; type annotation
[(:) (skip-whitespace port)
(type-label-property name (syntax->datum (read-one)))]
[(::) (skip-whitespace port)
(datum->syntax name `(ann ,name : ,(read-one)))]
[(@) (let ([elems (let loop ([es '()])
(skip-whitespace port)
(if (equal? #\} (peek-char port))
(reverse es)
(loop (cons (read-one) es))))])
(datum->syntax name `(inst ,name : ,@elems)))]
;; arbitrary property annotation
[(PROP) (skip-whitespace port)
(let* ([prop-name (syntax-e (read-one))])
(skip-whitespace port)
(syntax-property name prop-name (read-one)))]
;; otherwise error
[else
(let-values ([(l c p) (port-next-location port)])
(raise-read-error (format "typed expression ~a must be followed by :, ::, or @"
(syntax->datum name)) src l c p 1))])))
(skip-whitespace port)
(let ([c (read-char port)])
(unless (equal? #\} c)
(let-values ([(l c p) (port-next-location port)])
(raise-read-error (format "typed expression ~a not properly terminated" (syntax->datum name)) src l c p 1)))))))
(define parse-id-type
(case-lambda
[(ch port src line col pos)
;; `read-syntax' mode
(datum->syntax
#f
(parse port
(lambda () (read-syntax src port ))
src)
(let-values ([(l c p) (port-next-location port)])
(list src line col pos (and pos (- p pos)))))]))
(define (readtable)
(make-readtable (current-readtable) #\{ 'dispatch-macro parse-id-type))
(define (*read inp)
(parameterize ([current-readtable (readtable)])
(read inp)))
(define (*read-syntax src port)
(parameterize ([current-readtable (readtable)])
(read-syntax src port)))
(provide readtable (rename-out [*read read] [*read-syntax read-syntax]))
|
