Permalink
Browse files

Fully working version

  • Loading branch information...
1 parent 519951c commit 6bf44dbb72af91e4fcdd8eaf9f531855792fc658 @vseloved committed Mar 22, 2010
Showing with 244 additions and 130 deletions.
  1. +2 −2 cl-parsec.asd
  2. +117 −64 core.lisp
  3. +10 −10 examples/arithmetic.lisp
  4. +31 −22 examples/better-veselov.lisp
  5. +2 −0 examples/veselov.lisp
  6. +22 −24 higher-order.lisp
  7. +4 −6 item-level.lisp
  8. +54 −0 packages.lisp
  9. +2 −2 simple.lisp
View
@@ -5,13 +5,13 @@
(defsystem #:cl-parsec
:name "Parser combinators"
- :version '(0 0 1)
+ :version '(0 1 1)
:maintainer "Vsevolod Dyomkin <vseloved@gmail.com>"
:licence "MIT"
:description "Parser combinators in plain ANSI CL without monads."
:depends-on (:rutils)
:serial t
- :components ((:file "package")
+ :components ((:file "packages")
(:file "core")
(:file "simple")
(:file "item-level")
View
@@ -7,15 +7,21 @@
;;; conditions
-(define-condition want-more (condition)
- ((features :initarg :features :initform nil :reader more-features)))
-
(define-condition parsec-error (simple-error)
((stack :initarg :stack :reader error-stack))
(:report (lambda (condition stream)
- (format stream "Parse error. Error stack: ~a"
+ (format stream "Parsing error. Error stack: ~a"
(error-stack condition)))))
+(define-condition parsec-signal (condition)
+ ((features :initarg :features :initform nil :accessor signal-features)))
+
+(define-condition parsec-success (parsec-signal)
+ ((result :initarg :result :reader parsing-result)))
+
+(define-condition try-success (parsec-signal)
+ ((backlog :initarg :backlog :reader parsing-backlog)))
+
(defun ?! (&optional reason prev-error)
"Signal PARSEC-ERROR with REASON on top of PREV-ERROR's stack.
\(Name stands for `Wtf?!')"
@@ -29,12 +35,14 @@
(defvar *stream* nil
"Items' input stream.")
+
(defvar *backlog* nil
"Items' backlog.")
+
(defvar *source* nil
"Current source for items.")
-(defvar *cur* nil
+(defvar *current-item* nil
"Current item (acquired from *SOURCE* in NEXT-ITEM).")
(defvar *echo-p* nil
@@ -46,95 +54,140 @@
;;; convenience macros
-(define-symbol-macro next-item
- (funcall (if *echo-p* #`(progn (format *echo-stream* "~:@c" _)
- _)
- #'identity)
- (setf *cur* (read-item (setf *source*
- (if *backlog* :backlog :stream))))))
-
-(define-symbol-macro last-item
- *cur*)
-
-(eval-always
- (defmacro mk-till-macro (name conditions)
- "Make a special-case wrapper macro for handling specific
-CONDITIONS with the name TILL-NAME (like TILL-ERR)."
- `(defmacro ,(mksym name :format "till-~a") ((&body reaction) &body action)
- `(handler-case (progn ,@action)
- (,',conditions () (progn ,@reaction)))))
-
- (mk-till-macro eof end-of-file)
- (mk-till-macro err parsec-error)
- (mk-till-macro end (or parsec-error end-of-file)))
+(defmacro next-item ()
+ "Sets *CURRENT-ITEM* to newly READ-ITEM from *STREAM* or *BACKLOG* and ~
+returns it."
+ (with-gensyms (cur)
+ `(prog1 (setf *source* (if *backlog* :backlog :stream)
+ *current-item* (read-item (or *backlog* *stream*)))
+ (when *echo-p*
+ (format *echo-stream* "~:@c" *current-item*)))))
;;; reading/unreading
(defgeneric read-item (source)
(:documentation "`Read' item from SOURCE.")
- (:method ((source (eql :stream)))
+ (:method ((source stream))
(read-char *stream*))
- (:method ((source (eql :backlog)))
+ (:method ((source list))
(pop *backlog*)))
(defgeneric unread-item (item source)
(:documentation "`Unread' item to SOURCE.")
- (:method (char (source (eql :stream)))
+ (:method ((char character) (source stream))
(unread-char char *stream*))
- (:method (item (source (eql :backlog)))
+ (:method (item (source list))
(push item *backlog*)))
+(defmacro unread-last-item ()
+ "Unread *CURRENT-ITEM* to current *SOURCE*."
+ `(unread-item *current-item*
+ (if (eq *source* :stream) *stream*
+ *backlog*)))
;;; parsing
(defun parse (stream parser)
- ""
+ "Parses STREAM with the given PARSER function. Binds specials."
(let ((*stream* stream)
- *cur*
*backlog*
- (*source* :stream))
- (handler-bind ((want-more #`(invoke-restart 'parse-more)))
- (funcall parser))))
-
-(defgeneric parse-test (test cur)
- (:documentation "")
- (:method ((test character) (cur character))
- (char= test cur))
- (:method ((test function) cur)
- (funcall test cur))
- (:method ((test list) cur)
- (apply (car test) cur (cdr test))))
+ (*source* :stream)
+ *current-item*)
+ (funcall parser)))
+
+(defgeneric parse-test (test item)
+ (:documentation "Convenience function to test the current element with TEST.
+Instead of writing: (apply test-fn item), we use (parse-test test item), where ~
+TEST may have various correspondence to TEST-FN, like:
+ * for chars: CHAR -> #`(char= CHAR _)
+ * for functions: FN -> FN
+ * for lists: LIST -> #`(apply (car LIST) _ (cdr LIST))
+")
+ (:method ((test character) (item character))
+ (char= test item))
+ (:method ((test function) item)
+ (funcall test item))
+ (:method ((test list) item)
+ (apply (car test) item (cdr test))))
(defmacro mkparser (test &optional (return :parsed))
- ""
- (with-gensyms (cur gtest greturn rez)
+ "Creates the parser, based on PARSE-TEST, that implemets the following logic:
+it reads the next item with NEXT-ITEM, checks it with PARSE-TEST,
+ * if test passes, it signals PARSEC-SUCCESS and returns
+ - the item (default case)
+ - TEST (if return = :test)
+ - otherwise RETURN itself
+ * otherwise it performs UNREAD-LAST-ITEM and signals PARSEC-ERROR."
+ (with-gensyms (cur item gtest greturn)
`(lambda ()
(let ((,gtest ,test)
- (,cur next-item)
(,greturn ,return)
- ,rez)
- (restart-case
- (prog1 (if (parse-test ,gtest ,cur)
- (setf ,rez (case ,greturn
- (:test ,gtest)
- (:parsed ,cur)
- (otherwise ,greturn)))
- (progn (unread-item last-item *source*)
- (?! `(parser ,,gtest))))
- (signal 'want-more))
- (parse-more () ,rez))))))
+ (,cur (next-item)))
+ (if (parse-test ,gtest ,cur)
+ (progn (signal 'parsec-success :result ,cur)
+ (case ,greturn
+ (:parsed ,cur)
+ (:test ,gtest)
+ (otherwise ,greturn)))
+ (progn (unread-last-item)
+ (?! `(parser ,,gtest))))))))
(declaim (inline parsecall))
(defun parsecall (test &optional (return :parsed))
- ""
+ "Funcall TEST as if it was already passed to MKPARSER. RETURN semantics ~
+repeats MKPARSER's one."
(funcall (mkparser test return)))
(defmacro defparser (name (&rest args) &body body)
- ""
- `(defmethod ,name (,@args)
- (handler-case
- (progn ,@body)
- (parsec-error (e) (?! ',name e)))))
+ "DEFUN a parser function with the given NAME and ARGS. BODY is wraped in ~
+HANDLER-CASE, that traps PARSEC-ERROR and resignalls it with NAME added to ~
+error stack.
+
+Provides internal variable _PARSER-NAME_.
+
+Intended for topl-level use, like DEFUN."
+ `(defun ,name (,@args)
+ ,(when (stringp (car body))
+ (car body))
+ (let ((_parser-name_ ',name))
+ (handler-case
+ (progn ,@body)
+ (parsec-error (e) (?! ',name e))))))
+
+
+;; parser DSL macros
+
+(defmacro intercept-signals (signal-name (&rest signal-bindings) &body body)
+ "Evaluate BODY, intercepting PARSEC-SIGNALs, that are specified in ~
+SIGNAL-BINDINGS as: (signal . handling code) and evaluating handling code ~
+inside the lambda binding of SIGNAL-NAME to current signal object.
+Afterwars _PARSER-NAME_ is added to signal's features to prevent multiple ~
+handling in the same parser."
+ `(handler-bind
+ (,@(mapcar (lambda (binding)
+ `(,(car binding)
+ (lambda (,signal-name)
+ (unless (member _parser-name_
+ (signal-features ,signal-name))
+ ,@(cdr binding))
+ (pushnew _parser-name_
+ (signal-features ,signal-name)))))
+ signal-bindings))
+ ,@body))
+
+(eval-always
+ (defmacro mk-if-macro (name conditions)
+ "Make a special-case wrapper macro for handling specific ~
+CONDITIONS with the name if-NAME (like IF-ERR)."
+ `(progn
+ (defmacro ,(mksym name :format "if-~a") (action &body body)
+ `(handler-case (progn ,@body)
+ (,',conditions () ,action)))
+ (export ',(mksym name :format "if-~a") (find-package :cl-parsec))))
+
+ (mk-if-macro eof end-of-file)
+ (mk-if-macro err parsec-error)
+ (mk-if-macro end (or parsec-error end-of-file)))
;;; end
@@ -1,20 +1,20 @@
(in-package :parsec-test)
+(defparser spaces ()
+ (skip-many #\Space))
+
(defparser expression ()
- (skip-many #\Space)
(prog1 (many+ #'tok)
- (skip-many #\Space)
+ (spaces)
(eof)))
(defparser tok ()
- (skip-many #\Space)
- (either (mkparser #'digit-char-p)
- (mkparser #\( :lparen)
- (mkparser #\) :rparen)
+ (spaces)
+ (either #`(parse-integer (coerce (many+ #`(parsecall #'digit-char-p))
+ 'string))
+ #`(parsecall #\( :lparen)
+ #`(parsecall #\) :rparen)
#'operator))
(defparser operator ()
- (list :op (string (either (mkparser #\-)
- (mkparser #\+)
- (mkparser #\*)
- (mkparser #\/)))))
+ (list :op (parsecall '(member (#\- #\+ #\* #\/)))))
@@ -1,46 +1,55 @@
-;;; http://dying-sphynx.livejournal.com/66854.html
+(in-package :parsec-test)
-(in-package :parsec)
+(defparser spaces ()
+ (skip-many #\Space))
(defparser expression ()
(prog1 (subexpression)
+ (spaces)
(eof)))
(defparser subexpression ()
- (skip-many #\Space)
+ (spaces)
(many+ #'element))
(defparser element ()
- (prog1 (either #`(try #'func)
- #'token
- #'operator)
- (skip-many #\Space)))
+ (spaces)
+ (either #`(try #'func)
+ #'token
+ #'operator))
(defparser token ()
(list :atom
- (coerce (many+ (mkparser #'alphanumericp))
+ (coerce (many+ #`(parsecall #'alphanumericp))
'string)))
(defparser operator ()
(list :op
- (either (mkparser #\-)
- (mkparser #\+)
- (mkparser #\*)
- (mkparser #\/)
- (mkparser #\^)
- (mkparser #\.))))
+ (parsecall '(member (#\- #\+ #\* #\/ #\^ #\.)))))
+
+(defvar *more-func-args* nil)
+
+(defparser func-arg ()
+ (prog1 (subexpression)
+ (setf *more-func-args* nil)
+ (spaces)
+ (either #`(look-ahead #\))
+ #`((parsecall #\,)
+ (setf *more-func-args* t)))))
+
+(defparser func-end ()
+ (spaces)
+ (parsecall #\)))
(defparser func ()
(nconc (list :func
(second (prog1 (token)
- (skip-many #\Space)
+ (spaces)
(parsecall #\())))
- (let ((args (prog1 (many #`(prog1 (subexpression)
- (either (mkparser #\,)
- #`(look-ahead #\)))))
- (skip-many #\Space)
- (parsecall #\)))))
- (when (listp args)
- args))))
+ (let (*more-func-args*)
+ (prog1 (many #'func-arg)
+ (when *more-func-args*
+ (?!))
+ (func-end)))))
;;; end
@@ -1,5 +1,7 @@
;;; http://dying-sphynx.livejournal.com/66854.html
+(in-package :parsec-test)
+
(defparser expression ()
(skip-many #\Space)
(prog1 (many+ #'tok)
Oops, something went wrong.

0 comments on commit 6bf44db

Please sign in to comment.