X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8152ead4c5c5980414d1a4f21a98e851cc25c9b1..bfd08be5c65f696eddf48cfa48eaeab2714a3ec5:/src/module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index c5b28a6..df058be 100644
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -141,7 +141,7 @@
   (declare (ignore pset))
   (flet ((common (name type what thunk)
 	   (when name
-	     (find-file scanner
+	     (find-file (pathname (scanner-filename scanner))
 			(merge-pathnames name
 					 (make-pathname :type type
 							:case :common))
@@ -226,7 +226,7 @@
     (parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag)
 			   (seq ("teardown") #'make-sod-class-tearfrag)))
 		 (frag (parse-delimited-fragment scanner #\{ #\})))
-	     (funcall make class frag pset scanner)))))
+	     (funcall make class frag pset :location scanner)))))
 
 (define-pluggable-parser class-item initargs (scanner class pset)
   ;; initarg-item ::= `initarg' declspec+ list[init-declarator]
@@ -243,7 +243,9 @@
 			  (make-sod-user-initarg class
 						 (cdr declarator)
 						 (car declarator)
-						 pset init scanner))
+						 pset
+						 :default init
+						 :location scanner))
 			#\,))
 		 (nil (must #\;)))))))
 
@@ -260,6 +262,21 @@
   (with-parser-context (token-scanner-context :scanner scanner)
     (when name (make-class-type name))
     (let* ((duff (null name))
+	   (superclasses
+	    (let ((superclasses (restart-case
+				    (mapcar #'find-sod-class
+					    (or supers (list "SodObject")))
+				  (continue ()
+				    (setf duff t)
+				    (list (find-sod-class "SodObject"))))))
+	      (find-duplicates (lambda (first second)
+				 (declare (ignore second))
+				 (setf duff t)
+				 (cerror* "Class `~A' has duplicate ~
+					   direct superclass `~A'"
+					  name first))
+			       superclasses)
+	      (delete-duplicates superclasses)))
 	   (synthetic-name (or name
 			       (let ((var (synthetic-name)))
 				 (unless pset
@@ -267,14 +284,8 @@
 				 (unless (pset-get pset "nick")
 				   (add-property pset "nick" var :type :id))
 				 var)))
-	   (class (make-sod-class synthetic-name
-				  (restart-case
-				      (mapcar #'find-sod-class
-					      (or supers (list "SodObject")))
-				    (continue ()
-				      (setf duff t)
-				      (list (find-sod-class "SodObject"))))
-				  pset scanner))
+	   (class (make-sod-class synthetic-name superclasses pset
+				  :location scanner))
 	   (nick (sod-class-nickname class)))
 
       (labels ((must-id ()
@@ -305,8 +316,8 @@
 		 ;; Don't allow a method-body here if the message takes a
 		 ;; varargs list, because we don't have a name for the
 		 ;; `va_list' parameter.
-		 (let ((message (make-sod-message class name type
-						  sub-pset scanner)))
+		 (let ((message (make-sod-message class name type sub-pset
+						  :location scanner)))
 		   (if (varargs-message-p message)
 		       (parse #\;)
 		       (parse (or #\; (parse-method-item sub-pset
@@ -322,7 +333,8 @@
 					 scanner #\{ #\}))))
 			  (restart-case
 			      (make-sod-method class sub-nick name type
-					       body sub-pset scanner)
+					       body sub-pset
+					       :location scanner)
 			    (continue () :report "Continue")))))
 
 	       (parse-initializer ()
@@ -342,14 +354,12 @@
 		 (flet ((make-it (name type init)
 			  (restart-case
 			      (progn
-				(make-sod-slot class name type
-					       sub-pset scanner)
+				(make-sod-slot class name type sub-pset
+					       :location scanner)
 				(when init
-				  (make-sod-instance-initializer class
-								 nick name
-								 init
-								 sub-pset
-								 scanner)))
+				  (make-sod-instance-initializer
+				   class nick name init sub-pset
+				   :location scanner)))
 			    (continue () :report "Continue"))))
 		   (parse (and (error ()
 				   (seq ((init (? (parse-initializer))))
@@ -380,7 +390,8 @@
 				       (restart-case
 					   (funcall constructor class
 						    name-a name-b init
-						    sub-pset scanner)
+						    sub-pset
+						    :location scanner)
 					 (continue () :report "Continue")))
 				   (skip-until () #\, #\;))
 				 #\,)