| 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 | (decode-property sexp) |
| 104 | (values (cons type value) t t)))) |
| 105 | (#\{ |
| 106 | (values (cons :fragment |
| 107 | (parse-delimited-fragment scanner |
| 108 | #\{ #\})) |
| 109 | t t)) |
| 110 | (#\< |
| 111 | (parse (seq (#\< |
| 112 | (ds (parse-c-type scanner)) |
| 113 | (dc (parse-declarator |
| 114 | scanner ds |
| 115 | :kernel (lambda () |
| 116 | (values nil t nil)) |
| 117 | :abstractp t)) |
| 118 | #\>) |
| 119 | (values (cons :type (car dc)) |
| 120 | t t)))) |
| 121 | (t |
| 122 | (values (list :int :id :char :string #\?) |
| 123 | nil nil))))) |
| 124 | (or (seq (#\+) add) |
| 125 | (seq (#\-) sub) |
| 126 | (seq (#\*) mul) |
| 127 | (seq (#\/) div)) |
| 128 | (or (seq (#\() lp) |
| 129 | (seq (#\+) nop) |
| 130 | (seq (#\-) neg)) |
| 131 | (when nestedp (seq (#\)) rp)))))))) |
| 132 | |
| 133 | ;;;-------------------------------------------------------------------------- |
| 134 | ;;; Parsing property sets. |
| 135 | |
| 136 | (defun parse-property (scanner pset) |
| 137 | "Parse a single property using the SCANNER; add it to the PSET." |
| 138 | ;; property ::= id `=' expression |
| 139 | (with-parser-context (token-scanner-context :scanner scanner) |
| 140 | (parse (seq ((name :id) #\= (result (parse-expression scanner))) |
| 141 | (let ((type (car result)) |
| 142 | (value (cdr result))) |
| 143 | (unless (eq type :invalid) |
| 144 | (add-property pset name value |
| 145 | :type type |
| 146 | :location scanner))))))) |
| 147 | |
| 148 | (export 'parse-property-set) |
| 149 | (defun parse-property-set (scanner) |
| 150 | "Parse an optional property set from the SCANNER and return it." |
| 151 | ;; property-set ::= [`[' property-list `]'] |
| 152 | (with-parser-context (token-scanner-context :scanner scanner) |
| 153 | (parse (? (seq (#\[ |
| 154 | (pset (many (pset (make-property-set) pset) |
| 155 | (error () |
| 156 | (parse-property scanner pset) |
| 157 | (skip-until () #\, #\])) |
| 158 | #\,)) |
| 159 | #\]) |
| 160 | pset))))) |
| 161 | |
| 162 | ;;;----- That's all, folks -------------------------------------------------- |