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

Last change on this file since 22662 was 22662, checked in by felix winkelmann, 10 years ago

honu: 1.7, fixed comment handling

File size: 4.8 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) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
88                         port) ) ))
89                     ((opchar? c) (lnw (string->symbol (read-token opchar? port))))
90                     (else (err "invalid character" c)) ) ) ) ) ) )
91    (define (read-num)
92      (string->number
93       (let ((e #f)
94             (d #f))
95         (let loop ((lst '()))
96           (let ((c (peek-char port)))
97             (case c 
98               ((#\e #\E)
99                (cond (e (reverse-list->string lst))
100                      (else
101                       (set! e #t)
102                       (read-char port)
103                       (case (peek-char port)
104                         ((#\+ #\-) (loop (cons (read-char port) lst)))
105                         (else (reverse-list->string lst)) ) ) ) )
106               ((#!eof) (reverse-list->string lst))
107               ((#\.)
108                (cond (d (reverse-list->string lst))
109                      (else
110                       (set! d #t)
111                       (loop (cons (read-char port) lst)))))
112               (else
113                (if (char-numeric? c)
114                    (loop (cons (read-char port) lst))
115                    (reverse-list->string lst) ) ) ) ) ) ) ) )
116    (define (read-escaped pred)
117      (##sys#read-from-string
118       (string-append
119        "\""
120        (with-output-to-string
121          (lambda ()
122            (let loop ()
123              (let ((c (read-char port)))
124                (cond ((eof-object? c) (err "unexpected end of character sequence"))
125                      ((pred c))
126                      ((char=? #\\ c)
127                       (write-char #\\)
128                       (write-char (read-char port))
129                       (loop) )
130                      (else
131                       (write-char c)
132                       (loop) ) ) ) ) ) )
133        "\"") ) )
134    (define (skip-comment)
135      (let ((c (read-char port)))
136        (case c
137          ((#!eof) (err "unexpected end of comment"))
138          ((#\newline)
139           (set! ln (fx+ ln 1))
140           (skip-comment) )
141          ((#\*)
142           (let loop ()
143             (case (read-char port)
144               ((#\newline)
145                (set! ln (fx+ ln 1))
146                (skip-comment) )
147               ((#\*) (loop))
148               ((#\/) #f) 
149               (else (skip-comment)) ) ))
150          ((#\/)
151           (case (read-char port)
152             ((#\newline)
153              (set! ln (fx+ ln 1))
154              (skip-comment) )
155             ((#\*) (skip-comment) (skip-comment))
156             (else (skip-comment)) ) )
157          (else (skip-comment)) ) ) )
158    (define (read-sequence tok del)
159      (cons
160       tok
161       (let loop ((lst '()))
162         (let ((s (skip)))
163           (if (and s (not (eof-object? s)))
164               (loop (cons s lst))
165               (let ((c (peek-char port)))
166                 (cond ((eof-object? c) (err "unexpected end of sequence"))
167                       ((char=? del c)
168                        (read-char port)
169                        (reverse lst) )
170                       (else (loop (cons (scan) lst))) ) ) ) ) ) ) )
171    (scan) ) )
172
173)
Note: See TracBrowser for help on using the repository browser.