changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/parse/tests.lisp

changeset 698: 96958d3eb5b0
parent: 9472976adda9
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; lib/parse/tests.lisp --- Parser Tests
     2 
     3 ;;
     4 
     5 ;;; Code:
     6 (defpackage :parse/tests
     7   (:use :cl :rt :std :parse))
     8 
     9 (in-package :parse/tests)
    10 
    11 (defsuite :parse)
    12 (in-suite :parse)
    13 
    14 (deftest lex ()
    15   (is (string=
    16        (with-lexer-environment ("<foo>")
    17          (when (char= #\< (consume))
    18            (consume-until (make-matcher (is #\>)))))
    19        "foo"))
    20   (is (string=
    21        (let ((q "baz"))
    22          (with-lexer-environment ("foo bar baz")
    23            (consume-until (make-matcher (is q)))))
    24        "foo bar ")))
    25 
    26 (defun digitp (c) (member c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)))
    27 
    28 (defun simple-lexer (stream)
    29   (let ((c (read-char stream nil nil)))
    30     (cond
    31       ((null c) (values nil nil))
    32       ((member c '(#\Space #\Tab #\Newline)) (simple-lexer stream))
    33       ((member c '(#\+ #\- #\* #\/ #\( #\)))
    34        (let ((v (intern (string c))))
    35          (values v v)))
    36       ((digitp c)
    37        (let ((buffer (make-array 10 :element-type 'character
    38                                     :fill-pointer 0)))
    39          (do ((c c (read-char stream nil nil)))
    40              ((or (null c) (not (digitp c)))
    41               (unless (null c) (unread-char c stream))
    42               (values 'int (read-from-string buffer)))
    43            (vector-push-extend c buffer))))
    44       ((alpha-char-p c)
    45        (let ((buffer (make-array 10 :element-type 'character
    46                                     :fill-pointer 0)))
    47          (do ((c c (read-char stream nil nil)))
    48              ((or (null c) (not (alphanumericp c)))
    49               (unless (null c) (unread-char c stream))
    50               (values 'id (copy-seq buffer)))
    51            (vector-push-extend c buffer))))
    52       (t (error "Lexing error")))))
    53 
    54 (eval-when (:compile-toplevel :load-toplevel :execute)
    55   (defun k-2-3 (a b c) (declare (ignore a c)) b)
    56   )
    57 
    58 (define-parser *left-expression-parser*
    59   (:start-symbol expression)
    60   (:terminals (int id + - * / |(| |)|))
    61 
    62   (expression
    63    (expression + term)
    64    (expression - term)
    65    term)
    66 
    67   (term
    68    (term * factor)
    69    (term / factor)
    70    factor)
    71 
    72   (factor
    73    id
    74    int
    75    (|(| expression |)| #'k-2-3)))
    76 
    77 (define-parser *ambiguous-expression-parser*
    78   (:start-symbol expression)
    79   (:terminals (int id + - * / |(| |)|))
    80   (:muffle-conflicts (16 0))
    81 
    82   (expression
    83    (expression + expression)
    84    (expression - expression)
    85    (expression * expression)
    86    (expression / expression)
    87    id
    88    int
    89    (|(| expression |)| #'k-2-3)))
    90 
    91 (define-parser *precedence-left-expression-parser*
    92   (:start-symbol expression)
    93   (:terminals (int id + - * / |(| |)|))
    94   (:precedence ((:left * /) (:left + -)))
    95 
    96   (expression
    97    (expression + expression)
    98    (expression - expression)
    99    (expression * expression)
   100    (expression / expression)
   101    id
   102    int
   103    (|(| expression |)| #'k-2-3)))
   104 
   105 (define-parser *precedence-right-expression-parser*
   106   (:start-symbol expression)
   107   (:terminals (int id + - * / |(| |)|))
   108   (:precedence ((:right * /) (:right + -)))
   109 
   110   (expression
   111    (expression + expression)
   112    (expression - expression)
   113    (expression * expression)
   114    (expression / expression)
   115    id
   116    int
   117    (|(| expression |)| #'k-2-3)))
   118 
   119 (define-parser *precedence-nonassoc-expression-parser*
   120   (:start-symbol expression)
   121   (:terminals (int id + - * / |(| |)|))
   122   (:precedence ((:nonassoc * /) (:nonassoc + -)))
   123   (expression
   124    (expression + expression)
   125    (expression - expression)
   126    (expression * expression)
   127    (expression / expression)
   128    id
   129    int
   130    (|(| expression |)| #'k-2-3)))
   131 
   132 (deftest yacc ()
   133   (flet ((parse (parser e) 
   134            (with-input-from-string (s e)
   135              (parse-with-lexer #'(lambda () (simple-lexer s)) parser))))
   136     (let ((*package* (find-package :parse/tests)))
   137       (let ((e "(x+3)+y*z") (v '(("x" + 3) + ("y" * "z"))))
   138         (is (equal (parse *left-expression-parser* e) v))
   139         (is (equal (parse *precedence-left-expression-parser* e) v))
   140         (is (equal (parse *precedence-right-expression-parser* e) v))
   141         (is (equal (parse *precedence-nonassoc-expression-parser* e) v)))
   142       (let ((e "x+5/3*(12+y)/3+z"))
   143         (let ((v '(("x" + (((5 / 3) * (12 + "y")) / 3)) + "z")))
   144           (is (equal (parse *left-expression-parser* e) v))
   145           (is (equal (parse *precedence-left-expression-parser* e) v)))
   146         (let ((v '("x" + ((5 / (3 * ((12 + "y") / 3))) + "z"))))
   147           (is (equal (parse *precedence-right-expression-parser* e) v)))
   148         (let ((v '("x" + (5 / (3 * ((12 + "y") / (3 + "z")))))))
   149           (is (equal (parse *ambiguous-expression-parser* e) v)))
   150         (signals yacc-parse-error
   151           (parse *precedence-nonassoc-expression-parser* e)))
   152       (dolist (e '("5/3*(" "5/3)"))
   153         (signals yacc-parse-error
   154           (parse *left-expression-parser* e))
   155         (signals yacc-parse-error
   156           (parse *ambiguous-expression-parser* e))
   157         (signals yacc-parse-error
   158           (parse *precedence-left-expression-parser* e))
   159         (signals yacc-parse-error
   160           (parse *precedence-right-expression-parser* e))))))