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