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   ;; The expression parser works in two stages.  First, the parser proper
  50   ;; builds a thunk as its `value'.  If this is successful, then the thunk is
  51   ;; invoked to return a property type and value.  Primitive expressions
  52   ;; produce thunks which just return their values; operators combine their
  53   ;; argument thunks together, evaluating them (or not) on demand.
  54
  55   (macrolet ((oplambda (&body body)
  56                ;; Like `lambda', but (a) always produces a function with no
  57                ;; arguments, and (b) captures the current location so that
  58                ;; errors are attributed correctly.
  59
  60                (with-gensyms (floc)
  61                  `(let ((,floc (file-location scanner)))
  62                     (lambda ()
  63                       (with-default-error-location (,floc)
  64                         ,@body))))))
  65
  66     (flet ((dispatch (name args &rest spec)
  67              (oplambda
  68                (let ((args (mapcar (compose #'funcall #'cons) args)))
  69                  (aif (find-if (lambda (item)
  70                                  (every (lambda (type arg)
  71                                           (eql type (car arg)))
  72                                         (cddr item) args))
  73                                spec)
  74                       (values (car it) (apply (cadr it) (mapcar #'cdr args)))
  75                       (error "Type mismatch: operator `~A' applied to ~
  76                               types ~{~(~A~)~#[~; and ~;, ~]~}"
  77                              name (mapcar #'car args)))))))
  78
  79       (with-parser-context (token-scanner-context :scanner scanner)
  80         (when-parse ()
  81
  82             ;; Parse the expression, producing a thunk.
  83             (expr (:nestedp nestedp)
  84               (lisp (case (token-type scanner)
  85                       ((:int :id :char :string)
  86                        (let ((type (token-type scanner))
  87                              (value (token-value scanner)))
  88                          (scanner-step scanner)
  89                          (values (lambda () (values type value)) t t)))
  90                       (#\?
  91                        (handler-case
  92                            (let* ((stream (make-scanner-stream scanner))
  93                                   (sexp (read stream t)))
  94                              (scanner-step scanner)
  95                              (values (oplambda (decode-property (eval sexp)))
  96                                      t t))
  97                          (error (cond)
  98                            (scanner-step scanner)
  99                            (cerror*-with-location scanner
 100                                                   "Lisp `read' error: ~A"
 101                                                   cond)
 102                            (values #'continue t t))))
 103                       (#\{
 104                        (let ((fragment (parse-delimited-fragment scanner
 105                                                                  #\{ #\})))
 106                          (values (lambda () (values :fragment fragment))
 107                                  t t)))
 108                       (#\<
 109                        (parse (seq (#\<
 110                                     (ds (parse-c-type scanner))
 111                                     (dc (parse-declarator
 112                                          scanner ds
 113                                          :kernel (lambda ()
 114                                                    (values nil t nil))
 115                                          :abstractp t))
 116                                     #\>)
 117                                 (values (lambda () (values :type (car dc)))
 118                                         t t))))
 119                       (t
 120                        (values (list :int :id :char :string #\? #\{ #\<)
 121                                nil nil))))
 122
 123               ((:op #\* binop "*" (x y 7)
 124                     (dispatch "*" (list x y) (list :int #'* :int :int)))
 125                (:op #\/ binop "/" (x y 7)
 126                     (dispatch "/" (list x y)
 127                               (list :int
 128                                     (lambda (x y)
 129                                       (cond ((zerop y)
 130                                              (cerror*
 131                                               "Division by zero")
 132                                              (cons :invalid nil))
 133                                             (t
 134                                              (floor x y))))
 135                                     :int :int)))
 136                (:op #\+ binop "+" (x y 5)
 137                     (dispatch "+" (list x y) (list :int #'+ :int :int)))
 138                (:op #\- binop "-" (x y 5)
 139                     (dispatch "-" (list x y) (list :int #'- :int :int))))
 140
 141               ((:op #\+ preop "+" (x 9)
 142                     (dispatch "+" (list x) (list :int #'+ :int)))
 143                (:op #\- preop "-" (x 9)
 144                     (dispatch "-" (list x) (list :int #'- :int)))
 145                (:op #\( lparen #\)))
 146
 147               ((:op (when nestedp #\)) rparen #\))))
 148
 149           ;; Do the delayed evaluation.  Establish a restart so that we can
 150           ;; continue if evaluation fails for some reason.  (The value thunk
 151           ;; is expected to report the correct error locations, if it signals
 152           ;; conditions.)
 153           (restart-case (multiple-value-bind (type value) (funcall it)
 154                           (values (cons type value) t t))
 155             (continue () (values (cons :invalid nil) t t))))))))
 156
 157 ;;;--------------------------------------------------------------------------
 158 ;;; Parsing property sets.
 159
 160 (export 'parse-property)
 161 (defun parse-property (scanner pset)
 162   "Parse a single property using the SCANNER; add it to the PSET."
 163   ;; property ::= id `=' expression
 164   (with-parser-context (token-scanner-context :scanner scanner)
 165     (parse (seq ((name :id) #\= (result (parse-expression scanner)))
 166              (let ((type (car result))
 167                    (value (cdr result)))
 168                (unless (eq type :invalid)
 169                  (add-property pset name value
 170                                :type type
 171                                :location scanner)))))))
 172
 173 (export 'parse-property-set)
 174 (defun parse-property-set (scanner)
 175   "Parse an optional property set from the SCANNER and return it."
 176   ;; property-set ::= [`[' property-list `]']
 177   (with-parser-context (token-scanner-context :scanner scanner)
 178     (parse (? (seq (#\[
 179                     (pset (many (pset (make-property-set) pset)
 180                             (error ()
 181                               (parse-property scanner pset)
 182                               (skip-until () #\, #\]))
 183                             #\,))
 184                     #\])
 185                 pset)))))
 186
 187 ;;;----- That's all, folks --------------------------------------------------