source: project/release/4/honu/trunk/honu.scm @ 25847

Last change on this file since 25847 was 25847, checked in by felix winkelmann, 9 years ago

allow @ as operator char

File size: 5.3 KB
Line 
1;;;; honu.scm
2
3
4(module honu (read-honu)
5
6(import scheme chicken)
7(use extras ports data-structures)
8
9
10(define-constant +operator-chars+
11  '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^ #\\ #\@) )
12
13(define (read-honu #!optional (port (current-input-port)) line-numbers lnwrap)
14  (let ((ln (nth-value 0 (port-position port))))
15    (define (lnw x)
16      (if lnwrap (lnwrap x ln) x))
17    (define (err msg . args)
18      (apply
19       error 'read-honu
20       (string-append msg (if line-numbers (conc " in line " ln) "")) args) )
21    (define (opchar? c) (memq c +operator-chars+))
22    (define (skip)
23      (let ((c (peek-char port)))
24        (cond ((eof-object? c) c)
25              ((char=? #\newline c)
26               (set! ln (fx+ ln 1)) 
27               (read-char port)
28               (skip) )
29              ((char-whitespace? c)
30               (read-char port)
31               (skip) )
32              ((char=? #\/ c)
33               (read-char port)
34               (let ((c (peek-char port)))
35                 (case c
36                   ((#\/) 
37                    (read-line port)
38                    (set! ln (fx+ ln 1))
39                    (skip) )
40                   ((#\*) (skip-comment) (skip))
41                   (else
42                    (if (opchar? c)
43                        (let ((s (read-token opchar? port)))
44                          (string->symbol (string-append "/" s) ) )
45                        (lnw '/) ) ) ) ) )
46              (else #f) ) ) )
47    (define (scan)
48      (or (skip)
49          (let ((c (peek-char port)))
50            (case c
51              ((#!eof) (err "unexpected end of input"))
52              ((#\#)
53               (read-char port)
54               (let ((c (peek-char port)))
55                 (case c
56                   ((#\;)
57                    (read-char port)
58                    (let* ((x1 (scan))
59                           (x2 (scan)) )
60                      (if x1
61                          x2
62                          (scan) ) ) )
63                   (else
64                    (let ((t (read-token char-alphabetic? port)))
65                      (cond ((string=? "hx" t) (scan))
66                            ((string=? "sx" t) (read port)) 
67                            (else (err "invalid escape syntax" (conc "#" t))) ) ) ) ) ) )
68              ((#\') 
69               (read-char port)
70               (let ((s (read-escaped (lambda (c) (char=? #\' c)))))
71                 (if (zero? (string-length s))
72                     (err "empty character literal")
73                     (lnw (string-ref s 0) ) ) ) )
74              ((#\,) (read-char port) (lnw '|,|))
75              ((#\;) (read-char port) (lnw '|;|))
76              ((#\") (read-char port) (lnw (read-escaped (lambda (c) (char=? #\" c)))))
77              ((#\() (read-char port) (lnw (read-sequence '#%parens #\))))
78              ((#\[) (read-char port) (lnw (read-sequence '#%brackets #\])))
79              ((#\{) (read-char port) (lnw (read-sequence '#%braces #\})))
80              ((#\) #\] #\}) (err (sprintf "unexpected closing `~a'" c)))
81              (else
82               (cond ((char-numeric? c) (lnw (read-num)))
83                     ((char-alphabetic? c) 
84                      (lnw
85                       (string->symbol
86                        (read-token
87                         (lambda (c)
88                           (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
89                         port) ) ))
90                     ((opchar? c) (lnw (string->symbol (read-token opchar? port))))
91                     (else (err "invalid character" c)) ) ) ) ) ) )
92    (define (read-num)
93      (let ((base 10))
94        (string->number
95         (let ((e #f)
96               (d #f))
97           (let loop ((lst '()) (z? #f))
98             (let ((c (peek-char port)))
99               (case c 
100                 ((#\0)
101                  (when (null? lst) (set! base 8))
102                  (loop (cons (read-char port) lst)
103                        (null? lst)))
104                 ((#\x)
105                  (cond (z? (set! base 16)
106                            (read-char port)
107                            (loop '() #f))
108                        (else (reverse-list->string lst))))
109                 ((#\e #\E)
110                  (cond ((or e z?) (reverse-list->string lst))
111                        (else
112                         (set! e #t)
113                         (read-char port)
114                         (let ((c (peek-char port)))
115                           (case c
116                             ((#\+ #\-) (loop (cons (read-char port) (cons #\e lst)) #f))
117                             (else
118                              (if (char-numeric? c)
119                                  (loop (cons (read-char port) (cons #\e lst)) #f)
120                                  (reverse-list->string lst)) ) ) ) )))
121                 ((#!eof) (reverse-list->string lst))
122                 ((#\.)
123                  (cond ((or d z?) (reverse-list->string lst))
124                        (else
125                         (set! d #t)
126                         (loop (cons (read-char port) lst) #f))))
127                 (else
128                  (if (or (char-numeric? c)
129                          (case base
130                            ((16) (and (char-ci>=? c #\A)
131                                       (char-ci<=? c #\F)))
132                            (else #f)))
133                      (loop (cons (read-char port) lst) #f)
134                      (reverse-list->string lst) ) ) ) ) ) )
135         base)))
136    (define (read-escaped pred)
137      (##sys#read-from-string
138       (string-append
139        "\""
140        (with-output-to-string
141          (lambda ()
142            (let loop ()
143              (let ((c (read-char port)))
144                (cond ((eof-object? c) (err "unexpected end of character sequence"))
145                      ((pred c))
146                      ((char=? #\\ c)
147                       (write-char #\\)
148                       (write-char (read-char port))
149                       (loop) )
150                      (else
151                       (write-char c)
152                       (loop) ) ) ) ) ) )
153        "\"") ) )
154    (define (skip-comment)
155      (let ((c (read-char port)))
156        (case c
157          ((#!eof) (err "unexpected end of comment"))
158          ((#\newline)
159           (set! ln (fx+ ln 1))
160           (skip-comment) )
161          ((#\*)
162           (let loop ()
163             (case (read-char port)
164               ((#\newline)
165                (set! ln (fx+ ln 1))
166                (skip-comment) )
167               ((#\*) (loop))
168               ((#\/) #f) 
169               (else (skip-comment)) ) ))
170          ((#\/)
171           (case (read-char port)
172             ((#\newline)
173              (set! ln (fx+ ln 1))
174              (skip-comment) )
175             ((#\*) (skip-comment) (skip-comment))
176             (else (skip-comment)) ) )
177          (else (skip-comment)) ) ) )
178    (define (read-sequence tok del)
179      (cons
180       tok
181       (let loop ((lst '()))
182         (let ((s (skip)))
183           (if (and s (not (eof-object? s)))
184               (loop (cons s lst))
185               (let ((c (peek-char port)))
186                 (cond ((eof-object? c) (err "unexpected end of sequence"))
187                       ((char=? del c)
188                        (read-char port)
189                        (reverse lst) )
190                       (else (loop (cons (scan) lst))) ) ) ) ) ) ) )
191    (scan) ) )
192
193)
Note: See TracBrowser for help on using the repository browser.