Skip to content
Browse files

- Replaced PARSER-CONTEXT class with a struct. (This resulted a huge

  performance impact. For a particular document, runtime reduced from
  160 seconds to 6.5 seconds.)

- Replaced checkpoints list with an adjustable vector.

- Removed dependency to CL-UTILITIES and copied WITH-UNIQUE-NAMES from
  cl-ppcre package.
  • Loading branch information...
1 parent 4642785 commit c721108c19bf0f0a163e10bfec4410a138f8dc30 Volkan YAZICI committed Jul 18, 2007
Showing with 124 additions and 93 deletions.
  1. +7 −9 README
  2. +1 −1 meta-sexp.asd
  3. +20 −82 meta-sexp.lisp
  4. +1 −1 packages.lisp
  5. +95 −0 util.lisp
View
16 README
@@ -29,9 +29,8 @@ CREATE-PARSER-CONTEXT methods and DEFRULE, DEFRENDERER macros.
defrule (name (&rest args) (&optional attachment) &body body)
defrenderer (name (&rest args) (&optional attachment) &body body)
- If supplied, ATTACHMENT argument will get bound to ATTACHMENT
- keyword given to CREATE-PARSER-CONTEXT (or specified via
- MAKE-INSTANCE).
+In a rule or renderer body, if supplied, ATTACHMENT argument will get
+bound to ATTACHMENT keyword given to CREATE-PARSER-CONTEXT.
In some certain situations, you may also need to use DEFATOM too. See
atoms.lisp for DEFATOM examples.
@@ -59,18 +58,17 @@ Here is another example demonstrating the usage of META symbol.
"in Wonderland!"))
(:return t))
- (in-wonderland? (make-instance
- 'parser-context :data "META-SEXP in Wonderland!"))
+ (in-wonderland?
+ (create-parser-context :data "META-SEXP in Wonderland!"))
META-SEXP in Wonderland!
==> T
- (in-wonderland? (make-instance
- 'parser-context :data "META-SEXP in Fooland!"))
+ (in-wonderland?
+ (create-parser-context :data "META-SEXP in Fooland!"))
META-SEXP in Wonderland!
==> NIL
-You mostly won't need to bother with MAKE-INSTANCE calls. Here's a
-complete example with renderers and attachments.
+Here's a complete example with renderers and attachments.
(defrenderer internal-link! (label &optional text) (attachment)
(format attachment "<a href='~a'>~a</a>"
View
2 meta-sexp.asd
@@ -39,7 +39,7 @@
(asdf:defsystem :meta-sexp
:serial t
:version +meta-sexp-version+
- :depends-on (:cl-utilities)
:components ((:file "packages")
+ (:file "util")
(:file "meta-sexp")
(:file "atoms")))
View
102 meta-sexp.lisp
@@ -29,45 +29,24 @@
(in-package :meta-sexp)
-;;; Parser Context Class & Routines
+;;; Parser Context Structure & Routines
-(defclass parser-context ()
- ((data
- :initarg :data
- :accessor parser-context-data
- :documentation "Input data getting parsed.")
- (size
- :initarg :size
- :accessor parser-context-size
- :documentation "Size of the input data.")
- (cursor
- :initarg :cursor
- :accessor parser-context-cursor
- :documentation "Current location on the input data.")
- (checkpoints
- :accessor parser-context-checkpoints
- :documentation "Reversed list of declared checkpoints.")
- (attachment
- :initarg :attachment
- :accessor parser-context-attachment
- :documentation "Attachment to carry with to parser context object."))
- (:documentation "Information about current state of the parsing process."))
-
-(defmethod shared-initialize ((ctx parser-context) slot-names &rest args)
- (setf (parser-context-data ctx) (getf args :data)
- (parser-context-size ctx) (or (getf args :size) (length (getf args :data)))
- (parser-context-attachment ctx) (getf args :attachment)
- (parser-context-cursor ctx) (getf args :cursor)
- (parser-context-checkpoints ctx) nil))
+(defstruct parser-context
+ (data nil :read-only t :type string)
+ (size nil :read-only t :type unsigned-byte)
+ (cursor 0 :type unsigned-byte)
+ (checkpoints
+ (make-array 8 :element-type 'unsigned-byte :adjustable t :fill-pointer 0)
+ :type (vector unsigned-byte *))
+ attachment)
(defgeneric create-parser-context (input &rest args))
(defmethod create-parser-context ((input string) &key start end attachment)
- (make-instance 'parser-context
- :data input
- :size end
- :cursor (or start 0)
- :attachment attachment))
+ (make-parser-context :data input
+ :cursor (or start 0)
+ :size (or end (length input))
+ :attachment attachment))
(defmethod create-parser-context
((input string-stream) &key buffer-size start end attachment)
@@ -85,34 +64,27 @@
(create-parser-context
string :start start :end (or end size) :attachment attachment)))
-(define-condition parser-context-error ()
- ((operation :initarg :operation :accessor parser-context-error-operation)))
-
(declaim (inline peek-atom))
(defun peek-atom (ctx)
(if (< (parser-context-cursor ctx) (parser-context-size ctx))
(elt (parser-context-data ctx) (parser-context-cursor ctx))))
(declaim (inline read-atom))
(defun read-atom (ctx)
- (when (< (parser-context-cursor ctx) (parser-context-size ctx))
+ (when (< (parser-context-cursor ctx) (parser-context-size ctx))
(elt (parser-context-data ctx) (1- (incf (parser-context-cursor ctx))))))
(declaim (inline checkpoint))
(defun checkpoint (ctx)
- (push (parser-context-cursor ctx) (parser-context-checkpoints ctx)))
+ (vector-push-extend (parser-context-cursor ctx) (parser-context-checkpoints ctx)))
(declaim (inline rollback))
(defun rollback (ctx)
- (let ((prev-pos (pop (parser-context-checkpoints ctx))))
- (if prev-pos
- (setf (parser-context-cursor ctx) prev-pos)
- (error 'parser-context-error :operation 'rollback))))
+ (setf (parser-context-cursor ctx) (vector-pop (parser-context-checkpoints ctx))))
(declaim (inline commit))
(defun commit (ctx)
- (if (not (pop (parser-context-checkpoints ctx)))
- (error 'parser-context-error :operation 'commit)))
+ (vector-pop (parser-context-checkpoints ctx)))
;;; Atom, Rule & Type Matching
@@ -130,40 +102,6 @@
`(,rule ,@(nconc (list ctx) args)))
-;;; Accumulators
-
-(declaim (inline make-char-accum))
-(defun make-char-accum (&key (size 512))
- (make-array size :element-type 'character :adjustable t :fill-pointer 0))
-
-(declaim (inline char-accum-push))
-(defun char-accum-push (char accum)
- (if (typep char 'character)
- (vector-push-extend char accum)))
-
-(declaim (inline reset-char-accum))
-(defun reset-char-accum (accum)
- (setf (fill-pointer accum) 0))
-
-(declaim (inline empty-char-accum-p))
-(defun empty-char-accum-p (accum)
- (zerop (fill-pointer accum)))
-
-(declaim (inline make-list-accum))
-(defun make-list-accum ()
- nil)
-
-(defmacro list-accum-push (item accum)
- `(push ,item ,accum))
-
-(defmacro reset-list-accum (accum)
- `(setf ,accum nil))
-
-(declaim (inline empty-list-accum-p))
-(defun empty-list-accum-p (accum)
- (endp accum))
-
-
;;; Grammar Compiler
(defun compile-grammar (ctx form)
@@ -175,7 +113,7 @@
((and (consp form) (keywordp (car form)))
(ecase (car form)
(:checkpoint
- (with-gensyms (ret)
+ (with-unique-names (ret)
`(progn
(checkpoint ,ctx)
(let ((,ret ,(compile-expr (cadr form))))
@@ -237,7 +175,7 @@
(deftype ,name () `(satisfies ,',name))))
(defmacro defrule (name (&rest args) (&optional attachment) &body body)
- (with-gensyms (ctx)
+ (with-unique-names (ctx)
`(defun ,name (,ctx ,@args)
,(if attachment
`(let ((,attachment (parser-context-attachment ,ctx)))
@@ -247,7 +185,7 @@
,(compile-grammar ctx `(:checkpoint (:and ,@body))))))))
(defmacro defrenderer (name (&rest args) (&optional attachment) &body body)
- (with-gensyms (ctx)
+ (with-unique-names (ctx)
`(defun ,name (,ctx ,@args)
,(if attachment
`(let ((,attachment (parser-context-attachment ,ctx)))
View
2 packages.lisp
@@ -30,7 +30,7 @@
(defpackage :meta-sexp
(:documentation "LL(1) parser generator in META using s-expressions.")
- (:use :cl :cl-utilities)
+ (:use :cl)
(:export :defatom
:defrule
:defrenderer
View
95 util.lisp
@@ -0,0 +1,95 @@
+;;; Copyright (c) 2007, Volkan YAZICI <yazicivo@ttnet.net.tr>
+;;; All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+
+;;; - Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; - Redistributions in binary form must reproduce the above
+;;; copyright notice, this list of conditions and the following
+;;; disclaimer in the documentation and/or other materials provided
+;;; with the distribution.
+
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
+;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
+;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
+;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
+;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
+;;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
+;;; THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+
+(in-package :meta-sexp)
+
+#-:lispworks
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Syntax: WITH-UNIQUE-NAMES ( { var | (var x) }* ) declaration* form*
+
+Executes a series of forms with each VAR bound to a fresh,
+uninterned symbol. The uninterned symbol is as if returned by a call
+to GENSYM with the string denoted by X - or, if X is not supplied, the
+string denoted by VAR - as argument.
+
+The variable bindings created are lexical unless special declarations
+are specified. The scopes of the name bindings and declarations do not
+include the Xs.
+
+The forms are evaluated in order, and the values of all but the last
+are discarded \(that is, the body is an implicit PROGN)."
+ ;; (Copied to meta-sexp from cl-ppcre project of Dr. Edmund Weitz.)
+ ;; reference implementation posted to comp.lang.lisp as
+ ;; <cy3bshuf30f.fsf@ljosa.com> by Vebjorn Ljosa - see also
+ ;; <http://www.cliki.net/Common%20Lisp%20Utilities>
+ `(let ,(mapcar #'(lambda (binding)
+ (check-type binding (or cons symbol))
+ (if (consp binding)
+ (destructuring-bind (var x) binding
+ (check-type var symbol)
+ `(,var (gensym ,(etypecase x
+ (symbol (symbol-name x))
+ (character (string x))
+ (string x)))))
+ `(,binding (gensym ,(symbol-name binding)))))
+ bindings)
+ ,@body))
+
+
+;;; Accumulators
+
+(declaim (inline make-char-accum))
+(defun make-char-accum (&key (size 512))
+ (make-array size :element-type 'character :adjustable t :fill-pointer 0))
+
+(declaim (inline char-accum-push))
+(defun char-accum-push (char accum)
+ (if (typep char 'character)
+ (vector-push-extend char accum)))
+
+(declaim (inline reset-char-accum))
+(defun reset-char-accum (accum)
+ (setf (fill-pointer accum) 0))
+
+(declaim (inline empty-char-accum-p))
+(defun empty-char-accum-p (accum)
+ (zerop (fill-pointer accum)))
+
+(declaim (inline make-list-accum))
+(defun make-list-accum ()
+ nil)
+
+(defmacro list-accum-push (item accum)
+ `(push ,item ,accum))
+
+(defmacro reset-list-accum (accum)
+ `(setf ,accum nil))
+
+(declaim (inline empty-list-accum-p))
+(defun empty-list-accum-p (accum)
+ (endp accum))

0 comments on commit c721108

Please sign in to comment.
Something went wrong with that request. Please try again.