Permalink
Browse files

Working version 0.0.1

  • Loading branch information...
0 parents commit 519951cfef63f717912769bce5b0ab01c15d05c2 @vseloved committed Mar 18, 2010
Showing with 411 additions and 0 deletions.
  1. +8 −0 .gitignore
  2. +21 −0 README
  3. +45 −0 cl-parsec.asd
  4. +140 −0 core.lisp
  5. +20 −0 examples/arithmetic.lisp
  6. +46 −0 examples/better-veselov.lisp
  7. +35 −0 examples/veselov.lisp
  8. +48 −0 higher-order.lisp
  9. +29 −0 item-level.lisp
  10. +9 −0 package.lisp
  11. +10 −0 simple.lisp
@@ -0,0 +1,8 @@
+*~
+*.fasl
+\#*
+.\#*
+*.log
+tmp/*
+.*
+!.gitignore
21 README
@@ -0,0 +1,21 @@
+An experiment to create the analog of Haskell's Parsec library not on
+the basis of monads, but in ANSI CL, using the signal protocol,
+special variables and macros.
+
+Different test-cases are gathered in examples/.
+
+A note on terminology: these parsers are generic and can (in theory)
+work on other objects, than characters. Those objects could be called
+tokens, but this name is quite heavily used in parsers, so not to
+create confusion a different term is used: `items'.
+
+Example usage with the parser, defined in examples/better-veselov.lisp:
+
+CL-USER> (with-input-from-string (in "1 + 2-10 ^ ac1(ac+f(),2)")
+ (parse in 'expression))
+((:ATOM "1") (:OP #\+) (:ATOM "2") (:OP #\-) (:ATOM "10") (:OP #\^)
+ (:FUNC "ac1" ((:ATOM "ac") (:OP #\+) (:FUNC "f")) ((:ATOM "2"))))
+
+CL-USER> (with-input-from-string (in "1 + 2-10 ^ ac1(")
+ (parse in 'expression))
+=> Parse error. Error stack: ((EXPRESSION) (EOF))
@@ -0,0 +1,45 @@
+;;; CL-PARSEC system definition
+;;; (c) Vsevolod Dyomkin. See LICENSE file for permissions
+
+(in-package :asdf)
+
+(defsystem #:cl-parsec
+ :name "Parser combinators"
+ :version '(0 0 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")
+ (:file "core")
+ (:file "simple")
+ (:file "item-level")
+ (:file "higher-order")))
+
+
+#+:nuts
+(defmethod perform ((o test-op)
+ (c (eql (find-system 'cl-redis))))
+ (operate 'load-op '#:cl-parsec)
+ (operate 'test-op '#:cl-parsec-test :force t))
+
+#+:nuts
+(defsystem #:cl-parsec-test
+ :name "CL-PARSEC testsuite"
+ :version '(0 0 1)
+ :maintainer "Vsevolod Dyomkin <vseloved@gmail.com>"
+ :licence "MIT"
+ :description ""
+ :depends-on (:cl-parsec :nuts)
+ :serial t
+ :components ((:file "test")))
+
+#+:nuts
+(defmethod perform ((o test-op)
+ (c (eql (find-system 'cl-parsec-test))))
+ (operate 'load-op '#:cl-parsec-test)
+ (funcall (intern (symbol-name 'run-tests)
+ '#:parsec-test)))
+
+;;; end
140 core.lisp
@@ -0,0 +1,140 @@
+;;; CL-PARSEC core
+
+(in-package :parsec)
+
+(locally-enable-literal-syntax :sharp-backq)
+
+
+;;; 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"
+ (error-stack condition)))))
+
+(defun ?! (&optional reason prev-error)
+ "Signal PARSEC-ERROR with REASON on top of PREV-ERROR's stack.
+\(Name stands for `Wtf?!')"
+ (error 'parsec-error :stack (when reason
+ (cons (mklist reason)
+ (when prev-error
+ (error-stack prev-error))))))
+
+
+;;; specials
+
+(defvar *stream* nil
+ "Items' input stream.")
+(defvar *backlog* nil
+ "Items' backlog.")
+(defvar *source* nil
+ "Current source for items.")
+
+(defvar *cur* nil
+ "Current item (acquired from *SOURCE* in NEXT-ITEM).")
+
+(defvar *echo-p* nil
+ "Is debugging to *ECHO-STREAM* on?")
+
+(defvar *echo-stream* t
+ "Stream for debugging information.")
+
+
+;;; 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)))
+
+
+;;; reading/unreading
+
+(defgeneric read-item (source)
+ (:documentation "`Read' item from SOURCE.")
+ (:method ((source (eql :stream)))
+ (read-char *stream*))
+ (:method ((source (eql :backlog)))
+ (pop *backlog*)))
+
+(defgeneric unread-item (item source)
+ (:documentation "`Unread' item to SOURCE.")
+ (:method (char (source (eql :stream)))
+ (unread-char char *stream*))
+ (:method (item (source (eql :backlog)))
+ (push item *backlog*)))
+
+
+;;; parsing
+
+(defun parse (stream parser)
+ ""
+ (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))))
+
+(defmacro mkparser (test &optional (return :parsed))
+ ""
+ (with-gensyms (cur gtest greturn rez)
+ `(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))))))
+
+(declaim (inline parsecall))
+(defun parsecall (test &optional (return :parsed))
+ ""
+ (funcall (mkparser test return)))
+
+(defmacro defparser (name (&rest args) &body body)
+ ""
+ `(defmethod ,name (,@args)
+ (handler-case
+ (progn ,@body)
+ (parsec-error (e) (?! ',name e)))))
+
+;;; end
@@ -0,0 +1,20 @@
+(in-package :parsec-test)
+
+(defparser expression ()
+ (skip-many #\Space)
+ (prog1 (many+ #'tok)
+ (skip-many #\Space)
+ (eof)))
+
+(defparser tok ()
+ (skip-many #\Space)
+ (either (mkparser #'digit-char-p)
+ (mkparser #\( :lparen)
+ (mkparser #\) :rparen)
+ #'operator))
+
+(defparser operator ()
+ (list :op (string (either (mkparser #\-)
+ (mkparser #\+)
+ (mkparser #\*)
+ (mkparser #\/)))))
@@ -0,0 +1,46 @@
+;;; http://dying-sphynx.livejournal.com/66854.html
+
+(in-package :parsec)
+
+(defparser expression ()
+ (prog1 (subexpression)
+ (eof)))
+
+(defparser subexpression ()
+ (skip-many #\Space)
+ (many+ #'element))
+
+(defparser element ()
+ (prog1 (either #`(try #'func)
+ #'token
+ #'operator)
+ (skip-many #\Space)))
+
+(defparser token ()
+ (list :atom
+ (coerce (many+ (mkparser #'alphanumericp))
+ 'string)))
+
+(defparser operator ()
+ (list :op
+ (either (mkparser #\-)
+ (mkparser #\+)
+ (mkparser #\*)
+ (mkparser #\/)
+ (mkparser #\^)
+ (mkparser #\.))))
+
+(defparser func ()
+ (nconc (list :func
+ (second (prog1 (token)
+ (skip-many #\Space)
+ (parsecall #\())))
+ (let ((args (prog1 (many #`(prog1 (subexpression)
+ (either (mkparser #\,)
+ #`(look-ahead #\)))))
+ (skip-many #\Space)
+ (parsecall #\)))))
+ (when (listp args)
+ args))))
+
+;;; end
@@ -0,0 +1,35 @@
+;;; http://dying-sphynx.livejournal.com/66854.html
+
+(defparser expression ()
+ (skip-many #\Space)
+ (prog1 (many+ #'tok)
+ (eof)))
+
+(defparser tok ()
+ (prog1 (either #`(try #'func)
+ #'item
+ #'operator
+ (mkparser #\( :lparen)
+ (mkparser #\) :rparen)
+ (mkparser #\, :comma))
+ (skip-many #\Space)))
+
+(defparser item ()
+ (list :atom (coerce (many+ (mkparser #'alphanumericp))
+ 'string)))
+
+(defparser operator ()
+ (list :op (string (either (mkparser #\-)
+ (mkparser #\+)
+ (mkparser #\*)
+ (mkparser #\/)
+ (mkparser #\^)
+ (mkparser #\.)))))
+
+(defparser func ()
+ (list :func (coerce (second (prog1 (item)
+ (skip-many #\Space)
+ (look-ahead #\()))
+ 'string)))
+
+;;; end
@@ -0,0 +1,48 @@
+;;; CL-PARSEC higher-order parsers
+
+(in-package :parsec)
+
+(defparser many (parser)
+ "Returns all results of PARSER's application."
+ (let (rez)
+ (till-end ((reverse rez))
+ (loop (push (funcall parser) rez)))))
+
+(defparser many+ (parser)
+ "Returns all results of PARSER's application. PARSER should return
+successfully at least once."
+ (cons (funcall parser)
+ (many parser)))
+
+(defparser either (&rest parsers)
+ "If either of the PARSERS returns non-nil, return its result.
+Ordering matters.
+
+LL(1) variant. If it doesn't suit you, use this pattern:
+ (either (try ...))"
+ (dolist (parser parsers)
+ (till-err ()
+ (when-it (funcall parser)
+ (return-from either it))))
+ (?!))
+
+(defparser try (parser)
+ "Returns the result of PARSER's application or `unreads' all the
+read items back."
+ (let ((old-backlog *backlog*)
+ backlog)
+ (handler-bind ((want-more
+ (lambda (c)
+ (unless (member :try (more-features c))
+ (push last-item backlog)
+ (signal 'want-more
+ :features (cons :try
+ (more-features c)))))))
+ (till-end ((setf *backlog* (if (> (length old-backlog) (length backlog))
+ old-backlog
+ (nreverse backlog))
+ *source* :backlog)
+ nil)
+ (funcall parser)))))
+
+;;; end
Oops, something went wrong.

0 comments on commit 519951c

Please sign in to comment.