| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Test parser infrastructure |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensble Object Design, an object system for C. |
| 11 | ;;; |
| 12 | ;;; SOD is free software; you can redistribute it and/or modify |
| 13 | ;;; it under the terms of the GNU General Public License as published by |
| 14 | ;;; the Free Software Foundation; either version 2 of the License, or |
| 15 | ;;; (at your option) any later version. |
| 16 | ;;; |
| 17 | ;;; SOD is distributed in the hope that it will be useful, |
| 18 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;;; GNU General Public License for more details. |
| 21 | ;;; |
| 22 | ;;; You should have received a copy of the GNU General Public License |
| 23 | ;;; along with SOD; if not, write to the Free Software Foundation, |
| 24 | ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | (cl:in-package #:sod-test) |
| 27 | |
| 28 | (defclass test-parser (test-case) |
| 29 | ()) |
| 30 | (add-test *sod-test-suite* (get-suite test-parser)) |
| 31 | |
| 32 | ;;;-------------------------------------------------------------------------- |
| 33 | ;;; Utilities. |
| 34 | |
| 35 | (defmacro assert-parse |
| 36 | ((string value winp consumedp &key (scanner (gensym "SCANNER-"))) |
| 37 | &body parser) |
| 38 | (once-only (string value winp consumedp) |
| 39 | (with-gensyms (my-value my-winp my-consumedp label what) |
| 40 | `(let ((,scanner (make-string-scanner ,string))) |
| 41 | (multiple-value-bind (,my-value ,my-winp ,my-consumedp) |
| 42 | (with-parser-context |
| 43 | (character-scanner-context :scanner ,scanner) |
| 44 | (parse ,@parser)) |
| 45 | (flet ((,label (,what) |
| 46 | (format nil "~A; parsing ~S with ~S" |
| 47 | ,what ,string ',@parser))) |
| 48 | (cond (,winp |
| 49 | (assert-true ,my-winp (,label "winp")) |
| 50 | (if (eq ,value t) |
| 51 | (assert-not-eql ,my-value nil |
| 52 | (,label "parser result")) |
| 53 | (assert-equal ,my-value ,value |
| 54 | (,label "parser result")))) |
| 55 | (t |
| 56 | (assert-false ,my-winp (,label "winp")) |
| 57 | (assert-true (and (null (set-difference ,my-value ,value |
| 58 | :test #'equal)) |
| 59 | (null (set-difference ,value ,my-value |
| 60 | :test #'equal))) |
| 61 | (,label "failure indicator")))) |
| 62 | (if ,consumedp |
| 63 | (assert-true ,my-consumedp (,label "consumedp")) |
| 64 | (assert-false ,my-consumedp (,label "consumedp"))))))))) |
| 65 | |
| 66 | ;;;-------------------------------------------------------------------------- |
| 67 | ;;; Simple parser tests. |
| 68 | ;;; |
| 69 | ;;; This lot causes SBCL to warn like a mad thing. It's too clever for us, |
| 70 | ;;; and does half of the work at compile time! |
| 71 | |
| 72 | (def-test-method test-simple ((test test-parser) :run nil) |
| 73 | "Test simple atomic parsers, because we rely on them later." |
| 74 | |
| 75 | ;; Characters match themselves. For a character known only at run-time, |
| 76 | ;; use (char CH). |
| 77 | (assert-parse ("abcd" #\a t t) #\a) |
| 78 | (let ((ch #\b)) |
| 79 | (assert-parse ("abcd" '(#\b) nil nil) (char ch))) |
| 80 | |
| 81 | ;; A character can't match at EOF. |
| 82 | (assert-parse ("" '(#\z) nil nil) #\z) |
| 83 | |
| 84 | ;; All characters match :any; but EOF isn't a character. |
| 85 | (assert-parse ("z" #\z t t) :any) |
| 86 | (assert-parse ("" '(:any) nil nil) :any) |
| 87 | |
| 88 | ;; The parser (satisfies PREDICATE) succeeds if the PREDICATE returns |
| 89 | ;; true when applied to the current character. |
| 90 | (assert-parse ("a" #\a t t) (satisfies alpha-char-p)) |
| 91 | (assert-parse ("0" '(alpha-char-p) nil nil) (satisfies alpha-char-p)) |
| 92 | |
| 93 | ;; The parser (not CHAR) matches a character other than CHAR; but it won't |
| 94 | ;; match EOF. |
| 95 | (assert-parse ("a" #\a t t) (not #\b)) |
| 96 | (assert-parse ("b" '((not #\b)) nil nil) (not #\b)) |
| 97 | (assert-parse ("" '((not #\b)) nil nil) (not #\b)) |
| 98 | |
| 99 | ;; But :eof matches only at EOF. |
| 100 | (assert-parse ("" :eof t nil) :eof) |
| 101 | (assert-parse ("abcd" '(:eof) nil nil) :eof) |
| 102 | |
| 103 | ;; Strings match themselves without consuming if they fail. |
| 104 | (assert-parse ("abcd" "ab" t t) "ab") |
| 105 | (assert-parse ("abcd" '("cd") nil nil) "cd")) |
| 106 | |
| 107 | (def-test-method test-sequence ((test test-parser) :run nil) |
| 108 | |
| 109 | ;; An empty sequence always succeeds and never consumes. And provokes |
| 110 | ;; warnings: don't do this. |
| 111 | (assert-parse ("" :win t nil) (seq () :win)) |
| 112 | (assert-parse ("abcd" :win t nil) (seq () :win)) |
| 113 | |
| 114 | ;; A `seq' matches the individual parsers in order, and binds their results |
| 115 | ;; to variables -- if given. The result is the value of the body. If any |
| 116 | ;; parser fails having consumed input, then input stays consumed. There's |
| 117 | ;; no backtracking. |
| 118 | (assert-parse ("abcd" '(#\a . #\c) t t) |
| 119 | (seq ((foo #\a) #\b (bar #\c)) (cons foo bar))) |
| 120 | (assert-parse ("abcd" '(#\c) nil t) |
| 121 | (seq ((foo #\a) (bar #\c)) (cons foo bar))) |
| 122 | (assert-parse ("abcd" '(#\c) nil nil) |
| 123 | (seq ((bar #\c) (foo #\a)) (cons foo bar)))) |
| 124 | |
| 125 | (def-test-method test-repeat ((test test-parser) :run nil) |
| 126 | |
| 127 | ;; A `many' matches a bunch of similar things in a row. You can compute a |
| 128 | ;; result using `do'-like accumulation. |
| 129 | (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc)) #\a)) |
| 130 | |
| 131 | ;; The default minimum is zero; so the parser always succeeds. |
| 132 | (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc)) #\b)) |
| 133 | |
| 134 | ;; You can provide an explicit minimum. Then the match might fail. |
| 135 | (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min 2) #\a)) |
| 136 | (assert-parse ("aabb" '(#\a) nil t) (many (acc 0 (1+ acc) :min 3) #\a)) |
| 137 | |
| 138 | ;; You can also provide an explicit maximum. This will cause the parser to |
| 139 | ;; stop searching, but it can't make it fail. |
| 140 | (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max 3) #\a)) |
| 141 | |
| 142 | ;; You can provide both a maximum and a minimum at the same time. If |
| 143 | ;; they're consistent, you won't be surprised. If they aren't, then the |
| 144 | ;; maximum wins and the minimum is simply ignored (currently). |
| 145 | (assert-parse ("aaaaab" 4 t t) |
| 146 | (many (acc 0 (1+ acc) :min 3 :max 4) #\a)) |
| 147 | (assert-parse ("aabbbb" '(#\a) nil t) |
| 148 | (many (acc 0 (1+ acc) :min 3 :max 4) #\a)) |
| 149 | (assert-parse ("aaabbb" 3 t t) |
| 150 | (many (acc 0 (1+ acc) :min 3 :max 3) #\a)) |
| 151 | (assert-parse ("aaabbb" 3 t t) |
| 152 | (many (acc 0 (1+ acc) :min 17 :max 3) #\a)) |
| 153 | |
| 154 | ;; You can provide a separator. The `many' parser will look for the |
| 155 | ;; separator between each of the main items, but will ignore the results. |
| 156 | (assert-parse ("a,a,abc" 3 t t) (many (acc 0 (1+ acc)) #\a #\,)) |
| 157 | (assert-parse ("a,a,abc" 2 t t) (many (acc 0 (1+ acc) :max 2) #\a #\,)) |
| 158 | |
| 159 | ;; If `many' sees a separator then by default it commits to finding another |
| 160 | ;; item; so this can cause a parse to fail. |
| 161 | (assert-parse ("a,a,bc" '(#\a) nil t) (many (acc 0 (1+ acc)) #\a #\,)) |
| 162 | (assert-parse ("abc" 1 t t) (many (acc 0 (1+ acc)) #\a #\,)) |
| 163 | |
| 164 | ;; If you specify a separator then the default minimum number of |
| 165 | ;; repetitions becomes 1 rather than 0. But you can override this |
| 166 | ;; explicitly. |
| 167 | (assert-parse ("bc" '(#\a) nil nil) (many (acc 0 (1+ acc)) #\a #\,)) |
| 168 | (assert-parse ("bc" 0 t nil) (many (acc 0 (1+ acc) :min 0) #\a #\,)) |
| 169 | |
| 170 | ;; The parser will fail looking for a separator if there aren't enough |
| 171 | ;; items. |
| 172 | (assert-parse ("a,abc" '(#\,) nil t) |
| 173 | (many (acc 0 (1+ acc) :min 3) #\a #\,)) |
| 174 | |
| 175 | ;; You can override the commit-on-separator behaviour by using :commit. |
| 176 | ;; This makes a trailing separator legal (but optional), so it also affects |
| 177 | ;; the behaviour regarding maximum and minimum repetitions. (Commitment is |
| 178 | ;; irrelevant if you don't have a separator.) |
| 179 | (assert-parse ("a,a,bc" 2 t t) |
| 180 | (many (acc 0 (1+ acc) :commitp nil) #\a #\,)) |
| 181 | (assert-parse ("a,a,abc" 3 t t) |
| 182 | (many (acc 0 (1+ acc) :commitp nil) #\a #\,)) |
| 183 | (assert-parse ("a,a,a,bc" 3 t t) |
| 184 | (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp t) #\a #\,)) |
| 185 | #\,) |
| 186 | n)) |
| 187 | (assert-parse ("a,a,a,bc" 3 t t) |
| 188 | (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp nil) #\a #\,)) |
| 189 | #\b) |
| 190 | n)) |
| 191 | (assert-parse ("a,a,bc" '(#\a) nil t) |
| 192 | (many (acc 0 (1+ acc) :min 3 :commitp nil) #\a #\,)) |
| 193 | |
| 194 | ;; The `many' parser won't backtrack. The `many' eats as many `a's as |
| 195 | ;; possible; asking for another one is sure to fail. |
| 196 | (assert-parse ("aaaabc" '(#\a) nil t) (and (skip-many () #\a) #\a))) |
| 197 | |
| 198 | (def-test-method test-repeat-hairy ((test test-parser) :run nil) |
| 199 | ;; The `many' expander is very hairy and does magical things if it notices |
| 200 | ;; that some of its arguments are constants. So here we test a number of |
| 201 | ;; the above things again, using variables so that it has to produce code |
| 202 | ;; which makes decisions at run-time. (I've no doubt that SBCL will issue |
| 203 | ;; an infinite number of notes explaining how clever it is and how it can |
| 204 | ;; do it all at compile-time anyway. Of course, suppressing these notes is |
| 205 | ;; the main reason `many' is so hairy anyway.) |
| 206 | |
| 207 | (let ((zero 0) (two 2) (three 3) (yes t) (no nil)) |
| 208 | |
| 209 | ;; Minima. |
| 210 | (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :min zero) #\a)) |
| 211 | (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc) :min zero) #\b)) |
| 212 | (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min two) #\a)) |
| 213 | (assert-parse ("aabb" '(#\a) nil t) |
| 214 | (many (acc 0 (1+ acc) :min three) #\a)) |
| 215 | |
| 216 | ;; Maxima. |
| 217 | (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :max no) #\a)) |
| 218 | (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max three) #\a)) |
| 219 | |
| 220 | ;; And now together with separators and commitment. Oh, my. |
| 221 | (assert-parse ("a,a,a,bc" 3 t t) |
| 222 | (many (acc 0 (1+ acc) :commitp no) #\a #\,)) |
| 223 | (assert-parse ("a,a,a,bc" '(#\a) nil t) |
| 224 | (many (acc 0 (1+ acc) :commitp yes) #\a #\,)) |
| 225 | (assert-parse ("a,a,bc" '(#\a) nil t) |
| 226 | (many (acc 0 (1+ acc) :min three :commitp yes) #\a #\,)) |
| 227 | (assert-parse ("a,a,bc" '(#\a) nil t) |
| 228 | (many (acc 0 (1+ acc) :min 3 :commitp yes) #\a #\,)) |
| 229 | (assert-parse ("a,a,bc" '(#\a) nil t) |
| 230 | (many (acc 0 (1+ acc) :min three :commitp t) #\a #\,)) |
| 231 | (assert-parse ("a,a,a,bc" 3 t t) |
| 232 | (seq ((n (many (acc 0 (1+ acc) :max three :commitp no) #\a #\,)) #\b) |
| 233 | n)) |
| 234 | (assert-parse ("a,a,a,bc" 3 t t) |
| 235 | (seq ((n (many (acc 0 (1+ acc) :max three :commitp yes) #\a #\,)) #\,) |
| 236 | n)) |
| 237 | (assert-parse ("a,a,a,bc" 3 t t) |
| 238 | (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp no) #\a #\,)) #\b) |
| 239 | n)) |
| 240 | (assert-parse ("a,a,a,bc" 3 t t) |
| 241 | (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp yes) #\a #\,)) #\,) |
| 242 | n)) |
| 243 | (assert-parse ("a,a,a,bc" 3 t t) |
| 244 | (seq ((n (many (acc 0 (1+ acc) :max three :commitp nil) #\a #\,)) #\b) |
| 245 | n)) |
| 246 | (assert-parse ("a,a,a,bc" 3 t t) |
| 247 | (seq ((n (many (acc 0 (1+ acc) :max three :commitp t) #\a #\,)) #\,) |
| 248 | n)))) |
| 249 | |
| 250 | (def-test-method test-alternate ((test test-parser) :run nil) |
| 251 | |
| 252 | ;; An `or' matches the first parser that either succeeds or fails having |
| 253 | ;; consumed input. |
| 254 | (assert-parse ("abcd" #\a t t) (or #\a #\b)) |
| 255 | (assert-parse ("abcd" #\a t t) (or #\b #\a)) |
| 256 | (assert-parse ("abcd" '(#\b #\c) nil nil) (or #\b #\c)) |
| 257 | |
| 258 | ;; Strings don't consume if they fail. |
| 259 | (assert-parse ("abcd" "ab" t t) (or "cd" "ab")) |
| 260 | (assert-parse ("abcd" "ab" t t) (or "ad" "ab")) |
| 261 | (assert-parse ("abcd" '("ad" "ac") nil nil) (or "ad" "ac")) |
| 262 | |
| 263 | ;; But `seq' will if some component consumes. |
| 264 | (assert-parse ("abcd" '(#\d) nil t) (or (and #\a #\d) "ab")) |
| 265 | (assert-parse ("abcd" "ab" t t) (or (and #\c #\d) "ab")) |
| 266 | |
| 267 | ;; We can tame this using `peek' which rewinds the source if its argument |
| 268 | ;; fails, so as to hide consumption of input. |
| 269 | (assert-parse ("abcd" "ab" t t) (or (peek (and #\a #\d)) "ab")) |
| 270 | (assert-parse ("abcd" '(#\a #\b "cd") t t) |
| 271 | (seq ((foo (peek (seq ((foo #\a) (bar #\b)) (list foo bar)))) |
| 272 | (bar "cd")) |
| 273 | (append foo (list bar)))) |
| 274 | |
| 275 | ;; Failure indicators are union'd if they all fail. |
| 276 | (assert-parse ("abcd" '(#\q #\x #\z) nil nil) |
| 277 | (or #\q (peek (and #\a (or #\x #\q))) #\z)) |
| 278 | |
| 279 | ;; But if any of them consumed input then you only get the indicators from |
| 280 | ;; the consuming branch, because we committed to it when we consumed the |
| 281 | ;; input. |
| 282 | (assert-parse ("abcd" '(#\x #\q) nil t) |
| 283 | (or #\q #\z (and #\a (or #\q #\x))))) |
| 284 | |
| 285 | ;;;-------------------------------------------------------------------------- |
| 286 | ;;; Some tests with a simple recursive parser. |
| 287 | |
| 288 | (defstruct (node |
| 289 | (:predicate nodep) |
| 290 | (:constructor make-node (left data right))) |
| 291 | "Structure type for a simple binary tree." |
| 292 | left data right) |
| 293 | |
| 294 | (defun parse-tree (scanner) |
| 295 | "Parse a textual representation into a simple binary tree. |
| 296 | |
| 297 | The syntax is simple: |
| 298 | |
| 299 | TREE ::= EMPTY | `(' TREE CHAR TREE `)' |
| 300 | |
| 301 | There's an ambiguity in this syntax, at least if you have limited |
| 302 | lookahead: suppose you've just parsed the opening `(' of a TREE, and you |
| 303 | see another `(' -- is it the start of the non-empty left sub-TREE, or is |
| 304 | it the CHAR following an empty left sub-TREE? We opt for the first choice |
| 305 | always." |
| 306 | |
| 307 | ;; This came from another project, although it isn't actually used there. |
| 308 | ;; It exposed the weakness in an earlier design which prompted the addition |
| 309 | ;; of the CONSUMEDP flags to the parser protocol. |
| 310 | |
| 311 | (with-parser-context (character-scanner-context :scanner scanner) |
| 312 | (labels ((tree () |
| 313 | (parse (or (seq (#\( |
| 314 | (left (tree)) |
| 315 | (data :any) |
| 316 | (right (tree)) |
| 317 | #\)) |
| 318 | (make-node left data right)) |
| 319 | (values nil t nil))))) |
| 320 | (parse (seq ((tree (tree)) :eof) |
| 321 | tree))))) |
| 322 | |
| 323 | (defun parse-tree-lookahead (scanner) |
| 324 | "Parse a textual representation into a simple binary tree. |
| 325 | |
| 326 | The syntax is simple, and, indeed, the grammar's the same as for |
| 327 | `sod-parse-tree': |
| 328 | |
| 329 | TREE ::= EMPTY | `(' TREE CHAR TREE `)' |
| 330 | |
| 331 | But the rules are different. Instead of resolving the `ambiguity' between |
| 332 | TREE and CHAR when we find another `(' after the opening `(' of a TREE |
| 333 | deterministically in favour of TREE as `parse-tree' does, we try that |
| 334 | first, and backtrack if necessary." |
| 335 | |
| 336 | ;; Bison can do this, but you have to persuade it to use the scary GLR |
| 337 | ;; parser algorithm |
| 338 | |
| 339 | (with-parser-context (character-scanner-context :scanner scanner) |
| 340 | (labels ((tree () |
| 341 | (parse (or (peek (seq (#\( |
| 342 | (left (tree)) |
| 343 | (data :any) |
| 344 | (right (tree)) |
| 345 | #\)) |
| 346 | (make-node left data right))) |
| 347 | (values nil t nil))))) |
| 348 | (parse (seq ((tree (tree)) :eof) |
| 349 | tree))))) |
| 350 | |
| 351 | (def-test-method test-simple-tree-parser ((test test-parser) :run nil) |
| 352 | (assert-parse ("" nil t nil :scanner sc) (parse-tree sc)) |
| 353 | (assert-parse ("((a)b((c)d(e)))" t t t :scanner sc) (parse-tree sc)) |
| 354 | (assert-parse ("((a)b((c)d(e)))z" '(:eof) nil t :scanner sc) |
| 355 | (parse-tree sc)) |
| 356 | (assert-parse ("((a)b((c)d(e))" '(#\)) nil t :scanner sc) (parse-tree sc)) |
| 357 | (assert-parse ("(([)*(]))" t t t :scanner sc) (parse-tree sc)) |
| 358 | (assert-parse ("((()-()))" '(#\)) nil t :scanner sc) (parse-tree sc)) |
| 359 | (assert-parse ("((()-()))" t t t :scanner sc) (parse-tree-lookahead sc))) |
| 360 | |
| 361 | ;;;-------------------------------------------------------------------------- |
| 362 | ;;; Test expression parser. |
| 363 | |
| 364 | (defparse token (:context (context character-parser-context) parser) |
| 365 | (with-gensyms (value) |
| 366 | (expand-parser-spec context |
| 367 | `(seq ((,value ,parser) :whitespace) ,value)))) |
| 368 | |
| 369 | (let ((add (binop "+" (x y 5) `(+ ,x ,y))) |
| 370 | (sub (binop "-" (x y 5) `(- ,x ,y))) |
| 371 | (mul (binop "*" (x y 7) `(* ,x ,y))) |
| 372 | (div (binop "/" (x y 7) `(/ ,x ,y))) |
| 373 | (eq (binop "=" (x y 3 :assoc nil) `(= ,x ,y))) |
| 374 | (ne (binop "/=" (x y 3 :assoc nil) `(/= ,x ,y))) |
| 375 | (lt (binop "<" (x y 3 :assoc nil) `(< ,x ,y))) |
| 376 | (gt (binop ">" (x y 3 :assoc nil) `(> ,x ,y))) |
| 377 | (and (binop "&" (x y 2) `(and ,x ,y))) |
| 378 | (or (binop "|" (x y 1) `(or ,x ,y))) |
| 379 | (expt (binop "**" (x y 8 :assoc :right) `(** ,x ,y))) |
| 380 | (neg (preop "-" (x 9) `(- ,x))) |
| 381 | (not (preop "!" (x 2) `(not ,x))) |
| 382 | (fact (postop "!" (x 10) `(! ,x))) |
| 383 | (lp (lparen #\))) (rp (rparen #\))) |
| 384 | (lb (lparen #\])) (rb (rparen #\]))) |
| 385 | (defun test-parse-expr (string) |
| 386 | (with-parser-context (string-parser :string string) |
| 387 | (parse (seq (:whitespace |
| 388 | (value (expr (:nestedp nestedp) |
| 389 | (token (many (a 0 (+ (* a 10) it) :min 1) |
| 390 | (filter digit-char-p))) |
| 391 | (token (or (seq ("**") expt) |
| 392 | (seq ("/=") ne) |
| 393 | (seq (#\+) add) |
| 394 | (seq (#\-) sub) |
| 395 | (seq (#\*) mul) |
| 396 | (seq (#\/) div) |
| 397 | (seq (#\=) eq) |
| 398 | (seq (#\<) lt) |
| 399 | (seq (#\>) gt) |
| 400 | (seq (#\&) and) |
| 401 | (seq (#\|) or))) |
| 402 | (token (or (seq (#\() lp) |
| 403 | (seq (#\[) lb) |
| 404 | (seq (#\-) neg) |
| 405 | (seq (#\!) not))) |
| 406 | (token (or (seq (#\!) fact) |
| 407 | (when nestedp |
| 408 | (or (seq (#\)) rp) |
| 409 | (seq (#\]) rb))))))) |
| 410 | (next (or :any (t :eof)))) |
| 411 | (cons value next)))))) |
| 412 | |
| 413 | (defun assert-expr-parse (string value winp consumedp) |
| 414 | (multiple-value-bind (v w c) (test-parse-expr string) |
| 415 | (flet ((message (what) |
| 416 | (format nil "expression ~S; ~A" string what))) |
| 417 | (cond (winp (assert-true w (message "winp")) |
| 418 | (assert-equal v value (message "value"))) |
| 419 | (t (assert-false w (message "winp")) |
| 420 | (assert-equal v value (message "expected")))) |
| 421 | (assert-eql c consumedp (message "consumedp"))))) |
| 422 | |
| 423 | (def-test-method test-expression-parser ((test test-parser) :run nil) |
| 424 | (assert-expr-parse "1 + 2 + 3" '((+ (+ 1 2) 3) . :eof) t t) |
| 425 | (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t) |
| 426 | (assert-expr-parse "1 * 2 + 3" '((+ (* 1 2) 3) . :eof) t t) |
| 427 | (assert-expr-parse "(1 + 2) * 3" '((* (+ 1 2) 3) . :eof) t t) |
| 428 | (assert-expr-parse "1 ** 2 ** 3" '((** 1 (** 2 3)) . :eof) t t) |
| 429 | (assert-expr-parse "1 + 2) * 3" '((+ 1 2) . #\)) t t) |
| 430 | (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t) |
| 431 | (assert-expr-parse "! 1 + 2 = 3 | 6 - 3 /= 12/6" |
| 432 | '((or (not (= (+ 1 2) 3)) |
| 433 | (/= (- 6 3) (/ 12 6))) |
| 434 | . :eof) |
| 435 | t t) |
| 436 | (assert-expr-parse "! 1 > 2 & ! 4 < 6 | 3 < 4 & 9 > 10" |
| 437 | '((or (and (not (> 1 2)) (not (< 4 6))) |
| 438 | (and (< 3 4) (> 9 10))) |
| 439 | . :eof) |
| 440 | t t) |
| 441 | |
| 442 | (assert-condition 'simple-error (test-parse-expr "(1 + 2")) |
| 443 | (assert-condition 'simple-error (test-parse-expr "(1 + 2]")) |
| 444 | (assert-condition 'simple-error (test-parse-expr "1 < 2 < 3"))) |
| 445 | |
| 446 | ;;;----- That's all, folks -------------------------------------------------- |