| 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 -------------------------------------------------- |