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