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

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

_ is no opchar, identifiers may start with _, ruthlessly copied into tagdir

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