doc/*.tex: Add stubs for `file-location' reader methods.

[sod] / src / module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index 0a3cd28296adcfbb129cbf61cc5a8641bf584d9e..df058bee46bc179b69181dd2dab942d65cdc1d28 100644 (file)
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -141,7 +141,7 @@ (define-pluggable-parser module file (scanner pset)
   (declare (ignore pset))
   (flet ((common (name type what thunk)
           (when name
   (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))
                        (merge-pathnames name
                                         (make-pathname :type type
                                                        :case :common))


@@ -226,7 +226,7 @@ (define-pluggable-parser class-item initfrags (scanner class pset)
     (parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag)
                           (seq ("teardown") #'make-sod-class-tearfrag)))
                 (frag (parse-delimited-fragment scanner #\{ #\})))
     (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]
 
 (define-pluggable-parser class-item initargs (scanner class pset)
   ;; initarg-item ::= `initarg' declspec+ list[init-declarator]


@@ -243,7 +243,9 @@ (define-pluggable-parser class-item initargs (scanner class pset)
                          (make-sod-user-initarg class
                                                 (cdr declarator)
                                                 (car declarator)
                          (make-sod-user-initarg class
                                                 (cdr declarator)
                                                 (car declarator)

-                                                pset init scanner))
+                                                pset
+                                                :default init
+                                                :location scanner))

                        #\,))
                 (nil (must #\;)))))))
 
                        #\,))
                 (nil (must #\;)))))))
 


@@ -267,7 +269,14 @@ (defun parse-class-body (scanner pset name supers)
                                  (continue ()
                                    (setf duff t)
                                    (list (find-sod-class "SodObject"))))))
                                  (continue ()
                                    (setf duff t)
                                    (list (find-sod-class "SodObject"))))))

-             superclasses))
+             (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
           (synthetic-name (or name
                               (let ((var (synthetic-name)))
                                 (unless pset


@@ -275,7 +284,8 @@ (defun parse-class-body (scanner pset name supers)
                                 (unless (pset-get pset "nick")
                                   (add-property pset "nick" var :type :id))
                                 var)))
                                 (unless (pset-get pset "nick")
                                   (add-property pset "nick" var :type :id))
                                 var)))

-          (class (make-sod-class synthetic-name superclasses pset scanner))
+          (class (make-sod-class synthetic-name superclasses pset
+                                 :location scanner))

           (nick (sod-class-nickname class)))
 
       (labels ((must-id ()
           (nick (sod-class-nickname class)))
 
       (labels ((must-id ()


@@ -306,8 +316,8 @@ (defun parse-class-body (scanner pset name supers)
                 ;; 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.
                 ;; 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
                   (if (varargs-message-p message)
                       (parse #\;)
                       (parse (or #\; (parse-method-item sub-pset


@@ -323,7 +333,8 @@ (defun parse-class-body (scanner pset name supers)
                                         scanner #\{ #\}))))
                          (restart-case
                              (make-sod-method class sub-nick name type
                                         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 ()
                            (continue () :report "Continue")))))
 
               (parse-initializer ()


@@ -343,14 +354,12 @@ (defun parse-class-body (scanner pset name supers)
                 (flet ((make-it (name type init)
                          (restart-case
                              (progn
                 (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
                                (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))))
                            (continue () :report "Continue"))))
                   (parse (and (error ()
                                   (seq ((init (? (parse-initializer))))


@@ -381,7 +390,8 @@ (defun parse-class-body (scanner pset name supers)
                                       (restart-case
                                           (funcall constructor class
                                                    name-a name-b init
                                       (restart-case
                                           (funcall constructor class
                                                    name-a name-b init

-                                                   sub-pset scanner)
+                                                   sub-pset
+                                                   :location scanner)

                                         (continue () :report "Continue")))
                                   (skip-until () #\, #\;))
                                 #\,)
                                         (continue () :report "Continue")))
                                   (skip-until () #\, #\;))
                                 #\,)