chiark - git - mdw - sod/blob - src/parser/parser-impl.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Parser protocol implementation.
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensble Object Design, an object system for C.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod-parser)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Hairy functions used by parser syntax expanders.
  30
  31 (declaim (inline %many))
  32 (defun %many (update final parser &key (min 0) max)
  33   "Helper function for the `many' parser syntax.
  34
  35    This deals with simple repetition, without separators.  See the parser
  36    syntax documentation for details."
  37
  38   (let ((consumed-any-p nil))
  39     (do ((i 0 (1+ i)))
  40         ((and max (>= i max)))
  41       (multiple-value-bind (value winp consumep) (funcall parser)
  42         (when consumep (setf consumed-any-p t))
  43         (cond (winp (funcall update value))
  44               ((or consumep (< i min))
  45                (return-from %many (values value nil consumed-any-p)))
  46               (t (return)))))
  47     (values (funcall final) t consumed-any-p)))
  48
  49 (defun %many-sep (update final parser sep &key (min 1) max (commitp t))
  50   "Helper function for the `many' parser syntax.
  51
  52    This deals with the hairy separator and commit stuff.  See the parser
  53    syntax documentation for details."
  54
  55   (let ((consumed-any-p nil)
  56         (i 0))
  57     (block nil
  58       (flet ((sep ()
  59                (multiple-value-bind (value winp consumep) (funcall sep)
  60                  (when consumep (setf consumed-any-p t))
  61                  (unless winp
  62                    (if (and (>= i min) (not consumep)) (return)
  63                        (return-from %many-sep
  64                          (values value nil consumed-any-p))))))
  65
  66              (main (mustp)
  67                (multiple-value-bind (value winp consumep) (funcall parser)
  68                  (when consumep (setf consumed-any-p t))
  69                  (cond (winp (funcall update value))
  70                        ((or mustp consumep (< i min))
  71                         (return-from %many-sep
  72                           (values value nil consumed-any-p)))
  73                        (t (return))))
  74                (incf i)))
  75
  76         (when (eql max 0) (return))
  77
  78         (main nil)
  79
  80         (if commitp
  81             (loop (when (and max (>= i max)) (return)) (sep) (main t))
  82             (loop (sep) (when (and max (>= i max)) (return)) (main nil)))))
  83
  84     (values (funcall final) t consumed-any-p)))
  85
  86 ;;;--------------------------------------------------------------------------
  87 ;;; Token parser implementation.
  88
  89 (defmethod parser-at-eof-p ((context token-parser-context))
  90   `(eq ,(parser-token-type context) :eof))
  91
  92 ;;;--------------------------------------------------------------------------
  93 ;;; Simple list-based parser; useful for testing.
  94
  95 (export 'list-parser)
  96 (defclass list-parser ()
  97   ((var :initarg :var :type symbol :reader parser-var)))
  98
  99 (defmethod parser-at-eof-p ((context list-parser))
 100   `(not ,(parser-var context)))
 101
 102 (defmethod parser-capture-place ((context list-parser))
 103   `,(parser-var context))
 104
 105 (defmethod parser-restore-place ((context list-parser) place)
 106   `(setf ,(parser-var context) ,place))
 107
 108 (defmethod expand-parser-spec ((context list-parser) parser)
 109   (if (atom parser)
 110       (expand-parser-form context 'quote (list parser))
 111       (call-next-method)))
 112
 113 (defparse quote (:context (context list-parser) object)
 114   `(if (and ,(parser-var context)
 115             (eql (car ,(parser-var context)) ',object))
 116        (progn (pop ,(parser-var context)) (values ',object t t))
 117        (values (list ',object) nil nil)))
 118
 119 (defparse type (:context (context list-parser) type)
 120   `(if (and ,(parser-var context)
 121             (typep (car ,(parser-var context)) ',type))
 122        (values (pop ,(parser-var context)) t t)
 123        (values (list ',type) nil nil)))
 124
 125 (defmethod parser-places-must-be-released-p ((context list-parser)) nil)
 126
 127 ;;;--------------------------------------------------------------------------
 128 ;;; Simple string-based parser; useful for testing.
 129
 130 (export 'string-parser)
 131 (defclass string-parser (character-parser-context)
 132   ((%string :initarg :string :reader parser-string)
 133    (index :initarg :index :initform 0 :reader parser-index)
 134    (%length :initform (gensym "LEN-") :reader parser-length)))
 135
 136 (defmethod wrap-parser ((context string-parser) form)
 137   (with-slots ((string %string) index (length %length)) context
 138     `(let* (,@(unless (symbolp string)
 139                 (let ((s string))
 140                   (setf string (gensym "STRING-"))
 141                   `((,string ,s))))
 142             ,@(unless (symbolp index)
 143                 (let ((i index))
 144                   (setf index (gensym "INDEX-"))
 145                   `((,index ,i))))
 146               (,length (length ,string)))
 147        ,form)))
 148
 149 (defmethod parser-at-eof-p ((context string-parser))
 150   `(>= ,(parser-index context) ,(parser-length context)))
 151
 152 (defmethod parser-current-char ((context string-parser))
 153   `(char ,(parser-string context) ,(parser-index context)))
 154
 155 (defmethod parser-step ((context string-parser))
 156   `(incf ,(parser-index context)))
 157
 158 (defmethod parser-capture-place ((context string-parser))
 159   `,(parser-index context))
 160
 161 (defmethod parser-restore-place ((context string-parser) place)
 162   `(setf ,(parser-index context) ,place))
 163
 164 (defmethod parser-places-must-be-released-p ((context string-parser)) nil)
 165
 166 ;;;----- That's all, folks --------------------------------------------------