chiark - git - mdw - sod/blob - src/pset-parse.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Parsing property sets
   4 ;;;
   5 ;;; (c) 2012 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible 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 (in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; The expression parser.
  30
  31 (flet ((dispatch (name args &rest spec)
  32          (acond ((find :invalid args :key #'car)
  33                  (cons :invalid nil))
  34                 ((find-if (lambda (item)
  35                             (every (lambda (type arg)
  36                                      (eql type (car arg)))
  37                                    (cddr item)
  38                                    args))
  39                           spec)
  40                  (cons (car it) (apply (cadr it)
  41                                        (mapcar #'cdr args))))
  42                 (t
  43                  (cerror* "Type mismatch: operator `~A' applied to ~
  44                                types ~{~(~A~)~#[~; and ~;, ~]~}"
  45                           name
  46                           (mapcar #'car args))
  47                  (cons :invalid nil)))))
  48
  49   (defun parse-expression (scanner)
  50     "Parse and evaluate a simple expression.
  51
  52    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
  53    `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a
  54    sane value from being produced, the type `:invalid' is returned.
  55
  56    The syntax of expressions is rather limited at the moment, but more may be
  57    added later.
  58
  59    expression: term | expression `+' term | expression `-' term
  60    term: factor | term `*' factor | term `/' factor
  61    factor: primary | `+' factor | `-' factor
  62    primary: int | id | string | `(' expression `)' | `{' fragment `}'
  63      | `<' declspec+ declarator[empty] `>' | `?' lisp-expression
  64
  65    Only operators for dealing with integers are provided."
  66     (with-parser-context (token-scanner-context :scanner scanner)
  67       (parse (expr (:nestedp nestedp)
  68                (lisp (flet ((prop (type value)
  69                               (scanner-step scanner)
  70                               (values (cons type value) t t)))
  71                        (case (token-type scanner)
  72                          ((:int :id :char :string)
  73                           (prop (token-type scanner)
  74                                 (token-value scanner)))
  75                          (#\?
  76                           (let* ((stream (make-scanner-stream scanner))
  77                                  (sexp (read stream t)))
  78                             (scanner-step scanner)
  79                             (multiple-value-bind (type value)
  80                                 (restart-case (decode-property (eval sexp))
  81                                   (continue () (values :invalid nil)))
  82                               (values (cons type value) t t))))
  83                          (#\{
  84                           (values (cons :fragment
  85                                         (parse-delimited-fragment scanner
  86                                                                   #\{ #\}))
  87                                         t t))
  88                          (#\<
  89                           (parse (seq (#\<
  90                                        (ds (parse-c-type scanner))
  91                                        (dc (parse-declarator
  92                                             scanner ds
  93                                             :kernel (lambda ()
  94                                                       (values nil t nil))
  95                                             :abstractp t))
  96                                        #\>)
  97                                    (values (cons :type (car dc))
  98                                            t t))))
  99                          (t
 100                           (values (list :int :id :char :string #\? #\{ #\<)
 101                                   nil nil)))))
 102
 103                ((:op #\* binop "*" (x y 7)
 104                      (dispatch "*" (list x y) (list :int #'* :int :int)))
 105                 (:op #\/ binop "/" (x y 7)
 106                      (dispatch "/" (list x y)
 107                                (list :int
 108                                      (lambda (x y)
 109                                        (cond ((zerop y)
 110                                               (cerror*
 111                                                "Division by zero")
 112                                               (cons :invalid nil))
 113                                              (t
 114                                               (floor x y))))
 115                                      :int :int)))
 116                 (:op #\+ binop "+" (x y 5)
 117                      (dispatch "+" (list x y) (list :int #'+ :int :int)))
 118                 (:op #\- binop "-" (x y 5)
 119                      (dispatch "-" (list x y) (list :int #'- :int :int))))
 120
 121                ((:op #\+ preop "+" (x 9)
 122                      (dispatch "+" (list x) (list :int #'+ :int)))
 123                 (:op #\- preop "-" (x 9)
 124                      (dispatch "-" (list x) (list :int #'- :int)))
 125                 (:op #\( lparen #\)))
 126
 127                ((:op (when nestedp #\)) rparen #\))))))))
 128
 129 ;;;--------------------------------------------------------------------------
 130 ;;; Parsing property sets.
 131
 132 (export 'parse-property)
 133 (defun parse-property (scanner pset)
 134   "Parse a single property using the SCANNER; add it to the PSET."
 135   ;; property ::= id `=' expression
 136   (with-parser-context (token-scanner-context :scanner scanner)
 137     (parse (seq ((name :id) #\= (result (parse-expression scanner)))
 138              (let ((type (car result))
 139                    (value (cdr result)))
 140                (unless (eq type :invalid)
 141                  (add-property pset name value
 142                                :type type
 143                                :location scanner)))))))
 144
 145 (export 'parse-property-set)
 146 (defun parse-property-set (scanner)
 147   "Parse an optional property set from the SCANNER and return it."
 148   ;; property-set ::= [`[' property-list `]']
 149   (with-parser-context (token-scanner-context :scanner scanner)
 150     (parse (? (seq (#\[
 151                     (pset (many (pset (make-property-set) pset)
 152                             (error ()
 153                               (parse-property scanner pset)
 154                               (skip-until () #\, #\]))
 155                             #\,))
 156                     #\])
 157                 pset)))))
 158
 159 ;;;----- That's all, folks --------------------------------------------------