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     (flet ((dispatch (name args &rest spec)
  67              ;; Evaluate the ARGS to determine their types and values.  Find
  68              ;; the first SPEC, of the form (RETTY OP ARGTY*), where the
  69              ;; ARGTYs match the argument types, in order, and apply OP to
  70              ;; the argument values, return this as a result of type RETTY.
  71              ;; If no SPEC matches, then report an error.
  72
  73              (oplambda
  74                (let ((args (mapcar (compose #'funcall #'cons) args)))
  75                  (aif (find-if (lambda (item)
  76                                  (every (lambda (type arg)
  77                                           (eql type (car arg)))
  78                                         (cddr item) args))
  79                                spec)
  80                       (values (car it) (apply (cadr it) (mapcar #'cdr args)))
  81                       (error "Type mismatch: operator `~A' applied to ~
  82                               types ~{~(~A~)~#[~; and ~;, ~]~}"
  83                              name (mapcar #'car args)))))))
  84
  85       (with-parser-context (token-scanner-context :scanner scanner)
  86         (when-parse ()
  87
  88             ;; Parse the expression, producing a thunk.
  89             (expr (:nestedp nestedp)
  90
  91               (lisp (case (token-type scanner)
  92
  93                       ((:int :id :char :string)
  94                        ;; A simple literal.
  95                        (let ((type (token-type scanner))
  96                              (value (token-value scanner)))
  97                          (scanner-step scanner)
  98                          (values (lambda () (values type value)) t t)))
  99
 100                       (#\?
 101                        ;; A Lisp s-expression.  Catch and report reader-
 102                        ;; errors (though the main parser will probably
 103                        ;; end up /very/ confused); delay evaluation for
 104                        ;; later.
 105                        (handler-case
 106                            (let* ((stream (make-scanner-stream scanner))
 107                                   (sexp (read stream t)))
 108                              (scanner-step scanner)
 109                              (values (oplambda (decode-property (eval sexp)))
 110                                      t t))
 111                          (error (cond)
 112                            (scanner-step scanner)
 113                            (cerror*-with-location scanner
 114                                                   "Lisp `read' error: ~A"
 115                                                   cond)
 116                            (values #'continue t t))))
 117
 118                       (#\{
 119                        ;; A code fragment.
 120                        (let ((fragment (parse-delimited-fragment scanner
 121                                                                  #\{ #\})))
 122                          (values (lambda () (values :fragment fragment))
 123                                  t t)))
 124
 125                       (#\<
 126                        ;; A C type.
 127                        (parse (seq (#\<
 128                                     (ds (parse-c-type scanner))
 129                                     (dc (parse-declarator
 130                                          scanner ds
 131                                          :kernel (lambda ()
 132                                                    (values nil t nil))
 133                                          :abstractp t))
 134                                     #\>)
 135                                 (values (lambda () (values :type (car dc)))
 136                                         t t))))
 137
 138                       (t
 139                        ;; Anything else is an error.
 140                        (values (list :int :id :char :string #\? #\{ #\<)
 141                                nil nil))))
 142
 143               ;; Binary operators.
 144               ((:op #\* binop "*" (x y 7)
 145                     (dispatch "*" (list x y) (list :int #'* :int :int)))
 146                (:op #\/ binop "/" (x y 7)
 147                     (dispatch "/" (list x y)
 148                               (list :int
 149                                     (lambda (x y)
 150                                       (cond ((zerop y)
 151                                              (cerror*
 152                                               "Division by zero")
 153                                              (cons :invalid nil))
 154                                             (t
 155                                              (floor x y))))
 156                                     :int :int)))
 157                (:op #\+ binop "+" (x y 5)
 158                     (dispatch "+" (list x y) (list :int #'+ :int :int)))
 159                (:op #\- binop "-" (x y 5)
 160                     (dispatch "-" (list x y) (list :int #'- :int :int))))
 161
 162               ;; Prefix operators.
 163               ((:op #\+ preop "+" (x 9)
 164                     (dispatch "+" (list x) (list :int #'+ :int)))
 165                (:op #\- preop "-" (x 9)
 166                     (dispatch "-" (list x) (list :int #'- :int)))
 167                (:op #\( lparen #\)))
 168
 169               ;; Postfix operators.
 170               ((:op (when nestedp #\)) rparen #\))))
 171
 172           ;; Do the delayed evaluation.  Establish a restart so that we can
 173           ;; continue if evaluation fails for some reason.  (The value thunk
 174           ;; is expected to report the correct error locations, if it signals
 175           ;; conditions.)
 176           (restart-case (multiple-value-bind (type value) (funcall it)
 177                           (values (cons type value) t t))
 178             (continue () (values (cons :invalid nil) t t))))))))
 179
 180 ;;;--------------------------------------------------------------------------
 181 ;;; Parsing property sets.
 182
 183 (export 'parse-property)
 184 (defun parse-property (scanner pset)
 185   "Parse a single property using the SCANNER; add it to the PSET."
 186   ;; property ::= id `=' expression
 187   (with-parser-context (token-scanner-context :scanner scanner)
 188     (parse (seq ((name :id) #\= (result (parse-expression scanner)))
 189              (let ((type (car result))
 190                    (value (cdr result)))
 191                (unless (eq type :invalid)
 192                  (add-property pset name value
 193                                :type type
 194                                :location scanner)))))))
 195
 196 (export 'parse-property-set)
 197 (defun parse-property-set (scanner)
 198   "Parse an optional property set from the SCANNER and return it."
 199   ;; property-set ::= [`[' property-list `]']
 200   (with-parser-context (token-scanner-context :scanner scanner)
 201     (parse (? (seq (#\[
 202                     (pset (many (pset (make-property-set) pset)
 203                             (error ()
 204                               (parse-property scanner pset)
 205                               (skip-until () #\, #\]))
 206                             #\,))
 207                     #\])
 208                 pset)))))
 209
 210 ;;;----- That's all, folks --------------------------------------------------