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

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

honu 2.2: fix tests and add another hack for prolog

File size: 6.2 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                     ((and (char=? c #\!) (eq? flavor 'prolog))
120                      (read-char port)
121                      (lnw '!))         ; special case for prolog - "!" is sort of punctuation
122                     ((opchar? c) (lnw (string->symbol (read-token opchar? port))))
123                     (else (err "invalid character" c)) ) ) ) ) ) )
124    (define (read-num)
125      (let ((base 10))
126        (string->number
127         (let ((e #f)
128               (d #f))
129           (let loop ((lst '()) (z? #f))
130             (let ((c (peek-char port)))
131               (case c 
132                 ((#\0)
133                  (when (null? lst) (set! base 8))
134                  (loop (cons (read-char port) lst)
135                        (null? lst)))
136                 ((#\x)
137                  (cond (z? (set! base 16)
138                            (read-char port)
139                            (loop '() #f))
140                        (else (reverse-list->string lst))))
141                 ((#\e #\E)
142                  (cond ((or e z?) (reverse-list->string lst))
143                        (else
144                         (set! e #t)
145                         (read-char port)
146                         (let ((c (peek-char port)))
147                           (case c
148                             ((#\+ #\-) (loop (cons (read-char port) (cons #\e lst)) #f))
149                             (else
150                              (if (char-numeric? c)
151                                  (loop (cons (read-char port) (cons #\e lst)) #f)
152                                  (reverse-list->string lst)) ) ) ) )))
153                 ((#!eof) (reverse-list->string lst))
154                 ((#\.)
155                  (cond ((or d z?) (reverse-list->string lst))
156                        (else
157                         (set! d #t)
158                         (loop (cons (read-char port) lst) #f))))
159                 (else
160                  (if (or (char-numeric? c)
161                          (case base
162                            ((16) (and (char-ci>=? c #\A)
163                                       (char-ci<=? c #\F)))
164                            (else #f)))
165                      (loop (cons (read-char port) lst) #f)
166                      (reverse-list->string lst) ) ) ) ) ) )
167         base)))
168    (define (read-escaped pred)
169      (##sys#read-from-string
170       (string-append
171        "\""
172        (with-output-to-string
173          (lambda ()
174            (let loop ()
175              (let ((c (read-char port)))
176                (cond ((eof-object? c) (err "unexpected end of character sequence"))
177                      ((pred c))
178                      ((char=? #\\ c)
179                       (write-char #\\)
180                       (write-char (read-char port))
181                       (loop) )
182                      (else
183                       (write-char c)
184                       (loop) ) ) ) ) ) )
185        "\"") ) )
186    (define (skip-comment)
187      (let ((c (read-char port)))
188        (case c
189          ((#!eof) (err "unexpected end of comment"))
190          ((#\newline)
191           (set! ln (fx+ ln 1))
192           (skip-comment) )
193          ((#\*)
194           (let loop ()
195             (case (read-char port)
196               ((#\newline)
197                (set! ln (fx+ ln 1))
198                (skip-comment) )
199               ((#\*) (loop))
200               ((#\/) #f) 
201               (else (skip-comment)) ) ))
202          ((#\/)
203           (case (read-char port)
204             ((#\newline)
205              (set! ln (fx+ ln 1))
206              (skip-comment) )
207             ((#\*) (skip-comment) (skip-comment))
208             (else (skip-comment)) ) )
209          (else (skip-comment)) ) ) )
210    (define (read-sequence tok del)
211      (cons
212       tok
213       (let loop ((lst '()))
214         (let ((s (skip)))
215           (if (and s (not (eof-object? s)))
216               (loop (cons s lst))
217               (let ((c (peek-char port)))
218                 (cond ((eof-object? c) (err "unexpected end of sequence"))
219                       ((char=? del c)
220                        (read-char port)
221                        (reverse lst) )
222                       (else (loop (cons (scan) lst))) ) ) ) ) ) ) )
223    (scan) ) )
224
225)
Note: See TracBrowser for help on using the repository browser.