1.2.7-read.lisp (6928B)
1 ;; TODO : ne gère pas les échappements "foo\"bar" etc. ni les #... 2 3 (defun my-read (input-stream) 4 (let ((result-stack '()) 5 (result nil) 6 (char nil) 7 (stack '()) 8 (top-stack nil)) 9 (labels ((char-member (char chars) 10 (some (lambda (c) (char= char c)) chars)) 11 (pop-result () 12 (setq result (car result-stack)) 13 (setq result-stack (cdr result-stack))) 14 (push-val (val) 15 (push val result)) 16 (push-result () 17 (push result result-stack) 18 (setq result nil)) 19 (get-char () 20 (setq char (read-char input-stream nil nil)))) 21 (tagbody 22 start 23 (get-char) 24 (push 'end stack) 25 (go read-any) 26 27 read-any 28 (push 'end-read-any stack) 29 read-any-loop 30 (cond 31 ((not char) (go end-of-file)) 32 ((char= char #\() (go read-list)) 33 ((char= char #\)) (error "Paren mismatch. Stack :~&~a" stack)) 34 ((char= char #\') (go read-quote)) 35 ((char= char #\;) (push 'read-any-loop stack) (go read-comment)) 36 ((char= char #\") (go read-string)) 37 ((member char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) :test #'char=) (go read-number)) 38 ((char= char #\#) (go read-sharp)) 39 ((char= char #\`) (go read-backquote)) 40 ((char= char #\,) (go read-unquote)) 41 ((char= char #\ ) (get-char) (go read-any-loop)) 42 ((char= char #\newline) (get-char) (go read-any-loop)) 43 (t (go read-symbol))) ;; \ and | and : fall into this. 44 end-read-any 45 (go return) 46 47 read-list 48 (push-result) 49 (get-char) 50 read-list-loop 51 (when (or (char= char #\ ) (char= char #\newline)) 52 (get-char) 53 (go read-list-loop)) 54 (when (or (not char) (char= char #\))) 55 (go end-read-list-loop)) 56 (push 'read-list-loop stack) 57 (go read-any) 58 end-read-list-loop 59 (when (not char) 60 (error "EOF while reading a list")) 61 (get-char) 62 (push (reverse result) (car result-stack)) 63 (pop-result) 64 ;(get-char) 65 (go return) 66 67 read-quote 68 (push-result) 69 (push-val 'quote) 70 (get-char) 71 (go read-quotes-content) 72 73 read-quotes-content 74 (push 'end-read-quotes stack) 75 (go read-any) 76 end-read-quotes 77 (push (reverse result) (car result-stack)) 78 (pop-result) 79 (go return) 80 81 read-comment 82 read-comment-loop 83 (get-char) 84 (unless (or (not char) (char= char #\newline)) 85 (go read-comment-loop)) 86 (unless (not char) 87 (get-char)) 88 (go return) 89 90 read-string 91 (get-char) 92 (push-result) 93 (go read-string-loop-start) 94 read-string-loop 95 (push-val char) 96 (get-char) 97 read-string-loop-start 98 (unless (or (not char) (char= char #\")) 99 (go read-string-loop)) 100 (when (not char) 101 (error "End of file while reading string.")) 102 (get-char) 103 (push (format nil "~{~a~}" (reverse result)) (car result-stack)) 104 (pop-result) 105 (go return) 106 107 read-number 108 (push 'end-read-number stack) 109 (go read-symbol) 110 end-read-number 111 (setf (car result) (parse-integer (string (car result)))) 112 (go return) 113 114 read-sharp 115 (get-char) 116 (cond 117 ((char= char #\') (go read-quote-function)) 118 ((char= char #\\) (go read-sharp-char)) 119 (t (error "bootstrap : read : niy : syntax #~a not implemented yet." char))) 120 121 read-quote-function 122 (push-result) 123 (push-val 'function) 124 (get-char) 125 (go read-quotes-content) 126 127 read-sharp-char 128 (get-char) 129 (push 'end-read-sharp-char stack) 130 (go read-symbol) 131 end-read-sharp-char 132 (case (car result) 133 (newline (setf (car result) #\newline)) 134 (otherwise (setf (car result) (char (string (car result)) 0)))) 135 (go return) 136 137 read-backquote 138 (push-result) 139 (push-val 'quasiquote) 140 (get-char) 141 (go read-quotes-content) 142 143 read-unquote 144 (push-result) 145 (get-char) 146 (cond ((char= char #\@) 147 (get-char) 148 (push-val 'unquote-splice)) 149 ((char= char #\.) 150 (get-char) 151 (push-val 'unquote-destructive-splice)) 152 (t 153 (push-val 'unquote))) 154 (go read-quotes-content) 155 156 read-symbol 157 (push-result) 158 read-symbol-loop 159 (push-val char) 160 (get-char) 161 ;; Pas le # : '(a#(1 2)) => '(|a#| (1 2)), pas '(a #(1 2)) 162 (unless (or (not char) (char-member char '(#\( #\) #\' #\; #\" #\` #\, #\ #\newline))) 163 (go read-symbol-loop)) 164 (push (intern (format nil "~:@(~{~a~}~)" (reverse result))) (car result-stack)) 165 (pop-result) 166 (go return) 167 168 end-of-file 169 (error "End of file not expected here !") 170 171 return 172 (setq top-stack (car stack)) 173 (setq stack (cdr stack)) 174 (case top-stack 175 (start (go start)) 176 (read-any (go read-any)) 177 (read-any-loop (go read-any-loop)) 178 (end-read-any (go end-read-any)) 179 (read-list (go read-list)) 180 (read-list-loop (go read-list-loop)) 181 (read-quote (go read-quote)) 182 (end-read-quotes (go end-read-quotes)) 183 (end-read-sharp-char (go end-read-sharp-char)) 184 (end-read-number (go end-read-number)) 185 (read-symbol (go read-symbol)) 186 (read-symbol-loop (go read-symbol-loop)) 187 (end-of-file (go end-of-file)) 188 (end (go end)) 189 (otherwise (error "bootstrap : read : Invalid return point on the stack : ~w" top-stack))) 190 end)) 191 (car result))) 192 193 ;; (my-read (make-string-input-stream "foo")) 194 ;; (my-read (make-string-input-stream "'foo")) 195 ;; (my-read (make-string-input-stream "(foo)")) 196 ;; (my-read (make-string-input-stream "(foo bar)")) 197 ;; (my-read (make-string-input-stream "(foo bar baz)")) 198 ;; (my-read (make-string-input-stream "'(foo)")) 199 ;; (my-read (make-string-input-stream "'(foo bar baz)")) 200 201 ;; (my-read (make-string-input-stream "`(,foo ,@bar ,.baz 'quux blop)")) 202 203 ;; (my-read (make-string-input-stream "'(foo bar;;quux 204 ;; baz)")) 205 206 ;; (my-read (make-string-input-stream "'(foo bar;;quux aa 207 ;; baz \"buz\" 'moo)")) 208 209 ;; (my-read (make-string-input-stream "'(foo bar;;quux aa 210 ;; (baz #\\y \"buz\") 'moo)")) 211 212 (my-read (make-string-input-stream "(list '(+ 2 3))"))