;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;;--------------------------------------------------------------------------
;;; Utilities.
+(export 'combine-parser-failures)
(defun combine-parser-failures (failures)
"Combine the failure indicators listed in FAILURES.
failures
:initial-value nil))
+(export 'parse-empty)
+(defun parse-empty (&optional value)
+ "Return a parser which parses nothing, successfully.
+
+ The parser returns VALUE and consumes nothing."
+ (lambda () (values value t nil)))
+
+(export 'parse-fail)
+(defun parse-fail (indicator &optional consumedp)
+ "Return a parser which fails.
+
+ The parser reports the INDICATOR and (falsely) claims to have consumed
+ input if CONSUMEDP is true."
+ (lambda () (values indicator nil consumedp)))
+
;;;--------------------------------------------------------------------------
;;; Basic protocol.
(:documentation
"Expand a parser list-form given by HEAD and TAIL, in CONTEXT.")
(:method (context head tail)
+ (declare (ignore context))
(cons head tail)))
(export 'wrap-parser)
(defgeneric wrap-parser (context form)
(:documentation
"Enclose FORM in whatever is necessary to make the parser work.")
- (:method (context form) form)))
+ (:method (context form)
+ (declare (ignore context))
+ form)))
(export 'defparse)
(defmacro defparse (name bvl &body body)
body FORMs. The BVL is a destructuring lambda-list to be applied to the
tail of the form. The body forms are enclosed in a block called NAME.
- Within the FORMs, a function `expand' is available: it takes a parser
- specifier as its argument and returns its expansion in the parser's
- context.
-
If the :context key is provided, then the parser form is specialized on a
particular class of parser contexts SPEC; specialized expanders take
priority over less specialized or unspecialized expanders -- so you can
`(defmethod expand-parser-form
((,context ,ctxclass) (,head (eql ',name)) ,tail)
,@doc
- (block ,name
- (destructuring-bind ,bvl ,tail
- ,@decls
- ,@body)))))))
+ (declare (ignorable ,context))
+ (destructuring-bind ,bvl ,tail
+ ,@decls
+ (block ,name ,@body)))))))
(export '(with-parser-context parse))
(defmacro with-parser-context ((class &rest initargs) &body body)
(defmethod expand-parser-spec (context (spec (eql t)))
"Always matches without consuming input."
+ (declare (ignore context))
'(values t t nil))
(defmethod expand-parser-spec (context (spec (eql nil)))
"Always fails without consuming input. The failure indicator is `:fail'."
+ (declare (ignore context))
'(values '(:fail) nil nil))
(export 'seq)
(,func (lambda (,new)
(declare (ignorable ,new))
(setf ,accvar ,update))
- (lambda ()
- ,final)
+ (lambda () ,final)
(parser () ,parser)
,@(and sepp (list `(parser () ,sep)))
,@(and minp `(:min ,min))
If a parser with the given TAG is already attached to SYMBOL then the new
parser replaces the old one; otherwise it is added to the collection."
- `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body)))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(pluggable-parser-add ',symbol ',tag
+ (lambda ,bvl
+ ,@docs ,@decls
+ (block ,symbol ,@body)))))
;;;--------------------------------------------------------------------------
;;; Rewindable parser context protocol.
The return value may later be used with `parser-restore-place'. Be
careful: all of this is happening at macro-expansion time.")
(:method (context)
- (error "Parser context ~S doesn't support rewinding." context)))
+ (error "Parser context ~S doesn't support rewinding" context)))
(export 'parser-restore-place)
(defgeneric parser-restore-place (context place)
underlying scanner can use this call to determine whether there are
outstanding captured places, and thereby optimize its behaviour. Be
careful: all of this is happening at macro-expansion time.")
- (:method (context place) nil))
+ (:method (context place)
+ (declare (ignore context place))
+ nil))
(export 'parser-places-must-be-released-p)
(defgeneric parser-places-must-be-released-p (context)
the correct cleanup. If it returns false, then the `unwind-protect' is
omitted so that the runtime code does't have to register cleanup
handlers.")
- (:method (context) t)))
+ (:method (context)
+ (declare (ignore context))
+ t)))
(export 'with-parser-place)
(defmacro with-parser-place ((place context) &body body)
`(let ((,,place ,(parser-capture-place ,context)))
,(if (parser-places-must-be-released-p ,context)
`(unwind-protect ,(,bodyfunc)
- ,(parser-release-place ,context ,place))
+ (when ,,place
+ ,(parser-release-place ,context ,place)))
(,bodyfunc))))))))
(export 'peek)
"Attempt to run PARSER, but rewind the underlying source if it fails."
(with-gensyms (value win consumedp)
(with-parser-place (place context)
- `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
- (cond (,win
- (values ,value ,win ,consumedp))
- (t
- ,(parser-restore-place context place)
- (values ,value ,win nil)))))))
+ `(macrolet ((commit-peeked-place ()
+ `(progn
+ ,',(parser-release-place context place)
+ (setf ,',place nil))))
+ (multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+ (cond ((or ,win (null ,place))
+ (values ,value ,win ,consumedp))
+ (t
+ ,(parser-restore-place context place)
+ (values ,value ,win nil))))))))
+
+(defun commit-peeked-place ()
+ "Called by `commit' not lexically within `peek'."
+ (error "`commit' is not within `peek'"))
+
+(export 'commit)
+(defparse commit ()
+ "Commit to the current parse.
+
+ This releases the place captured by the innermost lexically enclosing
+ `peek'."
+ '(progn
+ (commit-peeked-place)
+ (values nil t nil)))
;;;--------------------------------------------------------------------------
;;; Character parser context protocol.
"Return the parser's current token's semantic value."))
(export 'token)
-(defparse token (:context (context token-parser-context)
- type &optional (value nil valuep) &key peekp)
- "Match tokens of a particular type.
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+ (defparse token (:context (context token-parser-context)
+ type &optional (value nil valuep) &key peekp)
+ "Match tokens of a particular type.
A token matches under the following conditions:
* If the value of TYPE is `t' then the match succeeds if and only if the
- parser it not at end-of-file.
+ parser is not at end-of-file.
* If the value of TYPE is not `eql' to the token type then the match
fails.
If the match fails then the failure indicator is either TYPE or (TYPE
VALUE), depending on whether a VALUE was specified."
- (once-only (type value peekp)
- (with-gensyms (tokty tokval)
- `(let ((,tokty ,(parser-token-type context))
- (,tokval ,(parser-token-value context)))
- (if ,(if (eq type t)
- `(not (eq ,tokty :eof))
- (flet ((check-value (cond)
- (if valuep
- `(and ,cond (equal ,tokval ,value))
- cond)))
- (if (constantp type)
- (check-value `(eql ,tokty ,type))
- `(if (eq ,type t)
- (not (eq ,tokty :eof))
- ,(check-value `(eql ,tokty ,type))))))
- ,(let* ((result `(values ,tokval t ,(if (constantp peekp)
- (not peekp)
- `(not ,peekp))))
- (step (parser-step context)))
- (cond ((not (constantp peekp))
- `(multiple-value-prog1 ,result
- (unless ,peekp ,step)))
- (peekp
- result)
- (t
- `(multiple-value-prog1 ,result
- ,step))))
- (values (list ,(if valuep `(list ,type ,value) type))
- nil nil))))))
+ (once-only (type value peekp)
+ (with-gensyms (tokty tokval)
+ `(let ((,tokty ,(parser-token-type context))
+ (,tokval ,(parser-token-value context)))
+ (if ,(if (eq type t)
+ `(not (eq ,tokty :eof))
+ (flet ((check-value (cond)
+ (if valuep
+ `(and ,cond (equal ,tokval ,value))
+ cond)))
+ (if (constantp type)
+ (check-value `(eql ,tokty ,type))
+ `(if (eq ,type t)
+ (not (eq ,tokty :eof))
+ ,(check-value `(eql ,tokty ,type))))))
+ ,(let* ((result `(values ,tokval t ,(if (constantp peekp)
+ (not peekp)
+ `(not ,peekp))))
+ (step (parser-step context)))
+ (cond ((not (constantp peekp))
+ `(multiple-value-prog1 ,result
+ (unless ,peekp ,step)))
+ (peekp
+ result)
+ (t
+ `(multiple-value-prog1 ,result
+ ,step))))
+ (values (list ,(if valuep `(list ,type ,value) type))
+ nil nil)))))))
(defmethod expand-parser-spec ((context token-parser-context) spec)
(if (atom spec)
~mdw / sod / blobdiff