From: Mark Wooding Date: Tue, 20 Aug 2019 01:04:16 +0000 (+0100) Subject: src/pset-parse.lisp: Parse and evaluate expressions in two separate steps. X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/7469d31e1a189759e6c32a5116b1b8e9da750da1?ds=sidebyside src/pset-parse.lisp: Parse and evaluate expressions in two separate steps. Previously, we'd parse and evaluate expressions in an interleaved fashion: the items on the parser's value stack were (TYPE . VALUE) pairs, fully evaluated. This causes a couple of problems. * Firstly, and most obviously, it means that we can't have operators which perform short-circuit evaluation -- sometimes failing to evaluate their operands. This doesn't seem like such a big deal: after all, we don't have any assignment operators. But we /do/ have an escape to Lisp's `eval' function via the `?' SEXP primary, and evaluating Lisp can have arbitrary side-effects. * Secondly, it makes error handling more annoying. There's logic throughout for reporting continuable errors and then returning a `:invalid' marker. This logic is currently concentrated in the internal `dispatch' function, but continuing to maintain this convention if and when we crack open `dispatch' to implement more complex operators would be messy. (I know: I've tried it.) Deferring evaluation to a second pass solves both problems. Control- flow operators can just decide not to evaluate operands they're not interested in. And errors can be caught and turned into an immediate return from the `parse-expression' toplevel. (The `:invalid' convention is still part of the external interface, for good reason, but it we can just use Lisp's non-local control flow forms inside.) The way this works is unsurprising. The `value' stack now holds thunks which will calculate and return their values when invoked. Operators close over the thunks for their operands and produce a new thunk which will call the operand thunks as required to calculate their result. The handling of `:invalid' in `dispatch' can be eliminated in favour of a `restart-case' form around invoking the final value thunk. The only remaining clever footwork is in `?' SEXP: if there's a read- time error then we yields a thunk which immediately escapes and returns `:invalid' from the toplevel. (We do this using `continue' on the grounds that the read error has already been reported -- along, probably, with a lot of knock-on parse errors while we try to resynchronize with the source.) --- diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp index b0e22be..4dec565 100644 --- a/src/pset-parse.lisp +++ b/src/pset-parse.lisp @@ -46,85 +46,113 @@ Only operators for dealing with integers are provided." - (flet ((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))))) - - (with-parser-context (token-scanner-context :scanner scanner) - (parse (expr (:nestedp nestedp) - (lisp (case (token-type scanner) - ((:int :id :char :string) - (scanner-step scanner) - (values (cons (token-type scanner) - (token-value scanner)) - t t)) - (#\? - (let* ((stream (make-scanner-stream scanner)) - (sexp (read stream t))) - (scanner-step scanner) - (multiple-value-bind (type value) - (restart-case (decode-property (eval sexp)) - (continue () (values :invalid nil))) - (values (cons type value) t t)))) - (#\{ - (values (cons :fragment - (parse-delimited-fragment scanner - #\{ #\})) - t t)) - (#\< - (parse (seq (#\< - (ds (parse-c-type scanner)) - (dc (parse-declarator - scanner ds - :kernel (lambda () - (values nil t nil)) - :abstractp t)) - #\>) - (values (cons :type (car dc)) - t t)))) - (t - (values (list :int :id :char :string #\? #\{ #\<) - nil nil)))) - - ((: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)))) - - ((:op #\+ preop "+" (x 9) - (dispatch "+" (list x) (list :int #'+ :int))) - (:op #\- preop "-" (x 9) - (dispatch "-" (list x) (list :int #'- :int))) - (:op #\( lparen #\))) - - ((:op (when nestedp #\)) rparen #\)))))))) + ;; 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) + (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) + (let ((type (token-type scanner)) + (value (token-value scanner))) + (scanner-step scanner) + (values (lambda () (values type value)) t t))) + (#\? + (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)))) + (#\{ + (let ((fragment (parse-delimited-fragment scanner + #\{ #\}))) + (values (lambda () (values :fragment fragment)) + t t))) + (#\< + (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 + (values (list :int :id :char :string #\? #\{ #\<) + nil nil)))) + + ((: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)))) + + ((:op #\+ preop "+" (x 9) + (dispatch "+" (list x) (list :int #'+ :int))) + (:op #\- preop "-" (x 9) + (dispatch "-" (list x) (list :int #'- :int))) + (:op #\( lparen #\))) + + ((: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.