honu.scm (5203B)
1 ;;; honu.scm - "honu"-syntax reader 2 3 4 (define read-honu 5 (let ((comma (string->symbol ",")) 6 (semicolon (string->symbol ";")) 7 (operator-chars 8 '(#\- #\+ #\/ #\? #\: #\* #\% #\& #\! #\. #\~ #\_ #\| #\> #\< #\= #\^) )) 9 (define (read-token pred . port) 10 (let* ((port (optional port (current-input-port))) 11 (out (open-output-string))) 12 (let loop () 13 (let ([c (peek-char port)]) 14 (cond ((and (not (eof-object? c)) (pred c)) 15 (write-char (read-char port) out) 16 (loop) ) 17 (else (get-output-string out) ) ) ) ) ) ) 18 (define (read-line . port) 19 (let ((in (optional port (current-input-port)))) 20 (let loop ((chars '())) 21 (let ((c (read-char in))) 22 (cond ((or (eof-object? c) (char=? #\newline c)) 23 (list->string (reverse chars))) 24 (else (loop (cons c chars)))))))) 25 (define (reverse-list->string lst) 26 (list->string (reverse lst))) 27 (lambda port 28 (let ((port (optional port (current-input-port)))) 29 (define (err msg . args) 30 (apply error 'read-honu msg args)) 31 (define (opchar? c) (memv c operator-chars)) 32 (define (skip) 33 (let ((c (peek-char port))) 34 (cond ((eof-object? c) c) 35 ((char-whitespace? c) 36 (read-char port) 37 (skip) ) 38 ((char=? #\/ c) 39 (read-char port) 40 (let ((c (peek-char port))) 41 (case c 42 ((#\/) 43 (read-line port) 44 (skip) ) 45 ((#\*) (skip-comment) (skip)) 46 (else 47 (if (opchar? c) 48 (let ((s (read-token opchar? port))) 49 (string->symbol (string-append "/" s) ) ) 50 '/) ) ) ) ) 51 (else #f) ) ) ) 52 (define (scan) 53 (or (skip) 54 (let ((c (peek-char port))) 55 (if (eof-object? c) 56 (err "unexpected end of input") 57 (case c 58 ((#\#) 59 (read-char port) 60 (let ((c (peek-char port))) 61 (case c 62 ((#\;) 63 (read-char port) 64 (let* ((x1 (scan)) 65 (x2 (scan)) ) 66 (if x1 67 x2 68 (scan) ) ) ) 69 (else 70 (let ((t (read-token char-alphabetic? port))) 71 (cond ((string=? "hx" t) (scan)) 72 ((string=? "sx" t) (read port)) 73 (else (err "invalid escape syntax" t)) ) ) ) ) ) ) 74 ((#\') 75 (read-char port) 76 (let ((s (read-escaped (lambda (c) (char=? #\' c))))) 77 (if (zero? (string-length s)) 78 (err "empty character literal") 79 (string-ref s 0) ) ) ) 80 ((#\,) (read-char port) comma) 81 ((#\;) (read-char port) semicolon) 82 ((#\") (read-char port) (read-escaped (lambda (c) (char=? #\" c)))) 83 ((#\() (read-char port) (read-sequence '%parens #\))) 84 ((#\[) (read-char port) (read-sequence '%brackets #\])) 85 ((#\{) (read-char port) (read-sequence '%braces #\})) 86 ((#\) #\] #\}) (err "unexpected closing delimiter" c)) 87 (else 88 (cond ((char-numeric? c) (read-num)) 89 ((or (char-alphabetic? c) 90 (char=? c #\_) 91 (char=? c #\$)) 92 (string->symbol 93 (read-token 94 (lambda (c) 95 (or (char-alphabetic? c) 96 (char-numeric? c) 97 (char=? #\_ c) 98 (char=? #\$ c))) 99 port) ) ) 100 ((opchar? c) (string->symbol (read-token opchar? port))) 101 (else (err "invalid character" c)) ) ) ) ) ) ) ) 102 (define (read-num) 103 (string->number 104 (let ((e #f) 105 (d #f)) 106 (let loop ((lst '())) 107 (let ((c (peek-char port))) 108 (if (eof-object? c) 109 (reverse-list->string lst) 110 (case c 111 ((#\e #\E) 112 (cond (e (reverse-list->string lst)) 113 (else 114 (set! e #t) 115 (read-char port) 116 (case (peek-char port) 117 ((#\+ #\-) (loop (cons (read-char port) lst))) 118 (else (reverse-list->string lst)) ) ) ) ) 119 ((#\.) 120 (cond (d (reverse-list->string lst)) 121 (else 122 (set! d #t) 123 (loop (cons (read-char port) lst))))) 124 (else 125 (if (char-numeric? c) 126 (loop (cons (read-char port) lst)) 127 (reverse-list->string lst) ) ) ) ) ) ) ) ) ) 128 (define (read-escaped pred) 129 (with-input-from-string 130 (with-output-to-string 131 (lambda () 132 (write-char #\") 133 (let loop () 134 (let ((c (read-char port))) 135 (cond ((eof-object? c) (err "unexpected end of character sequence")) 136 ((pred c)) 137 ((char=? #\\ c) 138 (write-char #\\) 139 (write-char (read-char port)) 140 (loop) ) 141 (else 142 (write-char c) 143 (loop) ) ) ) ) 144 (write-char #\") ) ) 145 read)) 146 (define (skip-comment) 147 (let ((c (read-char port))) 148 (if (eof-object? c) 149 (err "unexpected end of comment") 150 (case c 151 ((#\*) 152 (let loop () 153 (case (read-char port) 154 ((#\*) (loop)) 155 ((#\/) #f) 156 (else (skip-comment)) ) )) 157 ((#\/) 158 (case (read-char port) 159 ((#\*) (skip-comment) (skip-comment)) 160 (else (skip-comment)) ) ) 161 (else (skip-comment)) ) ) ) ) 162 (define (read-sequence tok del) 163 (cons 164 tok 165 (let loop ((lst '())) 166 (let ((s (skip))) 167 (if (and s (not (eof-object? s))) 168 (loop (cons s lst)) 169 (let ((c (peek-char port))) 170 (cond ((eof-object? c) (err "unexpected end of sequence")) 171 ((char=? del c) 172 (read-char port) 173 (reverse lst) ) 174 (else (loop (cons (scan) lst))) ) ) ) ) ) ) ) 175 (scan) ))))