more work
authorD Herring <dherring@at.tentpost.dot.com>
Thu, 22 Mar 2012 02:39:37 +0000 (22:39 -0400)
committerD Herring <dherring@at.tentpost.dot.com>
Thu, 22 Mar 2012 02:39:37 +0000 (22:39 -0400)
tried to handle left-recursive grammars, but more work will be required

In particular, I almost implemented Paull's algorithm.
A->b1|...|bn is easy; invoke the normal rule for A, but have recursive A's fail.
A->a1 A'|...|am A' is not easy; it requires changing orders.
Invoking the original rule for A, and having recursive A return a known value almost works;
but distinguishing between a returned "A a" and a returned "b" is hard, especially with result rewriting.
("bi bj" probably isn't in the original rule, but could be synthesized by this approximation...)

Also note that the corner turn algorithm is more efficient.

examples/extensible-parser-example.lisp
extensible-parser.lisp

index a1c213c..ae6f8c3 100644 (file)
    (ascii-range #\A #\F)
    (ascii-range #\0 #\9)))
 
+(defmacro when-match (name rule &body body)
+  `(let ((,name ,rule))
+     (when ,name
+       (values ,name
+               ,@body))))
+
+;; these would need to be cpf expansion rules to be truly useful...
+(defmacro with-match (context context-symbols rule &body body)
+  (destructuring-bind (stringsym startsym aftersym endsym) context-symbols
+    (with-slots (string start end) context
+      `(let ((,aftersym (cpf-macro ,rule ,context)))
+         (when ,aftersym
+           (let ((,stringsym ,string)
+                 (,startsym ,start)
+                 (,endsym ,end))
+             ,@body))))))
+
+;; match-filter isn't very useful as it stands
+;; it might be usefule as a cpf-list method
+(defmacro match-filter (context context-symbols rule &body body)
+  (destructuring-bind (stringsym startsym aftersym endsym) context-symbols
+    (declare (ignore stringsym startsym endsym))
+    `(with-match ,context ,context-symbols ,rule
+       (values ,aftersym ,@body))))
+
+
+;; 2.3
+(defrule hex-quad
+  (and (hexadecimal-digit)
+       (hexadecimal-digit)
+       (hexadecimal-digit)
+       (hexadecimal-digit)))
+
+(defrule universal-character-name
+  (or (and "\u" (hex-quad))
+      (and "\U" (hex-quad) (hex-quad))))
+
+
+;; 2.10
+;; left recursion...
+(defrule pp-number
+  (or> (digit)
+       (and #\. (digit))
+       (and (pp-number) (digit))
+       (and (pp-number) (identifier-nondigit))
+       (and (pp-number) #\e (sign))
+       (and (pp-number) #\E (sign))
+       (and (pp-number) #\.)))
+
+;; explore solution to left recursion
+;; simulate (or (and (pp-number) (digit)) (digit))
+(defparameter *pp-start* (cons -1 nil))
+(defrule pp-number
+  (:cl
+   (progn
+     ;;(print (list start *pp-start*))
+     (cond
+       ;; based on Paull's algorithm
+       ;; two cases of sub-recursion
+       ;; http://en.wikipedia.org/wiki/Left_recursion#Accommodating_left_recursion_in_top-down_parsing
+       ;; given A -> A a1 | ... | A an | b1 | ... | bn
+       ;; substitute production
+
+       ;; A -> b1 A' | ... | bm A'
+       ;; (i.e. A always fails; then if anything passes, try the rule again)
+       ((eql (cdr *pp-start*) :fail)
+        nil)
+
+       ;; A' = eps | a1 A' | ... | an A'
+       ;; (i.e. A always returns a bogus value)
+       ((eql (cdr *pp-start*) :pass)
+        (values start nil))
+
+       ((and (= (car *pp-start*) start)
+             (cdr *pp-start*))
+        (values-list (cdr *pp-start*)))
+
+       ;; detect left-recursion and invoke the two rules
+       ((= (car *pp-start*) start) ; left-recursion first detected
+        (let (e1 v1 e2 v2)
+          ;; find one of the b's
+          (let ((*pp-start* (cons start :fail)))
+            (setf (values e1 v1)
+                  (:parse (or (and (pp-number) (digit)) (digit))))
+            (print :v1))
+          (unless e1
+            (return-from pp-number nil))
+
+          #|
+          ;; try to find one of the a's
+          (setf start e1) ; using a leaky detail...
+          (let ((*pp-start* (cons start nil)))
+            (setf (values e2 v2)
+                  (:parse (or (and (pp-number) (digit)) (digit)))))
+          (setf v2 (list v1 v2))
+          |#
+
+          #| alternative, only recurses a couple times...
+          |#
+          (setf e2 t)
+          (do ()
+              ((not e2))
+            (let ((*pp-start* (cons start (list e1 v1))))
+              (setf (values e2 v2)
+                    (:parse (or (and (pp-number) (digit)) (digit)))))
+            (when e2
+              (setf e1 e2
+                    start e1
+                    ;;v1 (cons v1 v2)
+                    )))
+            
+
+          ;(print *pp-start*)
+          (format t "~A~%" (list :v1 e1 v1 :v2 e2 v2))
+          #|
+          (if e2
+              (values e2 v2)
+              (values e1 (cons v1 nil)))))
+          |#
+          (values e1 v1)))
+       (t
+        (let ((*pp-start* (cons start nil)))
+          (:parse (or (and (pp-number) (digit)) (digit)))))))))
+
+#|
+ (defparameter *pp-number* nil)
+ (defun pp-number (string &OPTIONAL (START 0) (END (LENGTH STRING)))
+  (cond
+    ((equal (car *pp-number*) :recur)
+     nil)
+    ((find start *pp-number*)
+     ;; left recursion detected
+     (let ((*pp-number* (cons :recur *pp-number*)))
+  (if (find start *pp-number*)
+      ;; left recursion detected
+      (progn
+        ;; run, but fail on any further recursions
+        )
+      ;; normal operation
+      (let ((*pp-number* (cons start *pp-number*)))
+        
+      ))
+|#
+
+;; 2.11
+(defrule nondigit
+  (or (ascii-range #\a #\z)
+      (ascii-range #\A #\Z)
+      #\_))
+
+(defrule digit
+  (ascii-range #\0 #\9))
+
+(defrule identifier-nondigit
+  (or (nondigit)
+      (universal-character-name)
+      ;; other implementation-defined characters
+      ))
+
+;; left recursion...
+(defrule identifier
+  (or> (identifier-nondigit)
+       (and (identifier) (identifier-nondigit))
+       (and (identifier) (digit))))
+
+;; 2.12 -- see bottom of file
+
+;; 2.14
+(defrule nonzero-digit (ascii-range #\1 #\9))
+
+(defrule octal-digit (ascii-range #\0 #\7))
+
+(defrule hexadecimal-digit
+  (or
+   (ascii-range #\0 #\9)
+   (ascii-range #\a #\f)
+   (ascii-range #\A #\F)))
+
+(defrule decimal-literal
+  (or (nonzero-digit)
+      (and (decimal-literal) (digit))))
+
+(defrule octal-literal
+  (or #\0
+      (and (octal-literal) (octal-digit))))
+
+(defrule hexadecimal-literal
+  (or (and "0x" (hexadecimal-digit))
+      (and "0X" (hexadecimal-digit))
+      (and (hexadecimal-literal) (hexadecimal-digit))))
+
+(defrule integer-literal
+  (or (and (decimal-literal) (optional (integer-suffix)))
+      (and (octal-literal) (optional (integer-suffix)))
+      (and (hexadecimal-literal) (optional (integer-suffix)))))
+
 ;; Integer            = (("0" [xX] HexDigit+) | ("0" OctalDigit*) | ([1-9] Digit*));
 (defrule r-integer
   (or
    (:cl
-    (let ((match (:parse (and #\0 (or #\x #\X) (repeat 1 nil (hex-digit))))))
-      (when match
-        (values match
-                (parse-integer (subseq string (+ start 2) match) :radix 16)))))
+    (when-match match (:parse (and #\0 (or #\x #\X) (repeat 1 nil (hex-digit))))
+      (parse-integer (subseq string (+ start 2) match) :radix 16)))
+   #|
+   ;; alternate implementation of previous clause
+   (:cl
+    (match-filter (:context) (string start after end)
+        (and #\0 (or #\x #\X) (repeat 1 nil (hex-digit)))
+      (parse-integer (subseq string (+ start 2) after) :radix 16)))
+   |#
    (:cl
-    (let ((match (:parse (and #\0 (repeat 0 nil (octal-digit))))))
-      (when match
-        (values match
-                (parse-integer (subseq string (+ start 1) match) :radix 8)))))
+    (when-match match (:parse (and #\0 (repeat 0 nil (octal-digit))))
+      (parse-integer (subseq string (+ start 1) match) :radix 8)))
    (:cl
-    (let ((match (:parse (and (ascii-range #\1 #\9) (repeat 0 nil (digit))))))
-      (when match
-        (values match
-                (parse-integer (subseq string start match) :radix 10)))))))
+    (when-match match (:parse (and (ascii-range #\1 #\9) (repeat 0 nil (digit))))
+      (parse-integer (subseq string start match) :radix 10)))))
 
 ;; ExponentStart      = [Ee] [+-];
 (defrule exponent-start
 
 ;; ExponentPart       = [Ee] [+-]? Digit+;
 (defrule exponent-part
-    (and (or #\E #\e)
-         (repeat 0 1 (or #\+ #\-))
-         (repeat 1 * digit)))
+  (and (or #\E #\e)
+       (repeat 0 1 (or #\+ #\-))
+       (repeat 1 nil (digit))))
 
 ;; FractionalConstant = (Digit* "." Digit+) | (Digit+ ".");
 (defrule fractional-constant
-    (or (and (repeat 0 * digit) #\. (repeat 1 * digit))
-        (and (repeat 1 * digit) #\.)))
+  (or (and (repeat 0 nil (digit)) #\. (repeat 1 nil (digit)))
+      (and (repeat 1 nil (digit)) #\.)))
 
 ;; FloatingSuffix     = [fF] [lL]? | [lL] [fF]?;
 (defrule floating-suffix
-    (or (and (or #\f #\F) (repeat 0 1 (or #\l #\L)))
-        (and (or #\l #\L) (repeat 0 1 (or #\f #\F)))))
+  (or (and (or #\f #\F) (repeat 0 1 (or #\l #\L)))
+      (and (or #\l #\L) (repeat 0 1 (or #\f #\F)))))
 
 ;; IntegerSuffix      = [uU] [lL]? | [lL] [uU]?;
 (defrule integer-suffix
-    (or (and (or #\u #\U) (repeat 0 1 (or #\l #\L)))
-        (and (or #\l #\L) (repeat 0 1 (or #\u #\U)))))
+  (or (and (or #\u #\U) (repeat 0 1 (or #\l #\L)))
+      (and (or #\l #\L) (repeat 0 1 (or #\u #\U)))))
 
 ;; LongIntegerSuffix  = [uU] ([lL] [lL]) | ([lL] [lL]) [uU]?;
 (defrule long-integer-suffix
+  (or (and (or #\u #\U) 
+  
 Backslash          = [\\] | "??/";
 EscapeSequence     = Backslash ([abfnrtv?'"] | Backslash | "x" HexDigit+ | OctalDigit OctalDigit? OctalDigit?);
 HexQuad            = HexDigit HexDigit HexDigit HexDigit;
@@ -125,3 +324,95 @@ NonDigit           = [a-zA-Z_$] | UniversalChar;
                (repeat 0 * (exception any (or slash-v slash-f slash-n)))
                (repeat 0 * (or slash-v slash-f (exception whitespace slash-n)))
                slash-n)))))
+
+
+
+;; 2.12
+;; these apply to full tokens...
+(defrule keywords
+  (or "alignas"
+      "alignof"
+      "asm"
+      "auto"
+      "bool"
+      "break"
+      "case"
+      "catch"
+      "char"
+      "char16_t"
+      "char32_t"
+      "class"
+      "const"
+      "constexpr"
+      "const_cast"
+      "continue"
+      "decltype"
+      "default"
+      "delete"
+      "do"
+      "double"
+      "dynamic_cast"
+      "else"
+      "enum"
+      "explicit"
+      "export"
+      "extern"
+      "false"
+      "float"
+      "for"
+      "friend"
+      "goto"
+      "if"
+      "inline"
+      "int"
+      "long"
+      "mutable"
+      "namespace"
+      "new"
+      "noexcept"
+      "nullptr"
+      "operator"
+      "private"
+      "protected"
+      "public"
+      "register"
+      "reinterpret_cast"
+      "return"
+      "short"
+      "signed"
+      "sizeof"
+      "static"
+      "static_assert"
+      "static_cast"
+      "struct"
+      "switch"
+      "template"
+      "this"
+      "thread_local"
+      "throw"
+      "true"
+      "try"
+      "typedef"
+      "typeid"
+      "typename"
+      "union"
+      "unsigned"
+      "using"
+      "virtual"
+      "void"
+      "volatile"
+      "wchar_t"
+      "while"))
+
+(defrule alternative-representations
+  (or "and"
+      "and_eq"
+      "bitand"
+      "bitor"
+      "compl"
+      "not"
+      "not_eq"
+      "or"
+      "or_eq"
+      "xor"
+      "xor_eq"))
\ No newline at end of file
index 8a13886..3e81ee4 100644 (file)
@@ -218,7 +218,8 @@ or to allow changes to the rule,
 (defvar *parse-rules* (make-hash-table)
   "hashtable of the rules that have been defined.  For each rule name, there is a property list recording possible expansions.  The key :source returns the original form.  Context indicators may return pre-compiled forms.")
 
-(defun get-parse-rule (key context)
+#| work-in-progress
+ (defun get-parse-rule (key context)
   "look up (or create) a parse rule for the given key and context"
   (let* ((props (gethash key *parse-rules*))
          (nonce (gensym))
@@ -231,6 +232,7 @@ or to allow changes to the rule,
                 
     
   )))))
+|#
 
 ;; store an alist (or plist) for each key
 ;; look up the context (the :form context returns the original source)
@@ -267,22 +269,28 @@ or to allow changes to the rule,
 
 (defmethod cpf-list ((car (eql :parse)) form context env)
   (error ":parse not in :cl - ~S" form))
-          
+
+(defmethod cpf-list ((car (eql :context)) form context env)
+  (error ":context not in :cl - ~S" form))
+
 
 (defun expand-nested-parse (form context &optional (key :parse))
   ;; don't pass env; it will be picked up by the call site...
-  "destructively recurse through the form, expanding (:parse x) into a (cpf x) call site"
+  "Destructively recurse through the form, expanding (:parse x) into a (cpf x) call site.  Also expands (:context) to the parse context object (e.g. for macros)."
   (when (listp form)
     ;; in (x1 x2 x3), replace xi if it matches (key y)
     (mapl (lambda (x)
             (let ((c (car x)))
               (when (listp c)
-                (if (eql (car c) key)
-                    (progn
-                      (unless (= (length c) 2)
-                        (error "expected (:parse rule), got ~S" c))
-                      (setf (car x) `(cpf-macro ,(cadr c) ,context)))
-                    (expand-nested-parse c context key)))))
+                (cond
+                  ((eql (car c) key)
+                   (unless (= (length c) 2)
+                     (error "expected (:parse rule), got ~S" c))
+                   (setf (car x) `(cpf-macro ,(cadr c) ,context)))
+                  ((equal c (list :context))
+                   (setf (car x) context))
+                  (t
+                   (expand-nested-parse c context key))))))
           form))
   form)
 
@@ -291,7 +299,8 @@ or to allow changes to the rule,
   ;; should this bind a new context?  skip for now...
   (unless (= (length form) 2)
     (error "expected (:cl form), got ~S" form))
-  (expand-nested-parse (cadr form) context))
+  ;; need to wrap and unwrap the argument so (:cl (:parse ...)) works
+  (car (expand-nested-parse (cdr form) context)))
 
 (defrule test-cl
   (:cl (and (:parse "hi"))))
@@ -414,6 +423,36 @@ or to allow changes to the rule,
          last))
       `(block ,blocksym ,inner))))
 
+(defmethod cpf-list ((car (eql 'or>)) form context env)
+  "return the rule that has the longest match"
+  (unless (cdr form) ; style tweak, doesn't change runtime, mimics (cl:or)
+    (return-from cpf-list nil))
+  (with-slots (string start end) context
+    (let* ((args (cdr form))
+           (blocksym (gensym (symbol-name :or-)))
+           (endsym (gensym (symbol-name :end-)))
+           (valsym (gensym (symbol-name :val-)))
+           (bestendsym (gensym (symbol-name :bestend-)))
+           (bestvalsym (gensym (symbol-name :bestval-)))
+           (inner
+            `(let* (,endsym ,valsym (,bestendsym ,start) ,bestvalsym)))
+           (last (last inner 1)))
+      (dolist (f args)
+        (pushback
+         `(setf (values ,endsym ,valsym) ,(cpf f context env))
+         last)
+        (pushback
+         `(when (and ,endsym (> ,endsym ,bestendsym))
+            (setf ,bestendsym ,endsym
+                  ,bestvalsym ,valsym))
+         last))
+      (pushback
+       `(when ,bestendsym
+          (values ,bestendsym ,bestvalsym))
+       last)
+      `(block ,blocksym ,inner))))
+
+
 (defrule test-or0 (or (or) "hi"))
 
 (defrule test-or
@@ -425,6 +464,8 @@ or to allow changes to the rule,
   (and (or "a" "b")
        (or "c" "d")))
 
+(defmethod cpf-list ((car (eql 'optional)) form context env)
+  (cpf (cons 'repeat (cons 0 (cons 1 (cdr form)))) context env))
 
 (defmethod cpf-list ((car (eql 'repeat)) form context env)
   "(repeat min max form) where min is 0 or more and max is an integer or nil for unlimited"
@@ -480,10 +521,12 @@ or to allow changes to the rule,
 
 ;;;; ARRAY IMPLEMENTATION
 
-(defmethod cfp ((form string) (context array-context))
+#| stale
+ (defmethod cfp ((form string) (context array-context))
   "match a string in the array"
   (with-slots (array start) context
     (values
      `(when (string= ,form (aref ,array ,start))
         (values ,form (1+ ,start)))
      t)))
+|#
\ No newline at end of file