- (parse (expr (:nestedp nestedp)
- (lisp (flet ((prop (type value)
- (scanner-step scanner)
- (values (cons type value) t t)))
- (case (token-type scanner)
- ((:int :id :char :string)
- (prop (token-type scanner)
- (token-value scanner)))
- (#\?
- (let* ((stream (make-scanner-stream scanner))
- (sexp (read stream t)))
- (scanner-step scanner)
- (multiple-value-bind (type value)
- (decode-property sexp)
- (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)))))
- (or (seq (#\+) add)
- (seq (#\-) sub)
- (seq (#\*) mul)
- (seq (#\/) div))
- (or (seq (#\() lp)
- (seq (#\+) nop)
- (seq (#\-) neg))
- (when nestedp (seq (#\)) rp))))))))
+ (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))))))))