src/pset-parse.lisp: Add a little vertical space and commentary.

[sod] / src / pset-parse.lisp

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index a38f44b..e86be27 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;

-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.

 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by


@@ -23,12 +23,17 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 

-(defun play (args)
+(in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; The expression parser.
+
+(defun parse-expression (scanner)

   "Parse and evaluate a simple expression.
 
    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',
   "Parse and evaluate a simple expression.
 
    The result is a pair (TYPE . VALUE).  Currently, type types are `:id',

-   `:int', `:string', and `:char'.  If an error prevented a sane ; value from
-   being produced, the type `:invalid' is returned.
+   `:int', `:string', `:char', `:fragment', `:type'.  If an error prevented a
+   sane value from being produced, the type `:invalid' is returned.

 
    The syntax of expressions is rather limited at the moment, but more may be
    added later.
 
    The syntax of expressions is rather limited at the moment, but more may be
    added later.


@@ -36,70 +41,170 @@
    expression: term | expression `+' term | expression `-' term
    term: factor | term `*' factor | term `/' factor
    factor: primary | `+' factor | `-' factor
    expression: term | expression `+' term | expression `-' term
    term: factor | term `*' factor | term `/' factor
    factor: primary | `+' factor | `-' factor

-   primary: int | id | string | `(' expression `)' | `?' lisp-expression
+   primary: int | id | string | `(' expression `)' | `{' fragment `}'
+     | `<' declspec+ declarator[empty] `>' | `?' lisp-expression

 
    Only operators for dealing with integers are provided."
 
 
    Only operators for dealing with integers are provided."
 

-  (labels ((type-dispatch (name args &rest spec)
-            (acond ((find :invalid args :key #'car)
-                    (cons :invalid nil))
-                   ((find-if (lambda (item)
-                               (every (lambda (type arg)
-                                        (eql type (car arg)))
-                                      (cddr item)
-                                      args))
-                             spec)
-                    (cons (car it) (apply (cadr it)
-                                          (mapcar #'cdr args))))
-                   (t
-                    (cerror* "Type mismatch: operator `~A' applied to ~
-                              types ~{~(~A~)~#[~; and ~;, ~]~}"
-                             name
-                             (mapcar #'car args))
-                    (cons :invalid nil))))
-          (add (x y) (type-dispatch "+" (list x y)
-                                    (list :integer #'+ :integer :integer)))
-          (sub (x y) (type-dispatch "-" (list x y)
-                                    (list :integer #'- :integer :integer)))
-          (mul (x y) (type-dispatch "*" (list x y)
-                                    (list :integer #'* :integer :integer)))
-          (div (x y) (type-dispatch "/" (list x y)
-                                    (list :integer
-                                          (lambda (x y)
-                                            (cond ((zerop y)
-                                                   (cerror*
-                                                    "Division by zero")
-                                                   (cons :invalid nil))
-                                                  (t
-                                                   (floor x y))))
-                                          :integer :integer)))
-          (nop (x) (type-dispatch "+" (list x)
-                                  (list :integer #'+ :integer)))
-          (neg (x) (type-dispatch "-" (list x)
-                                  (list :integer #'- :integer))))
-
-    (with-parser-context (token-scanner-context :scanner scanner)
-      (parse (expr (lisp (flet ((prop (type value)
-                                 (scanner-step scanner)
-                                 (values (cons type value) t t)))
-                          (case (token-type scanner)
-                            (:int
-                             (prop :integer (token-value scanner)))
-                            ((:id :char :string)
-                             (prop (token-type scanner) (token-value scanner)))
-                            (#\?
-                             (let* ((stream (make-scanner-stream scanner))
-                                    (sexp (read stream t)))
-                               (scanner-step scanner)
-                               (values (cons (property-type sexp) sexp)
-                                       t t)))
-                            (t
-                             (values (list :int :id :char :string #\?)
-                                     nil nil)))))
-                  
+  ;; The expression parser works in two stages.  First, the parser proper
+  ;; builds a thunk as its `value'.  If this is successful, then the thunk is
+  ;; invoked to return a property type and value.  Primitive expressions
+  ;; produce thunks which just return their values; operators combine their
+  ;; argument thunks together, evaluating them (or not) on demand.
+
+  (macrolet ((oplambda (&body body)
+              ;; Like `lambda', but (a) always produces a function with no
+              ;; arguments, and (b) captures the current location so that
+              ;; errors are attributed correctly.
+
+              (with-gensyms (floc)
+                `(let ((,floc (file-location scanner)))
+                   (lambda ()
+                     (with-default-error-location (,floc)
+                       ,@body))))))
+
+    (flet ((dispatch (name args &rest spec)
+            ;; Evaluate the ARGS to determine their types and values.  Find
+            ;; the first SPEC, of the form (RETTY OP ARGTY*), where the
+            ;; ARGTYs match the argument types, in order, and apply OP to
+            ;; the argument values, return this as a result of type RETTY.
+            ;; If no SPEC matches, then report an error.
+
+            (oplambda
+              (let ((args (mapcar (compose #'funcall #'cons) args)))
+                (aif (find-if (lambda (item)
+                                (every (lambda (type arg)
+                                         (eql type (car arg)))
+                                       (cddr item) args))
+                              spec)
+                     (values (car it) (apply (cadr it) (mapcar #'cdr args)))
+                     (error "Type mismatch: operator `~A' applied to ~
+                             types ~{~(~A~)~#[~; and ~;, ~]~}"
+                            name (mapcar #'car args)))))))
+
+      (with-parser-context (token-scanner-context :scanner scanner)
+       (when-parse ()
+
+           ;; Parse the expression, producing a thunk.
+           (expr (:nestedp nestedp)
+
+             (lisp (case (token-type scanner)
+
+                     ((:int :id :char :string)
+                      ;; A simple literal.
+                      (let ((type (token-type scanner))
+                            (value (token-value scanner)))
+                        (scanner-step scanner)
+                        (values (lambda () (values type value)) t t)))

 
 

+                     (#\?
+                      ;; A Lisp s-expression.  Catch and report reader-
+                      ;; errors (though the main parser will probably
+                      ;; end up /very/ confused); delay evaluation for
+                      ;; later.
+                      (handler-case
+                          (let* ((stream (make-scanner-stream scanner))
+                                 (sexp (read stream t)))
+                            (scanner-step scanner)
+                            (values (oplambda (decode-property (eval sexp)))
+                                    t t))
+                        (error (cond)
+                          (scanner-step scanner)
+                          (cerror*-with-location scanner
+                                                 "Lisp `read' error: ~A"
+                                                 cond)
+                          (values #'continue t t))))
+
+                     (#\{
+                      ;; A code fragment.
+                      (let ((fragment (parse-delimited-fragment scanner
+                                                                #\{ #\})))
+                        (values (lambda () (values :fragment fragment))
+                                t t)))
+
+                     (#\<
+                      ;; A C type.
+                      (parse (seq (#\<
+                                   (ds (parse-c-type scanner))
+                                   (dc (parse-declarator
+                                        scanner ds
+                                        :kernel (lambda ()
+                                                  (values nil t nil))
+                                        :abstractp t))
+                                   #\>)
+                               (values (lambda () (values :type (car dc)))
+                                       t t))))
+
+                     (t
+                      ;; Anything else is an error.
+                      (values (list :int :id :char :string #\? #\{ #\<)
+                              nil nil))))
+
+             ;; Binary operators.
+             ((:op #\* binop "*" (x y 7)
+                   (dispatch "*" (list x y) (list :int #'* :int :int)))
+              (:op #\/ binop "/" (x y 7)
+                   (dispatch "/" (list x y)
+                             (list :int
+                                   (lambda (x y)
+                                     (cond ((zerop y)
+                                            (cerror*
+                                             "Division by zero")
+                                            (cons :invalid nil))
+                                           (t
+                                            (floor x y))))
+                                   :int :int)))
+              (:op #\+ binop "+" (x y 5)
+                   (dispatch "+" (list x y) (list :int #'+ :int :int)))
+              (:op #\- binop "-" (x y 5)
+                   (dispatch "-" (list x y) (list :int #'- :int :int))))
+
+             ;; Prefix operators.
+             ((:op #\+ preop "+" (x 9)
+                   (dispatch "+" (list x) (list :int #'+ :int)))
+              (:op #\- preop "-" (x 9)
+                   (dispatch "-" (list x) (list :int #'- :int)))
+              (:op #\( lparen #\)))
+
+             ;; Postfix operators.
+             ((:op (when nestedp #\)) rparen #\))))
+
+         ;; Do the delayed evaluation.  Establish a restart so that we can
+         ;; continue if evaluation fails for some reason.  (The value thunk
+         ;; is expected to report the correct error locations, if it signals
+         ;; conditions.)
+         (restart-case (multiple-value-bind (type value) (funcall it)
+                         (values (cons type value) t t))
+           (continue () (values (cons :invalid nil) t t))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Parsing property sets.
+
+(export 'parse-property)

 (defun parse-property (scanner pset)
   "Parse a single property using the SCANNER; add it to the PSET."
 (defun parse-property (scanner pset)
   "Parse a single property using the SCANNER; add it to the PSET."

-  ;; id `=' expression
+  ;; property ::= id `=' expression
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (seq ((name :id) #\= (result (parse-expression scanner)))
+            (let ((type (car result))
+                  (value (cdr result)))
+              (unless (eq type :invalid)
+                (add-property pset name value
+                              :type type
+                              :location scanner)))))))
+
+(export 'parse-property-set)
+(defun parse-property-set (scanner)
+  "Parse an optional property set from the SCANNER and return it."
+  ;; property-set ::= [`[' property-list `]']
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (? (seq (#\[
+                   (pset (many (pset (make-property-set) pset)
+                           (error ()
+                             (parse-property scanner pset)
+                             (skip-until () #\, #\]))
+                           #\,))
+                   #\])
+               pset)))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------