cc-ide/recdesc.el

   1 ;;; recdesc.el --- Generator for recursive-descent parsers
   2 ;;
   3 ;; Copyright (C) 2000,2007 Stefan Bund
   4
   5 ;; recdesc.el is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 2, or (at
   8 ;; your option) any later version.
   9
  10 ;; recdesc.el is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; General Public License for more details.
  14
  15 ;;; Commentary:
  16
  17 ;; Der Syntax einer term deklaration ist:
  18
  19 ;; <term-declaration> := (term <symbol> <arglist> <command>...)
  20 ;;
  21 ;; <command> := <directive>
  22 ;;            | (collect <directive-or-form>)
  23 ;;            | (return <form>)
  24 ;;
  25 ;; <directive-or-form> := <directive> | <form>
  26 ;;
  27 ;; <diretive> :=  (match <term> [<form>...])
  28 ;;             |  (or <command>...)
  29 ;;             |  (and <command>...)
  30 ;;             |  (maybe <command>...)
  31 ;;             |  (repeat <command>...)
  32 ;;             |  (commit)
  33 ;;             |  (fail)
  34 ;;             |  (progn <lisp-code>...)
  35 ;;
  36 ;; <term> := <symbol> | <form>
  37
  38 ;;
  39 ;;
  40
  41 ;;; Change-Log:
  42
  43 ;; $Log: recdesc.el,v $
  44 ;; Revision 1.3  2000/02/13 21:19:56  bund
  45 ;; Erste vollständige version von SqIV2
  46 ;;
  47 ;; Revision 1.2  2000/02/03 10:15:19  bund
  48 ;; *** empty log message ***
  49 ;;
  50 ;; Revision 1.1  2000/02/01 13:26:03  bund
  51 ;; *** empty log message ***
  52 ;;
  53 ;;
  54
  55 ;;; Variables:
  56
  57 ;;; Code:
  58
  59 (require 'cl)
  60
  61 (declaim (special position))
  62 (declaim (special string))
  63 (declaim (special commit-flag))
  64 (declaim (special saved-position))
  65 (declaim (special saved-elements))
  66 (declaim (special elements))
  67 (declaim (special return-form))
  68
  69 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  70 ;;
  71 ;; Zunächst der Parser/Scanner zur deklaration von Termen
  72
  73 (defmacro recdesc-deferror (name message &rest classes)
  74   `(progn
  75      (put ',name 'error-conditions '(error sqi-error ,@classes ,name))
  76      (put ',name 'error-message ,message)))
  77
  78 (defmacro recdesc-declare (&rest forms)
  79   (cons 'progn
  80         (loop for form in forms
  81               collect (if (and (consp form)
  82                                (eq (car form) 'term)
  83                                (consp (cdr form))
  84                                (symbolp (cadr form))
  85                                (consp (cddr form))
  86                                (listp (caddr form)))
  87                           (recdesc-declare-term (cadr form)
  88                                                     (caddr form)
  89                                                     (cdddr form))
  90                         (signal 'recdesc-invalid-decl-component
  91                                 (list form))))))
  92
  93 (recdesc-deferror recdesc-invalid-decl-component
  94   "Invalid component in recdesc-declare" recdesc-error)
  95
  96 (defun recdesc-declare-term (name arglist body)
  97   (let (return-form)
  98     `(defun ,(intern (concat "recdesc@@" (symbol-name name))) ,arglist
  99        (let (elements)
 100          (or (and ,(recdesc-parse-directive/and body)
 101                   ,(if return-form
 102                        return-form
 103                      '(or elements t))))))))
 104
 105 (defun recdesc-parse-command (command)
 106   (if (not (consp command))
 107       (signal 'recdesc-invalid-command
 108               (list command)))
 109   (cond ((eq (car command) 'return)
 110          (if (not (consp (cdr command)))
 111              (signal 'recdesc-invalid-command
 112                      (list command)))
 113          (setq return-form (cadr command))
 114          t)
 115         ((eq (car command) 'collect)
 116          (if (not (consp (cdr command)))
 117              (signal 'recdesc-invalid-command (list command)))
 118          `(recdesc-collect ,(recdesc-parse-directive-or-form (cadr command))))
 119         (t (recdesc-parse-directive command))))
 120
 121 (recdesc-deferror recdesc-invalid-command
 122   "Invalid scanner command" recdesc-error)
 123
 124 (defun recdesc-parse-directive-or-form (directive-or-form)
 125   (or (recdesc-parse-directive directive-or-form t)
 126       directive-or-form))
 127
 128 (defun recdesc-parse-directive (directive &optional nosignal)
 129   (if (not (consp directive))
 130       (if (not nosignal)
 131           (signal 'recdesc-invalid-directive
 132                   (list directive)))
 133     (cond ((eq (car directive) 'match)   (recdesc-parse-directive/match   (cdr directive)))
 134           ((eq (car directive) 'or)      (recdesc-parse-directive/or      (cdr directive)))
 135           ((eq (car directive) 'and)     (recdesc-parse-directive/and     (cdr directive)))
 136           ((eq (car directive) 'maybe)   (recdesc-parse-directive/maybe   (cdr directive)))
 137           ((eq (car directive) 'repeat)  (recdesc-parse-directive/repeat  (cdr directive)))
 138           ((eq (car directive) 'commit)  (recdesc-parse-directive/commit  (cdr directive)))
 139           ((eq (car directive) 'fail)    (recdesc-parse-directive/fail    (cdr directive)))
 140           ((eq (car directive) 'progn)   (recdesc-parse-directive/progn   (cdr directive)))
 141           (t (if (not nosignal)
 142                  (signal 'recdesc-invalid-directive
 143                          (list directive)))))))
 144
 145 (recdesc-deferror recdesc-invalid-directive
 146   "Invalid scanner directive" recdesc-error)
 147
 148 (defun recdesc-parse-directive/match (args)
 149   (if (not (consp args))
 150       (signal 'recdesc-invalid-match-arguments
 151               (list args)))
 152   (if (symbolp (car args))
 153       (cons (intern (concat "recdesc@@" (symbol-name (car args))))
 154             (cdr args))
 155     (if (not (null (cdr args)))
 156         (signal 'recdesc-invalid-match-arguments
 157                 (list args)))
 158     (list 'recdesc-match-regexp (car args))))
 159
 160 (recdesc-deferror recdesc-invalid-match-arguments
 161   "Invalid arguments to match directive" recdesc-error)
 162
 163 (defun recdesc-parse-directive/or (args)
 164   (if (not (consp args))
 165       (signal 'recdesc-invalid-or-arguments
 166               (list args)))
 167   (cons 'or
 168         (loop for command in args
 169               collect (recdesc-parse-directive/and (list command)))))
 170
 171 (recdesc-deferror recdesc-invalid-or-arguments
 172   "Invalid arguments to or directive" recdesc-error)
 173
 174 (defun recdesc-parse-directive/and (args)
 175   (if (not (consp args))
 176       (signal 'recdesc-invalid-and-arguments
 177               (list args)))
 178   `(let ((saved-position position)
 179          (saved-elements elements)
 180          commit-flag)
 181      (or (and ,@(loop for command in args
 182                       collect (recdesc-parse-command command)))
 183          (recdesc-backtrack))))
 184
 185 (recdesc-deferror recdesc-invalid-and-arguments
 186   "Invalid arguments to and directive" recdesc-error)
 187
 188 (defun recdesc-parse-directive/maybe (args)
 189   (if (not (consp args))
 190       (signal 'recdesc-invalid-maybe-arguments
 191               (list args)))
 192   `(or ,(recdesc-parse-directive/and args) t))
 193
 194 (defun recdesc-parse-directive/repeat (args)
 195   `(loop for repeat-item = ,(recdesc-parse-directive/and args)
 196          while repeat-item
 197          collect repeat-item))
 198
 199 (defun recdesc-parse-directive/commit (args)
 200   (if args
 201       (signal 'recdesc-invalid-commit-arguments
 202               (list args)))
 203   `(setq commit-flag t))
 204
 205 (recdesc-deferror recdesc-invalid-commit-arguments
 206   "Invalid arguments to commit directive" recdesc-error)
 207
 208 (defun recdesc-parse-directive/fail (args)
 209   (if args
 210       (signal 'recdesc-invalid-fail-arguments
 211               (list args)))
 212   '(throw 'recdesc-failed nil))
 213
 214 (recdesc-deferror recdesc-invalid-fail-arguments
 215   "Invalid arguments to fail directive" recdesc-error)
 216
 217 (defun recdesc-parse-directive/progn (args)
 218   `(progn ,@args))
 219
 220 (put 'term 'lisp-indent-function 'defun)
 221
 222 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 223 ;;
 224 ;; Die folgenden Funktionen werden von den durch recdesc-declare
 225 ;; erzeugten termen benötigt
 226
 227 (defun recdesc-backtrack ()
 228   (progn
 229     (if commit-flag
 230         (throw 'recdesc-failed nil))
 231     (setq position saved-position
 232           elements saved-elements)
 233     nil))
 234
 235 (defun recdesc-collect (value)
 236   (if value
 237       (progn
 238         (setq elements (nconc elements
 239                               (list value)))
 240         value)))
 241
 242 (defun recdesc-match-regexp (regexp)
 243   (if (string-match (concat "^" regexp) (substring string position))
 244       (let ((start position))
 245         (setq position (+ position (match-end 0)))
 246         (substring string start position))))
 247
 248 (defun recdesc-match (term &rest args)
 249   (apply (intern (concat "recdesc@@" (symbol-name term))) args))
 250
 251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 252 ;;
 253 ;; Toplevel calls to generated scanners
 254
 255 (defun recdesc-scan-string (term string &rest args)
 256   (let ((scanner (intern (concat "recdesc@@"
 257                                  (symbol-name term))))
 258         (position 0)
 259         rv)
 260     (setq rv (catch 'recdesc-failed
 261                (apply scanner args)))
 262     (if (not (string-match "^[ \t\n\r]*$" (substring string position)))
 263         nil
 264       rv)))
 265
 266 (provide 'recdesc)
 267
 268 \f
 269 ;;; Local Variables:
 270 ;;; elisp-project-autoload-file-name: "sqi-autoload.el"
 271 ;;; End: