Commits

Anonymous committed c8bc970

Initial version of error handling.
Keywords: error handling

Comments (0)

Files changed (7)

examples/calculator.lisp

 (fucc:defparser *calculator-parser*
     s ; Initial non-terminal
   ;; List of terminal
-  (+ - * / = :semicolon :id :const)
+  (+ - * / = :semicolon :id :const #\( #\))
   ;; List of rules
   ((s ->
       (:var exp-list (:list exp :semicolon))
                     (funcall op a b)))
         ;; Constants
         -> :const
+        ;; Parenthes
+        -> #\( exp #\) (:call (lambda (ign1 val ign2)
+                                (declare (ignore ign1 ign2))
+                                val))
+        -> #\( error #\) (:call (lambda (&rest ignore)
+                                (declare (ignore ignore))
+                                0))
         ;; and variables
         ->  :id
             (:call (lambda (var)
          (values next-value (fdefinition next-value)))
         ((symbolp next-value)
          (values :id next-value))
+        ((characterp next-value)
+         (values next-value next-value))
         ((numberp next-value)
          (values :const next-value))
         (t
 
 (test-calc (copy-list '(a = c = 3 #\;
                         b = 4 #\;
-                        a * a + b * 9 - a)))
+                        a * a + #\( b * 9 #\) - a)))
+;; Error handling:
+(test-calc (copy-list '(a = c = 3 #\;
+                        b = 4 #\;
+                        a * a + #\( b * #\) - a)))

examples/css-with-error-recovery.lisp

+#+asdf(eval-when (:compile-toplevel :execute :load-toplevel)
+        (asdf:oos 'asdf:load-op :fucc-parser))
+#+asdf(eval-when (:compile-toplevel :execute)
+        (asdf:oos 'asdf:load-op :fucc-generator))
+
+(defun 1st (val &rest ignore)
+  (declare (ignore ignore))
+  val)
+
+(defun 2nd (ignore1 val &rest ignore2)
+  (declare (ignore ignore1 ignore2))
+  val)
+
+;; Simplified CSS parser with error recovery
+(fucc:defparser *css-parser*
+    s ; Initial non-terminal
+  (:identifier :length :color
+   #\; #\{ #\} #\( #\) #\: #\[ #\] #\*)
+  ((s -> (* rule))
+   (rule -> pattern body)
+   (pattern -> :identifier) ; Real patterns may be complex
+   (body -> #\{ decls #\} (:call #'2nd)
+         -> #\{ decls error #\} (:call #'2nd))
+   (decls -> 
+          -> decl (:call (lambda (decl) (list decl)))
+          -> decls #\; decl (:call (lambda (decls sep decl)
+                                     (declare (ignore sep))
+                                     ;; I know, it is slow, but short;
+                                     ;; enough for example code, but
+                                     ;; don't use it in real code
+                                     (append decls (list decl))))
+          -> decls #\;
+          -> decls error #\; (:call (lambda (decls &rest ignore)
+                                  (declare (ignore ignore))
+                                  decls)))
+   (decl -> :identifier #\: (:* property)
+         -> :identifier #\: error #\;)
+   ;; There are must also url, string etc., but this is just example.
+   (property -> (:or :color :length :identifier))))
+
+(defun dumb-lexer (list)
+  (lambda ()
+    (apply #'values (pop list))))
+
+(defun test-css (list)
+  (fucc:parser-lr
+   (dumb-lexer list)
+   *css-parser*))
+
+#| CSS in this example:
+
+* { color: #FFF; background: #000 }
+p { border: 1px solid red; padding-left: 1em; }
+
+|#
+#-(and)
+(test-css (copy-list '((:identifier "*")
+                       (#\{         #\{)
+                       (:identifier "color")
+                       (#\:         #\:)
+                       (:color      "#FFF")
+                       (#\;         #\;)
+                       (:identifier "background")
+                       (#\:         #\:)
+                       (:color      "#000")
+                       (#\}         #\})
+                       (:identifier "p")
+                       (#\{         #\{)
+                       (:identifier "border")
+                       (#\:         #\:)
+                       (:length     "1px")
+                       (:identifier "solid")
+                       (:identifier "red")
+                       (#\;         #\;)
+                       (:identifier "padding-left")
+                       (#\:         #\:)
+                       (:length     "1em")
+                       (#\;         #\;)
+                       (#\}         #\})
+                       (nil         nil))))
+
+(defun error-test ()
+  (test-css (copy-list '((:identifier "*")
+                         (#\{         #\{)
+                         (:identifier "color")
+
+                         (#\:         #\:)
+                         (:color      "#FFF")
+                         (#\;         #\;)
+                         (:identifier "background")
+                         (#\:         #\:)
+                         (:color      "#000")
+                         (#\}         #\})
+                         (:identifier "p")
+                         (#\{         #\{)
+                         (:identifier "border")
+                         (#\:         #\:)
+                         (:length     "1px")
+                         (:identifier "padding-left")
+                         (#\:         #\:)
+                         (:length     "1em")
+                         (#\;         #\;)
+                         (#\}         #\})
+                         (nil         nil)))))

generator/fg-decl.lisp

 #|
- Copyright (c) 2006 Ivan Boldyrev
+ Copyright (c) 2006-2008 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the

generator/fg-grammar.lisp

 #|
- Copyright (c) 2006-2007 Ivan Boldyrev
+ Copyright (c) 2006-2008 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
         (setf init-action (second (pop right))))
       (loop :while right :do
          (if (attribute-form-p (second right))
-             ;; Nterm with action
-             (let ((nt (get-nterm (pop right)))
-                   (action (second (pop right))))
-               (push action actions)
-               (push nt right-nterms))
-             ;; Normal nterm
-             (let ((nt (get-nterm (pop right))))
-               (push nil actions)
-               (push nt right-nterms))))
+            ;; Nterm with action
+            (let ((nt (get-nterm (pop right)))
+                  (action (second (pop right))))
+              (push action actions)
+              (push nt right-nterms))
+            ;; Normal nterm
+            (let ((nt (get-nterm (pop right))))
+              (push nil actions)
+              (push nt right-nterms))))
       (setf actions (nreverse actions))
       (setf right-nterms (nreverse right-nterms))
+      ;; Check if rule is well-formed error recovery rule
+      (let* ((where-is-err (member 'cl:error right-nterms))
+             (term-after-err (second where-is-err)))
+        (when where-is-err
+            (if (null (cddr where-is-err))
+                (when (and term-after-err
+                           (not (terminal-p term-after-err)))
+                  (error "After ~S (error recovery designator) should go only a single terminal, but ~S is found." 'cl:error (nterm-name term-after-err)))
+                (error "After ~S (error recovery designator) should go only single terminal, but several are found: ~S." 'cl:error (rest where-is-err)))))
+      
       (let ((rule (apply #'make-rule
                          :left left-nterm
                          :right right-nterms
                       "Intarg clause is too short: ~S" form)
               (assert (not (cdddr form)) nil
                       "Init-Env clause is too long: ~S" form)
-              (let ((var (gensym)))
+              (let ((var (gensym "NTERM")))
                 (push (second form)
                       rev-initarg-list)
                 (push var
                 (push var var-list)
                 (third form)))
              (t
-              (let ((var (gensym)))
+              (let ((var (gensym "NTERM")))
                 (push var var-list)
                 form))))
           (t
-           (let ((var (gensym)))
+           (let ((var (gensym "NTERM")))
              (push var var-list)
              form))))
      ;; Primary action
         '())))))
 
 (defun parse-grammar (initial terminals rules &key prec-info (type :lr))
-  ;; Add EOF mark
+  ;; Add error and EOF marks
+  (push 'cl:error terminals)
   (push +EOF+ terminals)
   ;; Add artifical start rule
   (setf rules
 number of argument and doesn't evaluate unused expressions"
   (if (null other-sets)
       set
-      (let ((temp-var (gensym)))
+      (let ((temp-var (gensym "TEMP")))
         `(let ((,temp-var ,set))
           (if (and ,temp-var (null (first ,temp-var)))
               (ounion (rest ,temp-var) (combine-first-sets ,@other-sets)

generator/fg-macro.lisp

 #|
- Copyright (c) 2006-2007 Ivan Boldyrev
+ Copyright (c) 2006-2008 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
   (let ((grammar (parse-grammar initial terminals rules
                                 :prec-info prec-info
                                 :type type))
-        (%/value/-var (gensym))
-        (mapping-var (gensym))
-        (state-var (gensym))
-        (nterminal-var (gensym))
-        (terminal-var (gensym))
-        (parser-var (gensym))
-        (goto-table-var (gensym))
-        (new-state-var (gensym))
+        (%/value/-var (gensym "VALUE"))
+        (mapping-var (gensym "MAPPING"))
+        (state-var (gensym "STATE"))
+        (nterminal-var (gensym "NTERMINAL"))
+        (terminal-var (gensym "TERMINAL"))
+        (parser-var (gensym "PARSER"))
+        (goto-table-var (gensym "GOTO-TABLE"))
+        (new-state-var (gensym "NEW-STATE"))
         (use-context-p (member :context lexer-options)))
     ;; Check parameters
     (dolist (option (set-difference lexer-options '(:context)))
                          ,new-state-var))
                    (first ,%/value/-var)
                    (second ,%/value/-var)
+                   ',(mapcar #'nterm-name (rest (grammar-terminals grammar)))
                    ,(if use-context-p
                         (dump-valid-terminals action grammar)
                         nil))))))))))

generator/fg-transform.lisp

                   :collect nterminal
                 :else
                   :do (push nterminal unused)))
-    ;; Update terminals, preserving EOF terminal (which is always first)
-    (let ((eof-terminal (first (grammar-terminals grammar))))
+    ;; Update terminals, preserving EOF and ERROR terminals (they are two first)
+    (let ((reserved-terminal (subseq (grammar-terminals grammar)
+                                     0 2)))
       (setf (grammar-terminals grammar)
-            (cons eof-terminal
-                  (loop :for terminal :in (rest (grammar-terminals grammar))
+            (nconc reserved-terminal
+                  (loop :for terminal :in (cddr (grammar-terminals grammar))
                         :if (nterm-used terminal)
                           :collect terminal
                         :else
 (defun add-nterm (actions)
   (mapcar
    #'(lambda (action)
-       (let ((var (gensym)))
+       (let ((var (gensym "VAR")))
          (destructuring-bind (lmbd (&rest arglist) (funcall rule &rest realargs))
              action
            `(,lmbd ,(cons var arglist)

parser/fucc-parser.lisp

 #|
- Copyright (c) 2006 Ivan Boldyrev
+ Copyright (c) 2006-2008 Ivan Boldyrev
                                              
  Permission is hereby granted, free of charge, to any person obtaining
  a copy of this software and associated documentation files (the
                                 (list (first parser))))
         (atom-id)
         (data)
-        (context-info (sixth parser)))
+        (context-info (seventh parser)))
     (let ((lexer-fun (if context-info
                          #'(lambda (state)
                              (funcall lexer (aref context-info state)))
                    (if (eq action-type 'reduce-action)
                        (parser-lr--reduce! config action parser atom-id data) ; Reduction
                        ;;  Or error handling
-                       (error 'lr-parse-error-condition
-                              :token-id atom-id
-                              :data data
-                              :config config))
+                       (progn
+                         ;; Try recover error without help.  Find
+                         ;; error-handling state and generate CL:ERROR
+                         ;; token.
+                         (let ((states (lr-config-state-stack config))
+                               (datas  (lr-config-data-stack  config)))
+                           (loop :for sts :on states
+                              :for state := (first sts)
+                              :for action-type := (action-type (next-action state 'cl:error))
+                              :for dats :on datas
+                              :if (eq action-type 'shift-action) :do
+                              ;; Error-handling state found; error
+                              ;; recovery starts.  Unwind stack to the
+                              ;; state.
+                              (setf
+                               (lr-config-state-stack config) sts
+                               (lr-config-data-stack  config) dats)
+                              (process-token 'cl:error nil)
+                              ;; Look for possible sync tokens.  They
+                              ;; are just that can be shifted.
+                              (let ((tokens (cons nil
+                                                  (loop
+                                                     :for at-id :in (sixth parser)
+                                                     :if (member (action-type (get-action config at-id))
+                                                                 '(shift-action))
+                                                     :collect at-id))))
+                                (loop
+                                   ;; Hey, found something!
+                                   (when (member atom-id tokens)
+                                     (if atom-id 
+                                         (process-token atom-id data)
+                                         (error 'lr-parse-error-condition
+                                                :token-id atom-id
+                                                :data data
+                                                :config config))
+                                     (return-from process-token))
+                                   (multiple-value-setq (atom-id data) (funcall lexer-fun nil))))))
+                         (error 'lr-parse-error-condition
+                                :token-id atom-id
+                                :data data
+                                :config config)))
                  ;; Restarts
                  (skip-token ()
                    ;; Get next token