mdw@git.distorted.org.uk Git - 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     (labels ((want (type thunk)
  67                ;; Evaluate THUNK and convert its result to the given TYPE.
  68                (multiple-value-bind (ty val) (funcall thunk)
  69                  (coerce-property-value val ty type)))
  70
  71              (int-unop (intop x)
  72                ;; Evaluate X to an integer, and apply INTOP to the result,
  73                ;; giving another integer.
  74                (oplambda (values :int (funcall intop (want :int x)))))
  75
  76              (int-binop (intop x y)
  77                ;; Evaluate X and Y to integers, and apply INTOP to the
  78                ;; results, giving another integer.
  79                (oplambda
  80                  (values :int (funcall intop (want :int x) (want :int y)))))
  81
  82              (compareop (intop strop x y)
  83                ;; Evaluate X and Y.  If they're integers, then apply INTOP to
  84                ;; them; if they're strings, apply STROP.  The result is a
  85                ;; boolean.
  86                (oplambda
  87                  (multiple-value-bind (xty xval) (funcall x)
  88                    (case xty
  89                      (:int
  90                       (values :boolean
  91                               (funcall intop xval (want :int y))))
  92                      ((:id :string :symbol)
  93                       (values :boolean
  94                               (funcall strop
  95                                        (coerce-property-value xval xty :id)
  96                                        (want :id y))))
  97                      (t
  98                       (error "Can't compare objects of type ~(~A~)" xty)))))))
  99
 100       (with-parser-context (token-scanner-context :scanner scanner)
 101         (when-parse ()
 102
 103             ;; Parse the expression, producing a thunk.
 104             (expr (:nestedp nestedp)
 105
 106               (lisp (case (token-type scanner)
 107
 108                       ((:int :id :char :string)
 109                        ;; A simple literal.
 110                        (let ((type (token-type scanner))
 111                              (value (token-value scanner)))
 112                          (scanner-step scanner)
 113                          (values (lambda () (values type value)) t t)))
 114
 115                       (#\?
 116                        ;; A Lisp s-expression.  Catch and report reader-
 117                        ;; errors (though the main parser will probably
 118                        ;; end up /very/ confused); delay evaluation for
 119                        ;; later.
 120                        (handler-case
 121                            (let* ((stream (make-scanner-stream scanner))
 122                                   (sexp (read stream t)))
 123                              (scanner-step scanner)
 124                              (values (oplambda (decode-property (eval sexp)))
 125                                      t t))
 126                          (error (cond)
 127                            (scanner-step scanner)
 128                            (cerror*-with-location scanner
 129                                                   "Lisp `read' error: ~A"
 130                                                   cond)
 131                            (values #'continue t t))))
 132
 133                       (#\{
 134                        ;; A code fragment.
 135                        (let ((fragment (parse-delimited-fragment scanner
 136                                                                  #\{ #\})))
 137                          (values (lambda () (values :fragment fragment))
 138                                  t t)))
 139
 140                       (#\<
 141                        ;; A C type.
 142                        (parse (seq (#\<
 143                                     (ds (parse-c-type scanner))
 144                                     (dc (parse-declarator
 145                                          scanner ds
 146                                          :kernel (lambda ()
 147                                                    (values nil t nil))
 148                                          :abstractp t))
 149                                     #\>)
 150                                 (values (lambda () (values :type (car dc)))
 151                                         t t))))
 152
 153                       (t
 154                        ;; Anything else is an error.
 155                        (values (list :int :id :char :string #\? #\{ #\<)
 156                                nil nil))))
 157
 158               ;; Binary operators.
 159               ((:op #\* binop "*" (x y 70) (int-binop #'* x y))
 160                (:op #\/ binop "/" (x y 70)
 161                     (oplambda
 162                       (let ((x (want :int x)) (y (want :int y)))
 163                         (when (zerop y) (error "Division by zero"))
 164                         (values :int (floor x y)))))
 165                (:op #\+ binop "+" (x y 60) (int-binop #'+ x y))
 166                (:op #\- binop "-" (x y 60) (int-binop #'- x y))
 167                (:op :shl binop "<<" (x y 50) (int-binop #'ash x y))
 168                (:op :shr binop ">>" (x y 50)
 169                     (int-binop (lambda (x y) (ash x (- y))) x y))
 170                (:op #\< binop "<" (x y 45)
 171                     (compareop #'< #'string< x y))
 172                (:op :le binop "<=" (x y 45)
 173                     (compareop #'<= #'string<= x y))
 174                (:op :ge binop ">=" (x y 45)
 175                     (compareop #'>= #'string>= x y))
 176                (:op #\> binop ">" (x y 45)
 177                     (compareop #'> #'string> x y))
 178                (:op :eq binop "==" (x y 40)
 179                     (compareop #'= #'string= x y))
 180                (:op :ne binop "!=" (x y 40)
 181                     (compareop #'/= #'string/= x y))
 182                (:op #\& binop "&" (x y 37) (int-binop #'logand x y))
 183                (:op #\^ binop "^" (x y 35) (int-binop #'logxor x y))
 184                (:op #\| binop "|" (x y 32) (int-binop #'logior x y))
 185                (:op :and binop "&&" (x y 27)
 186                     (oplambda (if (want :boolean x) (funcall y)
 187                                   (values :boolean nil))))
 188                (:op :or binop "||" (x y 22)
 189                     (oplambda
 190                       (multiple-value-bind (xty xval) (funcall x)
 191                         (if (coerce-property-value xval xty :boolean)
 192                             (values xty xval)
 193                             (funcall y))))))
 194
 195               ;; Prefix operators.
 196               ((:op #\~ preop "~" (x 90) (int-unop #'lognot x))
 197                (:op #\! preop "!" (x 90)
 198                     (oplambda
 199                       (values :boolean
 200                               (not (want :boolean (funcall x))))))
 201                (:op #\+ preop "+" (x 90) (int-unop #'identity x))
 202                (:op #\- preop "-" (x 90) (int-unop #'- x))
 203                (:op #\( lparen #\)))
 204
 205               ;; Postfix operators.
 206               ((:op (when nestedp #\)) rparen #\))))
 207
 208           ;; Do the delayed evaluation.  Establish a restart so that we can
 209           ;; continue if evaluation fails for some reason.  (The value thunk
 210           ;; is expected to report the correct error locations, if it signals
 211           ;; conditions.)
 212           (restart-case (multiple-value-bind (type value) (funcall it)
 213                           (values (cons type value) t t))
 214             (continue () (values (cons :invalid nil) t t))))))))
 215
 216 ;;;--------------------------------------------------------------------------
 217 ;;; Parsing property sets.
 218
 219 (export 'parse-property)
 220 (defun parse-property (scanner pset)
 221   "Parse a single property using the SCANNER; add it to the PSET."
 222   ;; property ::= id `=' expression
 223   (with-parser-context (token-scanner-context :scanner scanner)
 224     (parse (seq ((name :id) #\= (result (parse-expression scanner)))
 225              (let ((type (car result))
 226                    (value (cdr result)))
 227                (unless (eq type :invalid)
 228                  (add-property pset name value
 229                                :type type
 230                                :location scanner)))))))
 231
 232 (export 'parse-property-set)
 233 (defun parse-property-set (scanner)
 234   "Parse an optional property set from the SCANNER and return it."
 235   ;; property-set ::= [`[' property-list `]']
 236   (with-parser-context (token-scanner-context :scanner scanner)
 237     (parse (? (seq (#\[
 238                     (pset (many (pset (make-property-set) pset)
 239                             (error ()
 240                               (parse-property scanner pset)
 241                               (skip-until () #\, #\]))
 242                             #\,))
 243                     #\])
 244                 pset)))))
 245
 246 ;;;----- That's all, folks --------------------------------------------------