src/pset-parse.lisp: Report `{' and `<' as expected tokens in errors.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index e3fb6aef7ea28be5be24e95ed2fb13682579420b..6c751a4dff360cfa53d6b3f5d53e06bd369a2403 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -249,30 +249,45 @@ (define-on-demand-slot delegating-direct-method function-type (method)
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 

-(defmethod method-keyword-argument-lists
-    ((method effective-method) direct-methods)
-  (with-slots (message) method
-    (and (keyword-message-p message)
-        (cons (cons (c-function-keywords (sod-message-type message))
-                    (format nil "message ~A (at ~A)"
-                            message (file-location message)))
-              (mapcar (lambda (m)
-                        (cons (c-function-keywords (sod-method-type m))
-                              (format nil "method for ~A on ~A (at ~A)"
-                                      message
-                                      (sod-method-class m)
-                                      (file-location m))))
-                      direct-methods)))))
+(defmethod sod-message-keyword-argument-lists
+    ((message sod-message) (class sod-class) direct-methods state)
+  (and (keyword-message-p message)
+       (cons (cons (lambda (arg)
+                    (let ((class (sod-message-class message)))
+                      (info-with-location
+                       message "Type `~A' declared in message ~
+                                definition in `~A' (here)"
+                       (argument-type arg) class)
+                      (report-inheritance-path state class)))
+                  (c-function-keywords (sod-message-type message)))
+            (mapcar (lambda (method)
+                      (cons (lambda (arg)
+                              (let ((class (sod-method-class method)))
+                                (info-with-location
+                                 method "Type `~A' declared in ~A direct ~
+                                         method of `~A' (defined here)"
+                                 (argument-type arg)
+                                 (sod-method-description method) class)
+                                (report-inheritance-path state class)))
+                            (c-function-keywords (sod-method-type method))))
+                    direct-methods))))
+
+(defmethod sod-message-check-methods
+    ((message sod-message) (class sod-class) direct-methods)
+  (compute-effective-method-keyword-arguments message class direct-methods))

 
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 
 
 (defmethod shared-initialize :after
     ((method effective-method) slot-names &key direct-methods)
   (declare (ignore slot-names))
 

-  ;; Set the keyword argument list.
-  (with-slots (message keywords) method
+  ;; Set the keyword argument list.  Blame the class as a whole for mismatch
+  ;; errors, because they're fundamentally a non-local problem about the
+  ;; class construction.
+  (with-slots ((class %class) message keywords) method

     (setf keywords
     (setf keywords

-         (merge-keyword-lists (method-keyword-argument-lists
-                               method direct-methods)))))
+         (compute-effective-method-keyword-arguments message
+                                                     class
+                                                     direct-methods))))

 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods
 
 (export '(basic-effective-method
          effective-method-around-methods effective-method-before-methods


@@ -668,7 +683,8 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
               (codegen-push codegen)
               (ensure-var codegen "sod__obj" ilayout-type
                           (make-convert-to-ilayout-inst class
               (codegen-push codegen)
               (ensure-var codegen "sod__obj" ilayout-type
                           (make-convert-to-ilayout-inst class

-                                                        head "me"))))
+                                                        head "me"))
+              (deliver-call codegen :void "SOD__IGNORE" "sod__obj")))

           (finish-entry (tail)
             (let* ((head (sod-class-chain-head tail))
                    (role (if parm-n :valist nil))
           (finish-entry (tail)
             (let* ((head (sod-class-chain-head tail))
                    (role (if parm-n :valist nil))


@@ -799,6 +815,14 @@ (defmethod compute-effective-method-body :around
                    (*keyword-struct-disposition* :local))
               (ensure-var codegen *sod-keywords* (c-type (struct tag)))
               (make-keyword-parser-function codegen method tag set keywords)
                    (*keyword-struct-disposition* :local))
               (ensure-var codegen *sod-keywords* (c-type (struct tag)))
               (make-keyword-parser-function codegen method tag set keywords)

+              (emit-insts codegen
+                          (mapcar (lambda (keyword)
+                                    (make-set-inst
+                                     (format nil "~A.~A__suppliedp"
+                                             *sod-keywords*
+                                             (argument-name keyword))
+                                     0))
+                                  keywords))

               (parse-keywords (lambda ()
                                 (call :void name kw-addr ap-addr
                                       *null-pointer* 0)))
               (parse-keywords (lambda ()
                                 (call :void name kw-addr ap-addr
                                       *null-pointer* 0)))