chiark - git - mdw - sod/blob - pre-reorg/module.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Modules and module parser
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Module importing.
  30
  31 (defun read-module (pathname &key (truename (truename pathname)) location)
  32   "Reads a module.
  33
  34    The module is returned if all went well; nil is returned if an error
  35    occurred.
  36
  37    The PATHNAME argument is the file to read.  TRUENAME should be the file's
  38    truename, if known: often, the file will have been searched for using
  39    `probe-file' or similar, which drops the truename into your lap."
  40
  41   ;; Deal with a module which is already in the map.  If its state is a
  42   ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
  43   (let ((module (gethash truename *module-map*)))
  44     (cond ((null module))
  45           ((typep (module-state module) 'file-location)
  46            (error "Module ~A already being imported at ~A"
  47                   pathname (module-state module)))
  48           (module
  49            (return-from read-module module))))
  50
  51   ;; Make a new module.  Be careful to remove the module from the map if we
  52   ;; didn't succeed in constructing it.
  53   (define-module (pathname :location location :truename truename)
  54     (let ((*readtable* (copy-readtable)))
  55       (with-open-file (f-stream pathname :direction :input)
  56         (let* ((pai-stream (make-instance 'position-aware-input-stream
  57                                           :stream f-stream
  58                                           :file pathname))
  59                (lexer (make-instance 'sod-lexer :stream pai-stream)))
  60           (with-default-error-location (lexer)
  61             (next-char lexer)
  62             (next-token lexer)
  63             (parse-module lexer)))))))
  64
  65 ;;;--------------------------------------------------------------------------
  66 ;;; Module parsing protocol.
  67
  68 (defgeneric parse-module-declaration (tag lexer pset)
  69   (:method (tag lexer pset)
  70     (error "Unexpected module declaration ~(~A~)" tag))
  71   (:method :before (tag lexer pset)
  72     (next-token lexer)))
  73
  74 (defun parse-module (lexer)
  75   "Main dispatching for module parser.
  76
  77    Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
  78
  79   (loop
  80     (restart-case
  81         (case (token-type lexer)
  82           (:eof (return))
  83           (#\; (next-token lexer))
  84           (t (let ((pset (parse-property-set lexer)))
  85                (case (token-type lexer)
  86                  (:id (let ((tag (intern (frob-case (token-value lexer))
  87                                          :keyword)))
  88                         (parse-module-declaration tag lexer pset)
  89                         (check-unused-properties pset)))
  90                  (t (error "Unexpected token ~A: ignoring"
  91                            (format-token lexer)))))))
  92       (continue ()
  93         :report "Ignore the error and continue parsing."
  94         nil))))
  95
  96 (defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
  97   "module-decl ::= `typename' id-list `;'"
  98   (loop (let ((name (require-token lexer :id)))
  99           (unless name (return))
 100           (if (gethash name *type-map*)
 101               (cerror* "Type `~A' already defined" name)
 102               (add-to-module *module* (make-instance 'type-item :name name)))
 103           (unless (require-token lexer #\, :errorp nil) (return))))
 104   (require-token lexer #\;))
 105
 106 ;;;--------------------------------------------------------------------------
 107 ;;; Fragments.
 108
 109 (defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
 110   "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
 111    constraint ::= id*"
 112   (labels ((parse-constraint ()
 113              (let ((list nil))
 114                (loop (let ((id (require-token lexer :id
 115                                               :errorp (null list))))
 116                        (unless id (return))
 117                        (push id list)))
 118                (nreverse list)))
 119            (parse-constraints ()
 120              (let ((list nil))
 121                (when (require-token lexer #\[ :errorp nil)
 122                  (loop (let ((constraint (parse-constraint)))
 123                          (push constraint list)
 124                          (unless (require-token lexer #\, :errorp nil)
 125                            (return))))
 126                  (require-token lexer #\]))
 127                (nreverse list)))
 128            (keywordify (id)
 129              (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
 130     (let* ((reason (prog1 (keywordify (require-token lexer :id))
 131                    (require-token lexer #\:)))
 132            (name (keywordify (require-token lexer :id)))
 133            (constraints (parse-constraints)))
 134       (when (require-token lexer #\{ :consumep nil)
 135         (let ((frag (scan-c-fragment lexer '(#\}))))
 136           (next-token lexer)
 137           (require-token lexer #\})
 138           (add-to-module *module*
 139                          (make-instance 'code-fragment-item
 140                                         :name name
 141                                         :reason reason
 142                                         :constraints constraints
 143                                         :fragment frag)))))))
 144
 145 ;;;--------------------------------------------------------------------------
 146 ;;; File searching.
 147
 148
 149 (defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
 150   "module-decl ::= `import' string `;'"
 151   (let ((name (require-token lexer :string)))
 152     (when name
 153       (find-file lexer
 154                  (merge-pathnames name
 155                                   (make-pathname :type "SOD" :case :common))
 156                  "module"
 157                  (lambda (path true)
 158                    (handler-case
 159                        (let ((module (read-module path :truename true)))
 160                          (when module
 161                            (module-import module)
 162                            (pushnew module (module-dependencies *module*))))
 163                      (file-error (error)
 164                        (cerror* "Error reading module ~S: ~A"
 165                                 path error)))))
 166       (require-token lexer #\;))))
 167
 168 (defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
 169   "module-decl ::= `load' string `;'"
 170   (let ((name (require-token lexer :string)))
 171     (when name
 172       (find-file lexer
 173                  (merge-pathnames name
 174                                   (make-pathname :type "LISP" :case :common))
 175                  "Lisp file"
 176                  (lambda (path true)
 177                    (handler-case (load true :verbose nil :print nil)
 178                      (error (error)
 179                        (cerror* "Error loading Lisp file ~S: ~A"
 180                                 path error)))))
 181       (require-token lexer #\;))))
 182
 183 ;;;--------------------------------------------------------------------------
 184 ;;; Lisp escapes.
 185
 186 (defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
 187   "module-decl ::= `lisp' s-expression `;'"
 188   (let ((form (with-lexer-stream (stream lexer) (read stream t))))
 189     (eval form))
 190   (next-token lexer)
 191   (require-token lexer #\;))
 192
 193 ;;;--------------------------------------------------------------------------
 194 ;;; Class declarations.
 195
 196 (defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
 197   "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
 198   (let* ((location (file-location lexer))
 199          (name (let ((name (require-token lexer :id)))
 200                  (make-class-type name location)
 201                  (when (require-token lexer #\; :errorp nil)
 202                    (return-from parse-module-declaration))
 203                  name))
 204          (supers (when (require-token lexer #\: :errorp nil)
 205                    (let ((list nil))
 206                      (loop (let ((id (require-token lexer :id)))
 207                              (unless id (return))
 208                              (push id list)
 209                              (unless (require-token lexer #\, :errorp nil)
 210                                (return))))
 211                      (nreverse list))))
 212          (class (make-sod-class name (mapcar #'find-sod-class supers)
 213                                 pset location))
 214          (nick (sod-class-nickname class)))
 215     (require-token lexer #\{)
 216
 217     (labels ((parse-item ()
 218                "Try to work out what kind of item this is.  Messy."
 219                (let* ((pset (parse-property-set lexer))
 220                       (location (file-location lexer)))
 221                  (cond ((declaration-specifier-p lexer)
 222                         (let ((declspec (parse-c-type lexer)))
 223                           (multiple-value-bind (type name)
 224                               (parse-c-declarator lexer declspec :dottedp t)
 225                             (cond ((null type)
 226                                    nil)
 227                                   ((consp name)
 228                                    (parse-method type (car name) (cdr name)
 229                                                  pset location))
 230                                   ((typep type 'c-function-type)
 231                                    (parse-message type name pset location))
 232                                   (t
 233                                    (parse-slots declspec type name
 234                                                 pset location))))))
 235                        ((not (eq (token-type lexer) :id))
 236                         (cerror* "Expected <class-item>; found ~A (skipped)"
 237                                  (format-token lexer))
 238                         (next-token lexer))
 239                        ((string= (token-value lexer) "class")
 240                         (next-token lexer)
 241                         (parse-initializers #'make-sod-class-initializer
 242                                             pset location))
 243                        (t
 244                         (parse-initializers #'make-sod-instance-initializer
 245                                             pset location)))))
 246
 247              (parse-method (type nick name pset location)
 248                "class-item ::= declspec+ dotted-declarator -!- method-body
 249
 250                 method-body ::= `{' c-fragment `}' | `extern' `;'
 251
 252                 The dotted-declarator must describe a function type."
 253                (let ((body (cond ((eq (token-type lexer) #\{)
 254                                   (prog1 (scan-c-fragment lexer '(#\}))
 255                                     (next-token lexer)
 256                                     (require-token lexer #\})))
 257                                  ((and (eq (token-type lexer) :id)
 258                                        (string= (token-value lexer)
 259                                                 "extern"))
 260                                   (next-token lexer)
 261                                   (require-token lexer #\;)
 262                                   nil)
 263                                  (t
 264                                   (cerror* "Expected <method-body>; ~
 265                                             found ~A"
 266                                            (format-token lexer))))))
 267                  (make-sod-method class nick name type body pset location)))
 268
 269              (parse-message (type name pset location)
 270                "class-item ::= declspec+ declarator -!- (method-body | `;')
 271
 272                 The declarator must describe a function type."
 273                (make-sod-message class name type pset location)
 274                (unless (require-token lexer #\; :errorp nil)
 275                  (parse-method type nick name nil location)))
 276
 277              (parse-initializer-body ()
 278                "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
 279                (let ((char (lexer-char lexer)))
 280                  (loop
 281                    (when (or (null char) (not (whitespace-char-p char)))
 282                      (return))
 283                    (setf char (next-char lexer)))
 284                  (cond ((eql char #\{)
 285                         (next-char lexer)
 286                         (let ((frag (scan-c-fragment lexer '(#\}))))
 287                           (next-token lexer)
 288                           (require-token lexer #\})
 289                           (values :compound frag)))
 290                        (t
 291                         (let ((frag (scan-c-fragment lexer '(#\, #\;))))
 292                           (next-token lexer)
 293                           (values :simple frag))))))
 294
 295              (parse-slots (declspec type name pset location)
 296                "class-item ::=
 297                   declspec+ init-declarator [`,' init-declarator-list] `;'
 298
 299                 init-declarator ::= declarator -!- [initializer]"
 300                (loop
 301                  (make-sod-slot class name type pset location)
 302                  (when (eql (token-type lexer) #\=)
 303                    (multiple-value-bind (kind form) (parse-initializer-body)
 304                      (make-sod-instance-initializer class nick name
 305                                                     kind form nil
 306                                                     location)))
 307                  (unless (require-token lexer #\, :errorp nil)
 308                    (return))
 309                  (setf (values type name)
 310                        (parse-c-declarator lexer declspec)
 311                        location (file-location lexer)))
 312                (require-token lexer #\;))
 313
 314              (parse-initializers (constructor pset location)
 315                "class-item ::= [`class'] -!- slot-initializer-list `;'
 316
 317                 slot-initializer ::= id `.' id initializer"
 318                (loop
 319                  (let ((nick (prog1 (require-token lexer :id)
 320                                (require-token lexer #\.)))
 321                        (name (require-token lexer :id)))
 322                    (require-token lexer #\=)
 323                    (multiple-value-bind (kind form)
 324                        (parse-initializer-body)
 325                      (funcall constructor class nick name kind form
 326                               pset location)))
 327                  (unless (require-token lexer #\, :errorp nil)
 328                    (return))
 329                  (setf location (file-location lexer)))
 330                (require-token lexer #\;)))
 331
 332       (loop
 333         (when (require-token lexer #\} :errorp nil)
 334           (return))
 335         (parse-item)))
 336
 337     (finalize-sod-class class)
 338     (add-to-module *module* class)))
 339
 340 ;;;----- That's all, folks --------------------------------------------------