nix-archive-1(type directoryentry(namesharenode(type directoryentry(name common-lispnode(type directoryentry(namesourcenode(type directoryentry(name cl-proc-parsenode(type directoryentry(name .gitignorenode(typeregularcontents<*.fasl *.dx32fsl *.dx64fsl *.lx32fsl *.lx64fsl *.x86f *~ .#*))entry(name .travis.ymlnode(typeregularcontentsDlanguage: common-lisp sudo: required env: global: - PATH=~/.roswell/bin:$PATH - ROSWELL_BRANCH=release - ROSWELL_INSTALL_DIR=$HOME/.roswell - COVERAGE_EXCLUDE=t matrix: - LISP=sbcl-bin COVERALLS=true - LISP=ccl-bin - LISP=abcl - LISP=clisp - LISP=ecl - LISP=allegro - LISP=cmucl install: # Install Roswell - curl -L https://raw.githubusercontent.com/snmsts/roswell/$ROSWELL_BRANCH/scripts/install-for-ci.sh | sh - ros install prove before_script: - ros --version - ros config script: - run-prove proc-parse-test.asd ))entry(nameREADME.markdownnode(typeregularcontents"# Proc-Parse [![Build Status](https://travis-ci.org/fukamachi/proc-parse.svg?branch=master)](https://travis-ci.org/fukamachi/proc-parse) [![Coverage Status](https://coveralls.io/repos/fukamachi/proc-parse/badge.svg?branch=master)](https://coveralls.io/r/fukamachi/proc-parse)
Question: Are these parser macros for speed or just to make your application look cool?
Answer: Both.
This is a string/octets parser library for Common Lisp with speed and readability in mind. Unlike other libraries, the code is not a pattern-matching-like, but a char-by-char procedural parser. Although the design is good for speed, the code could look ugly with `tagbody` and `go`. Proc-Parse wraps the code with sexy macros. I believe we don't have to give up speed for the readability while we use Common Lisp. ## Usage ```common-lisp (defun parse-url-scheme (data &key (start 0) end) "Return a URL scheme of DATA as a string." (declare (optimize (speed 3) (safety 0) (debug 0))) (block nil (with-vector-parsing (data :start start :end end) (match-i-case ("http:" (return "http")) ("https:" (return "https")) (otherwise (unless (standard-alpha-char-p (current)) (return nil)) (bind (scheme (skip* (not #\:))) (return scheme))))))) ``` ## API ### with-vector-parsing - can parse both string and octets. ```Lisp (with-vector-parsing ("It's Tuesday!" :start 5 :end 12) (bind (str (skip-until (lambda (c) (declare (ignore c)) (eofp)))) (print str))) ; "Tuesday" (with-vector-parsing ((babel:string-to-octets "It's Tuesday!") :start 5 :end 12) (bind (str (skip-until (lambda (c) (declare (ignore c)) (eofp)))) (print str))) ; "Tuesday" ``` ### with-string-parsing - can parse string. ```Lisp (with-string-parsing ("It's Tuesday!" :start 5 :end 12) (bind (str (skip-until (lambda (c) (declare (ignore c)) (eofp)))) (print str))) ; "Tuesday" ``` ### with-octets-parsing - can parse octets. ```Lisp (with-octets-parsing ((babel:string-to-octets "It's Tuesday!") :start 5 :end 12) (bind (str (skip-until (lambda (c) (declare (ignore c)) (eofp)))) (print str))) ; "Tuesday" ``` ### eofp - can return EOF or not. ```Lisp (with-vector-parsing ("hello") (print (eofp)) ; NIL (match "hello") (print (eofp))) ; T ``` ### current - can return the character of the current position. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (skip #\h) (print (current))) ; #\e ``` ### peek - can peek next character from the current position ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (print (peek)) ; #\e (print (current))) ; #\h ``` - and you can specify the eof-value ```Lisp (with-vector-parsing ("hello") (match "hell") (print (pos)) ; #\4 (print (peek :eof-value 'yes))) ; YES ``` ### pos - can return the current position. ```Lisp (with-vector-parsing ("hello") (print (pos)) ; 0 (skip #\h) (print (pos))) ; 1 ``` ### advance - can put the current postion forward. - can cease parsing with EOF. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (advance) (print (current)) ; #\e (match "ello") (print (current)) ; #\o (advance) (print "Hi")) ; "Hi" won't displayed. ``` ### advance* - can put the current postion forward. - just returns NIL with EOF. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (advance*) (print (current)) ; #\e (match "ello") (print (current)) ; #\o (advance*) (print (current)) ; #\o (print "Hi")) ; "Hi" ``` ### skip - can skip the specified character. - can raise MATCH-FAILED error with unmatched characters. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (skip #\h) (print (current)) ; #\e (skip (not #\h)) (print (current)) ; #\l (skip #\f)) ;; => Condition MATCH-FAILED was signalled. ``` ### skip* - can skip some straignt specified characters. - just returns NIL with unmatched characters. ```Lisp (with-vector-parsing ("hello") (skip* #\h) (print (current)) ; #\e (skip* (not #\l)) (print (current)) ; #\l (skip* #\l) (print (current)) ; #\o (skip* #\f)) ; MATCH-FAILED won't be raised. ``` ### skip+ - can skip some straignt specified characters. - can raise MATCH-FAILED error with unmatched characters. ```Lisp (with-vector-parsing ("hello") (skip+ #\h) (print (current)) ; #\e (skip* (not #\l)) (print (current)) ; #\l (skip+ #\l) (print (current)) ; #\o (skip+ #\f)) ;; => Condition MATCH-FAILED was signalled. ``` ### skip? - can skip the specified character. - just returns NIL with unmatched characters. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (skip? #\h) (print (current)) ; #\e (skip? (not #\h)) (print (current)) ; #\l (skip? #\f)) ; MATCH-FAILED won't be raised. ``` ### skip-until - can skip until form returned T or parsing reached EOF. ```Lisp (with-vector-parsing ("hello") (skip-until (lambda (char) (char= char #\o))) (print (current)) ; #\o (print (eofp)) ; NIL (skip-until (lambda (char) (char= char #\f))) (print (eofp))) ; T ``` ### skip-while - can skip while form returns T and parsing doesn't reach EOF. ```Lisp (with-vector-parsing ("hello") (skip-while (lambda (char) (char/= char #\o))) (print (current)) ; #\o (print (eofp)) ; NIL (skip-while (lambda (char) (char/= char #\f))) (print (eofp))) ; T ``` ### bind - can bind subseqed string. ```Lisp (with-vector-parsing ("hello") (bind (str1 (skip-until (lambda (c) (char= c #\l)))) (print str1)) ; "he" (bind (str2 (skip* (not #\f))) (print str2))) ; "llo" ``` ### match - can skip matched one of the specified strings. - can raise MATCH-FAILED error with unmatched characters. ```Lisp (with-vector-parsing ("hello") (match "he") (print (current)) ; #\l (match "l" "ll") (print (current)) ; #\o (match "f")) ;; => Condition MATCH-FAILED was signalled. ``` ### match-i - can skip case-insensitively matched one of the specified strings. - can raise MATCH-FAILED error with case-insensitively unmatched characters. ```Lisp (with-vector-parsing ("hello") (match-i "He") (print (current)) ; #\l (match-i "L" "LL") (print (current)) ; #\o (match-i "F")) ;; => Condition MATCH-FAILED was signalled. ``` ### match? - can skip matched one of the specified strings. - just returns NIL with unmatched characters. ```Lisp (with-vector-parsing ("hello") (match? "he") (print (current)) ; #\l (match? "l" "ll") (print (current)) ; #\o (match? "f")) ; MATCH-FAILED won't be raised. ``` ### match-case - can dispatch to the matched case. - aborts parsing when reaching EOF. ```Lisp (with-vector-parsing ("hello") (match-case ("he" (print 0)) ("ll" (print 1)) (otherwise (print 2))) ; 0 (print (current)) ; #\l (match-case ("he" (print 0)) ("ll" (print 1)) (otherwise (print 2))) ; 1 (print (current)) ; #\o (match-case ("he" (print 0)) ("ll" (print 1)) (otherwise (print 2))) ; 2 (print (current)) ; #\o (match-case ("he" (print 0)) ("ll" (print 1)))) ;; => Condition MATCH-FAILED was signalled. (with-vector-parsing ("hello") (print (match-case ("hello" 0))) ;; Nothing will be printed. (print "It shold not be printed.")) ;; Nothing will be printed. ;; => NIL ``` ### match-i-case - can dispatch to the case-insensitively matched case. - aborts parsing when reaching EOF. ```Lisp (with-vector-parsing ("hello") (match-i-case ("He" (print 0)) ("LL" (print 1)) (otherwise (print 2))) ; 0 (print (current)) ; #\l (match-i-case ("He" (print 0)) ("LL" (print 1)) (otherwise (print 2))) ; 1 (print (current)) ; #\o (match-i-case ("He" (print 0)) ("LL" (print 1)) (otherwise (print 2))) ; 2 (print (current)) ; #\o (match-i-case ("He" (print 0)) ("LL" (print 1)))) ;; => Condition MATCH-FAILED was signalled. (with-vector-parsing ("hello") (print (match-i-case ("Hello" 0))) ;; Nothing will be printed. (print "It shold not be printed.")) ;; Nothing will be printed. ;; => NIL ``` ### match-failed - is the condition representing failure of matching. ```Lisp (with-vector-parsing ("hello") (print (current)) ; #\h (skip #\f)) ;; => Condition MATCH-FAILED was signalled. ``` ## Author * Eitaro Fukamachi * Rudolph Miller ## Copyright Copyright (c) 2015 Eitaro Fukamachi & Rudolph Miller ## License Licensed under the BSD 2-Clause License. ))entry(nameproc-parse-test.asdnode(typeregularcontentsŒ#| This file is a part of proc-parse project. Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) |# (in-package :cl-user) (defpackage proc-parse-test-asd (:use :cl :asdf)) (in-package :proc-parse-test-asd) (defsystem proc-parse-test :author "Eitaro Fukamachi" :license "BSD 2-Clause" :depends-on (:proc-parse :prove) :components ((:module "t" :components ((:test-file "proc-parse")))) :defsystem-depends-on (:prove-asdf) :perform (test-op :after (op c) (funcall (intern #.(string :run-test-system) :prove-asdf) c) (asdf:clear-system c))) ))entry(nameproc-parse.asdnode(typeregularcontentsœ#| This file is a part of proc-parse project. Copyright (c) 2015 Eitaro Fukamachi (e.arrows@gmail.com) |# #| Author: Eitaro Fukamachi (e.arrows@gmail.com) |# (in-package :cl-user) (defpackage proc-parse-asd (:use :cl :asdf)) (in-package :proc-parse-asd) (defsystem proc-parse :version "0.1" :author "Eitaro Fukamachi" :license "BSD 2-Clause" :depends-on (:alexandria :babel #+sbcl :sb-cltl2) :components ((:module "src" :components ((:file "proc-parse")))) :description "Procedural vector parser" :long-description #.(with-open-file (stream (merge-pathnames #p"README.markdown" (or *load-pathname* *compile-file-pathname*)) :if-does-not-exist nil :direction :input) (when stream (let ((seq (make-array (file-length stream) :element-type 'character :fill-pointer t))) (setf (fill-pointer seq) (read-sequence seq stream)) seq))) :in-order-to ((test-op (test-op proc-parse-test)))) ))entry(namesrcnode(type directoryentry(nameproc-parse.lispnode(typeregularcontents3S(in-package :cl-user) (defpackage proc-parse (:use :cl) #+(or sbcl openmcl cmu allegro lispworks) (:import-from #+sbcl :sb-cltl2 #+openmcl :ccl #+cmu :ext #+allegro :sys #+lispworks :hcl :variable-information) (:import-from :alexandria :with-gensyms :once-only :ensure-cons :ignore-some-conditions) (:export :with-vector-parsing :with-string-parsing :with-octets-parsing :eofp :current :peek :eof-value :pos :advance :advance* :advance-to :advance-to* :skip :skip* :skip+ :skip? :skip-until :skip-while :bind :match :match-i :match? :match-case :match-i-case :match-failed) (:use :cl)) (in-package :proc-parse) (define-condition match-failed (error) ((elem :initarg :elem :initform nil) (expected :initarg :expected :initform nil)) (:report (lambda (condition stream) (with-slots (elem expected) condition (format stream "Match failed~:[~;~:*: ~S~]~:[~;~:* (expected: ~{~S~^, ~})~]" (ensure-char-elem elem) expected))))) (defun convert-case-conditions (var chars) (cond ((consp chars) `(or ,@(loop for ch in chars if (characterp ch) collect `(char= ,var ,ch) else collect `(= ,var ,ch)))) ((eq chars 'otherwise) t) (t (if (characterp chars) `(char= ,var ,chars) `(= ,var ,chars))))) (defun typed-case-tagbodies (var &rest cases) (cond ((null cases) nil) ((= 1 (length cases)) `((when ,(convert-case-conditions var (car (first cases))) ,@(cdr (first cases))))) ((and (= 2 (length cases)) (eq (car (second cases)) 'otherwise)) `((unless ,(convert-case-conditions var (car (first cases))) ,@(cdr (second cases))) ,@(cdr (first cases)))) (t (let ((tags (make-array (length cases) :initial-contents (loop repeat (length cases) collect (gensym)))) (end (gensym "END"))) `(,@(loop for (chars . body) in cases for i from 0 collect `(when ,(convert-case-conditions var chars) (go ,(aref tags i)))) ,@(loop for case in cases for i from 0 append `(,(aref tags i) ,@(cdr case) (go ,end))) ,end))))) (defmacro vector-case (elem-var vec-and-options &body cases) (destructuring-bind (vec &key case-insensitive) (ensure-cons vec-and-options) (with-gensyms (otherwise end-tag vector-case-block) (labels ((case-candidates (el) (cond ((not case-insensitive) el) ((characterp el) (cond ((char<= #\a el #\z) `(,el ,(code-char (- (char-code el) #.(- (char-code #\a) (char-code #\A)))))) ((char<= #\A el #\Z) `(,el ,(code-char (+ (char-code el) #.(- (char-code #\a) (char-code #\A)))))) (t el))) ((typep el '(unsigned-byte 8)) (cond ((<= #.(char-code #\a) el #.(char-code #\z)) `(,el ,(- el #.(- (char-code #\a) (char-code #\A))))) ((<= #.(char-code #\A) el #.(char-code #\Z)) `(,el ,(+ el #.(- (char-code #\a) (char-code #\A))))) (t el))) (t el))) (build-case (i cases vec) (when cases (let ((map (make-hash-table))) (map nil (lambda (case) (unless (vectorp (car case)) (error "The first element of cases must be a constant vector")) (unless (<= (length (car case)) i) (push case (gethash (aref (car case) i) map)))) cases) (let (res-cases) (maphash (lambda (el cases) (let ((next-case (build-case (1+ i) cases vec))) (cond (next-case (push `(,(case-candidates el) (unless (advance*) ,(if (= (length (caar cases)) (1+ i)) `(progn ,@(cdr (car cases)) (go ,end-tag)) `(go :eof))) ,@(apply #'typed-case-tagbodies elem-var (append next-case `((otherwise (go ,otherwise)))))) res-cases)) (t (push `(,(case-candidates el) (advance*) (return-from ,vector-case-block (progn ,@(cdr (car cases))))) res-cases))))) map) res-cases))))) (let ((otherwise-case nil)) (when (eq (caar (last cases)) 'otherwise) (setq otherwise-case (car (last cases)) cases (butlast cases))) `(block ,vector-case-block (tagbody ,@(apply #'typed-case-tagbodies elem-var (append (build-case 0 cases vec) `((otherwise (go ,otherwise))))) (go ,end-tag) ,otherwise ,@(when otherwise-case `(unless (eofp) (return-from ,vector-case-block (progn ,@(cdr otherwise-case))))) ,end-tag))))))) (defun variable-type (var &optional env) (declare (ignorable env)) (cond ((constantp var) (type-of var)) #+(or sbcl openmcl cmu allegro) ((and (symbolp var) #+allegro (cadr (assoc 'type (nth-value 2 (variable-information var env)))) #-allegro (cdr (assoc 'type (nth-value 2 (variable-information var env)))))) ((and (listp var) (eq (car var) 'the) (cadr var))))) (deftype octets (&optional (len '*)) `(simple-array (unsigned-byte 8) (,len))) (defun variable-type* (var &optional env) (let ((type (variable-type var env))) (cond ((null type) nil) ((subtypep type 'string) 'string) ((subtypep type 'octets) 'octets)))) (defun check-skip-elems (elems) (or (every (lambda (elem) (or (characterp elem) (and (consp elem) (null (cddr elem)) (eq (first elem) 'not) (characterp (second elem))))) elems) (error "'skip' takes only constant characters, or a cons starts with 'not'."))) (defun check-match-cases (cases) (or (every (lambda (case) (and (consp case) (or (eq (car case) 'otherwise) (stringp (car case))))) cases) (error "'match-case' takes only constant strings at the car position.~% ~S" cases))) (defmacro bind ((symb &body bind-forms) &body body) (declare (ignore symb bind-forms body))) (defmacro subseq* (data start &optional end) `(subseq ,data ,start ,end)) (defmacro get-elem (form) form) (defun ensure-char-elem (elem) (if (characterp elem) elem (code-char elem))) (defmacro tagbody-with-match-failed (elem &body body) (with-gensyms (block) `(block ,block (tagbody (return-from ,block ,@body) :match-failed (error 'match-failed :elem ,elem))))) (defmacro parsing-macrolet ((elem data p end) (&rest macros) &body body) `(macrolet ((advance (&optional (step 1)) `(or (advance* ,step) (go :eof))) (advance* (&optional (step 1)) `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (incf ,',p ,step) ,@(if (eql step 0) () `((if (<= ,',end ,',p) nil (progn (setq ,',elem (aref ,',data ,',p)) t)))))) (advance-to (to) `(or (advance-to* ,to) (go :eof))) (advance-to* (to) (once-only (to) `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (check-type ,to fixnum) (setq ,',p ,to) (if (<= ,',end ,',p) nil (progn (setq ,',elem (aref ,',data ,',p)) t))))) (skip (&rest elems) (check-skip-elems elems) `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (if (skip-conditions ,',elem ,elems) (advance) (error 'match-failed :elem ,',elem :expected ',elems)))) (skip* (&rest elems) (check-skip-elems elems) `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (unless (eofp) (loop (unless (skip-conditions ,',elem ,elems) (return)) (or (advance*) (go :eof)))))) (skip+ (&rest elems) `(progn (skip ,@elems) (skip* ,@elems))) (skip? (&rest elems) (check-skip-elems elems) `(locally (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0))) (when (skip-conditions ,',elem ,elems) (or (advance*) (go :eof))))) (skip-until (fn) `(loop until ,(if (symbolp fn) `(,fn (get-elem ,',elem)) `(funcall ,fn (get-elem ,',elem))) do (or (advance*) (go :eof)))) (skip-while (fn) `(loop while ,(if (symbolp fn) `(,fn (get-elem ,',elem)) `(funcall ,fn (get-elem ,',elem))) do (or (advance*) (go :eof)))) (bind ((symb &body bind-forms) &body body) (with-gensyms (start) `(let ((,start ,',p)) (tagbody ,@bind-forms :eof) (prog1 (let ((,symb (subseq* ,',data ,start ,',p))) ,@body) (when (eofp) (go :eof)))))) (%match (&rest vectors) `(%match-case ,@(loop for vec in vectors collect `(,vec)))) (match (&rest vectors) `(block match-block (tagbody (return-from match-block (%match ,@vectors)) :match-failed (error 'match-failed :elem ,',elem)))) (match? (&rest vectors) (with-gensyms (start start-elem) `(let ((,start ,',p) (,start-elem ,',elem)) (block match?-block (tagbody (%match ,@vectors) (return-from match?-block t) :match-failed (setq ,',p ,start ,',elem ,start-elem)))))) (match-i (&rest vectors) `(match-i-case ,@(loop for vec in vectors collect `(,vec)))) ,@macros) #+sbcl (declare (sb-ext:muffle-conditions sb-ext:code-deletion-note)) (labels ((eofp () (declare (optimize (speed 3) (safety 0) (debug 0))) (<= ,end ,p)) (current () (get-elem ,elem)) (peek (&key eof-value) (declare (optimize (speed 3) (safety 0) (debug 0))) (let ((len (length ,data))) (declare (type fixnum len)) (if (or (eofp) (>= ,p (- ,end 1)) (= ,p (- len 1))) eof-value (aref ,data (+ 1 ,p))))) (pos () (the fixnum ,p))) (declare (inline eofp current pos)) ,@body))) (defmacro with-string-parsing ((data &key start end) &body body) (with-gensyms (g-end elem p body-block) (once-only (data) `(let ((,elem #\Nul) (,p ,(if start `(or ,start 0) 0)) (,g-end ,(if end `(or ,end (length ,data)) `(length ,data)))) (declare (type simple-string ,data) (type fixnum ,p ,g-end) (type character ,elem)) (parsing-macrolet (,elem ,data ,p ,g-end) ((skip-conditions (elem-var elems) `(or ,@(loop for el in elems if (and (consp el) (eq (car el) 'not)) collect `(not (char= ,(cadr el) ,elem-var)) else collect `(char= ,el ,elem-var)))) (%match-case (&rest cases) (check-match-cases cases) `(prog1 (vector-case ,',elem (,',data) ,@(if (find 'otherwise cases :key #'car :test #'eq) cases (append cases '((otherwise (go :match-failed)))))) (when (eofp) (go :eof)))) (%match-i-case (&rest cases) (check-match-cases cases) `(prog1 (vector-case ,',elem (,',data :case-insensitive t) ,@(if (find 'otherwise cases :key #'car :test #'eq) cases (append cases '((otherwise (go :match-failed)))))) (when (eofp) (go :eof)))) (match-case (&rest cases) `(tagbody-with-match-failed ,',elem (%match-case ,@cases))) (match-i-case (&rest cases) `(tagbody-with-match-failed ,',elem (%match-i-case ,@cases)))) (block ,body-block (tagbody (when (eofp) (go :eof)) (setq ,elem (aref ,data ,p)) (return-from ,body-block (progn ,@body)) :eof))))))) (defmacro with-octets-parsing ((data &key start end) &body body) (with-gensyms (g-end elem p body-block) (once-only (data) `(let ((,elem 0) (,p ,(if start `(or ,start 0) 0)) (,g-end ,(if end `(or ,end (length ,data)) `(length ,data)))) (declare (type octets ,data) (type fixnum ,p ,g-end) (type (unsigned-byte 8) ,elem)) (parsing-macrolet (,elem ,data ,p ,g-end) ((skip-conditions (elem-var elems) `(or ,@(loop for el in elems if (and (consp el) (eq (car el) 'not)) collect `(not (= ,(char-code (cadr el)) ,elem-var)) else collect `(= ,(char-code el) ,elem-var)))) (%match-case (&rest cases) (check-match-cases cases) (setf cases (loop for case in cases if (stringp (car case)) collect (cons (babel:string-to-octets (car case)) (cdr case)) else collect case)) `(prog1 (vector-case ,',elem (,',data) ,@(if (find 'otherwise cases :key #'car :test #'eq) cases (append cases '((otherwise (go :match-failed)))))) (when (eofp) (go :eof)))) (%match-i-case (&rest cases) (check-match-cases cases) (setf cases (loop for case in cases if (stringp (car case)) collect (cons (babel:string-to-octets (car case)) (cdr case)) else collect case)) `(prog1 (vector-case ,',elem (,',data :case-insensitive t) ,@(if (find 'otherwise cases :key #'car :test #'eq) cases (append cases '((otherwise (go :match-failed)))))) (when (eofp) (go :eof)))) (match-case (&rest cases) `(tagbody-with-match-failed ,',elem (%match-case ,@cases))) (match-i-case (&rest cases) `(tagbody-with-match-failed ,',elem (%match-i-case ,@cases)))) (block ,body-block (tagbody (when (eofp) (go :eof)) (setq ,elem (aref ,data ,p)) (return-from ,body-block (progn ,@body)) :match-failed (error 'match-failed :elem ,elem) :eof))))))) (defmacro with-vector-parsing ((data &key (start 0) end) &body body &environment env) (let ((data-type (variable-type* data env))) (case data-type (string `(with-string-parsing (,data :start ,start :end ,end) ,@body)) (octets `(macrolet ((get-elem (form) `(code-char ,form)) (subseq* (data start &optional end) `(babel:octets-to-string ,data :start ,start :end ,end))) (with-octets-parsing (,data :start ,start :end ,end) ,@body))) (otherwise (once-only (data) `(etypecase ,data (string (with-string-parsing (,data :start ,start :end ,end) ,@body)) (octets (macrolet ((get-elem (form) `(code-char ,form)) (subseq* (data start &optional end) `(babel:octets-to-string ,data :start ,start :end ,end))) (with-octets-parsing (,data :start ,start :end ,end) ,@body))))))))) ))))entry(nametnode(type directoryentry(nameproc-parse.lispnode(typeregularcontents÷%(in-package :cl-user) (defpackage proc-parse-test (:use :cl :proc-parse :prove) (:shadowing-import-from :proc-parse :skip)) (in-package :proc-parse-test) (plan 17) (defmacro with-vector-parsing-test ((target) &body body) `(progn (subtest "with-string-parsing" (with-string-parsing (,target) (flet ((is-current (char &optional desc) (is (current) char desc :test #'char=))) ,@body))) (subtest "with-octets-parsing" (with-octets-parsing (,(babel:string-to-octets target)) (flet ((is-current (char &optional desc) (is (current) (char-code char) desc :test #'=))) ,@body))))) (subtest "current" (subtest "with-vector-parsing" (with-vector-parsing ("a") (is (current) #\a))) (with-vector-parsing-test ("a") (is-current #\a "can return the current character."))) (defmacro test-peek ((target) &body body) `(progn (subtest "with-vector-parsing" (with-vector-parsing (,target) ,@body)) (subtest "with-string-parsing" (with-string-parsing (,target) ,@body)) (subtest "with-octets-parsing" (with-octets-parsing (,(babel:string-to-octets target)) ,@body)))) (subtest "peek" (test-peek ("a") (is (peek) nil)) (test-peek ("a") (is (peek :eof-value 'yes) 'yes)) (subtest "with-vector-parsing" (with-vector-parsing ("abcd") (advance) (is (peek) #\c))) (subtest "with-vector-parsing" (with-vector-parsing ("abcdefg" :end 5) (match "abc") (is (peek :eof-value 'yes) #\e))) (subtest "with-vector-parsing" (with-vector-parsing ("abcdefg" :end 5) (match "abcd") (is (peek :eof-value 'yes) 'yes)))) (subtest "advance" (with-vector-parsing-test ("ab") (advance) (is-current #\b "can increment the current position.") (advance) (fail "won't be executed after EOF"))) (subtest "advance*" (with-vector-parsing-test ("ab") (advance*) (is-current #\b "can increment the current position.") (ok (not (advance*)) "doesn't raise the eof error without rest characters."))) (subtest "skip" (with-vector-parsing-test ("ab") (skip #\a) (is-current #\b "can skip the spcified character.") (is-error (skip #\c) 'match-failed "can raise the match-failed error with unmatched character."))) (subtest "skip*" (with-vector-parsing-test ("aaabbb") (skip* #\a) (is-current #\b "can skip some spcified character.") (ok (not (skip* #\c)) "doesn't raise the match-failed error with unmatched character.") (is-current #\b "doesn't skip any characters when unmatched character spcified."))) (subtest "skip+" (with-vector-parsing-test ("aaabbb") (skip+ #\a) (is-current #\b "can skip some spcified character.") (is-error (skip+ #\c) 'match-failed "can raise the match-failed error with unmatched character."))) (subtest "skip?" (with-vector-parsing-test ("ab") (skip? #\a) (is-current #\b "can skip the spcified character.") (ok (not (skip? #\c)) "doesn't raise the match-failed error with unmatched character.") (is-current #\b "doesn't skip any characters when unmatched character spcified."))) (subtest "skip-until" (subtest "with-vector-parsing" (with-vector-parsing ("aaab") (skip-until (lambda (c) (char/= c #\a))) (is (current) #\b "can skip until form returns T.") (skip-until (lambda (c) (char/= c #\c))) (is (current) #\b "can skip until eof."))) (subtest "with-string-parsing" (with-string-parsing ("aaab") (skip-until (lambda (c) (char/= c #\a))) (is (current) #\b "can skip until form returns T.") (skip-until (lambda (c) (char/= c #\c))) (is (current) #\b "can skip until eof."))) (subtest "with-octets-parsing" (with-octets-parsing ((babel:string-to-octets "aaab")) (skip-until (lambda (b) (/= b (char-code #\a)))) (is (current) (char-code #\b) "can skip until form returns T.") (skip-until (lambda (b) (/= b (char-code #\c)))) (is (current) (char-code #\b) "can skip until eof.")))) (subtest "skip-while" (subtest "with-vector-parsing" (with-vector-parsing ("aaab") (skip-while (lambda (c) (char= c #\a))) (is (current) #\b "can skip when form returns T.") (skip-while (lambda (c) (char= c #\b))) (is (current) #\b "can skip until eof."))) (subtest "with-string-parsing" (with-string-parsing ("aaab") (skip-while (lambda (c) (char= c #\a))) (is (current) #\b "can skip when form returns T.") (skip-while (lambda (c) (char= c #\b))) (is (current) #\b "can skip until eof."))) (subtest "with-octets-parsing" (with-octets-parsing ((babel:string-to-octets "aaab")) (skip-while (lambda (b) (= b (char-code #\a)))) (is (current) (char-code #\b) "can skip when form returns T.") (skip-while (lambda (b) (= b (char-code #\b)))) (is (current) (char-code #\b) "can skip until eof.")))) (defun alpha-char-byte-p (byte) (or (<= (char-code #\a) byte (char-code #\z)) (<= (char-code #\A) byte (char-code #\Z)))) (subtest "bind" (subtest "with-vector-parsing" (with-vector-parsing ("aaab") (bind (str1 (skip-while (lambda (c) (char= c #\a)))) (is str1 "aaa" "can bind string with form.")) (bind (str2 (skip-while (lambda (c) (char= c #\b)))) (is str2 "b" "can bind string until eof."))) (with-vector-parsing ("a123") (skip-while alpha-char-p) (bind (num (skip-until alpha-char-p)) (is num "123" "can bind even when reached to EOF")))) (subtest "with-string-parsing" (with-string-parsing ("aaab") (bind (str1 (skip-while (lambda (c) (char= c #\a)))) (is str1 "aaa" "can bind string with form.")) (bind (str2 (skip-while (lambda (c) (char= c #\b)))) (is str2 "b" "can bind string until eof."))) (with-string-parsing ("a123") (skip-while alpha-char-p) (bind (num (skip-until alpha-char-p)) (is num "123" "can bind even when reached to EOF")))) (subtest "with-octets-parsing" (with-octets-parsing ((babel:string-to-octets "aaab")) (bind (bytes1 (skip-while (lambda (b) (= b (char-code #\a))))) (is bytes1 (babel:string-to-octets "aaa") "can bind octets with form." :test #'equalp)) (bind (bytes2 (skip-while (lambda (b) (= b (char-code #\b))))) (is bytes2 (babel:string-to-octets "b") "can bind octets until eof." :test #'equalp))) (with-octets-parsing ((babel:string-to-octets "a123")) (skip-while alpha-char-byte-p) (bind (num (skip-until alpha-char-byte-p)) (is num (babel:string-to-octets "123") "can bind even when reached to EOF" :test #'equalp))))) (subtest "match" (with-vector-parsing-test ("abc") (match "cd" "ab") (is-current #\c "can skip the matched one of specified strings.") (is-error (match "e" "fg") 'match-failed "can raise the match-failed error with unmatched strings."))) (subtest "match-i" (with-vector-parsing-test ("ABC") (match-i "cd" "ab") (is-current #\C "can skip the case-insensitively matched one of specified strings.") (is-error (match-i "e") 'match-failed "can raise the match-failed error with case-insensitively unmatched strings."))) (subtest "match?" (with-vector-parsing-test ("abc") (match? "ab") (is-current #\c "can skip the matched one of specified strings.") (match? "de") (is-current #\c "doesn't raise the match-failed error with unmatched strings."))) (subtest "match-case" (with-vector-parsing-test ("abc") (is (match-case ("a" 0) ("b" 1)) 0 "can return the value the body form of the matched case returns.") (is (match-case ("c" 0) (otherwise 1)) 1 "can return the value the otherwise form returns.") (is-error (match-case ("c")) 'match-failed "can raise the match-failed error with unmatched cases.") (is (match-case ("bc" 0)) 0 "can return the value the body form of the matched case returns even thogh eof."))) (subtest "match-i-case" (with-vector-parsing-test ("ABC") (is (match-i-case ("a" 0) ("b" 1)) 0 "can return the value the body form of the case-insensitively matched case returns.") (is (match-i-case ("c" 0) (otherwise 1)) 1 "can return the value the otherwise form returns.") (is-error (match-i-case ("c")) 'match-failed "can raise the match-failed error with case-insensitively unmatched cases.") (is (match-i-case ("bc" 0)) 0 "can return the value the body form of the matched case returns even thogh eof."))) (subtest "declaration of types" (let ((str "LISP")) (declare (type simple-string str)) (with-vector-parsing (str) (is (current) #\L)))) (finalize) ))))))))entry(namesystemsnode(type directoryentry(nameproc-parse-test.asdnode(typesymlinktarget„/gnu/store/001lnl7ikf4chzwgk60pr202q9d27rf6-cl-proc-parse-0.0.0-1.ac36368/share/common-lisp/source/cl-proc-parse/proc-parse-test.asd))entry(nameproc-parse.asdnode(typesymlinktarget/gnu/store/001lnl7ikf4chzwgk60pr202q9d27rf6-cl-proc-parse-0.0.0-1.ac36368/share/common-lisp/source/cl-proc-parse/proc-parse.asd)))))))))