| 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 | ;;; File searching. |
| 30 | |
| 31 | (defparameter *module-dirs* nil |
| 32 | "A list of directories (as pathname designators) to search for files. |
| 33 | |
| 34 | Both SOD module files and Lisp extension files are searched for in this |
| 35 | list. The search works by merging the requested pathname with each |
| 36 | element of this list in turn. The list is prefixed by the pathname of the |
| 37 | requesting file, so that it can refer to other files relative to wherever |
| 38 | it was found. |
| 39 | |
| 40 | See FIND-FILE for the grubby details.") |
| 41 | |
| 42 | (defun find-file (lexer name what thunk) |
| 43 | "Find a file called NAME on the module search path, and call THUNK on it. |
| 44 | |
| 45 | The file is searched for relative to the LEXER's current file, and also in |
| 46 | the directories mentioned in the *MODULE-DIRS* list. If the file is |
| 47 | found, then THUNK is invoked with two arguments: the name we used to find |
| 48 | it (which might be relative to the starting directory) and the truename |
| 49 | found by PROBE-FILE. |
| 50 | |
| 51 | If the file wasn't found, or there was some kind of error, then an error |
| 52 | is signalled; WHAT should be a noun phrase describing the kind of thing we |
| 53 | were looking for, suitable for inclusion in the error message. |
| 54 | |
| 55 | While FIND-FILE establishes condition handlers for its own purposes, THUNK |
| 56 | is not invoked with any additional handlers defined." |
| 57 | |
| 58 | (handler-case |
| 59 | (dolist (dir (cons (stream-pathname (lexer-stream lexer)) |
| 60 | *module-dirs*) |
| 61 | (values nil nil)) |
| 62 | (let* ((path (merge-pathnames name dir)) |
| 63 | (probe (probe-file path))) |
| 64 | (when probe |
| 65 | (return (values path probe))))) |
| 66 | (file-error (error) |
| 67 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) |
| 68 | (:no-error (path probe) |
| 69 | (cond ((null path) |
| 70 | (error "Failed to find ~A ~S" what name)) |
| 71 | (t |
| 72 | (funcall thunk path probe)))))) |
| 73 | |
| 74 | ;;;-------------------------------------------------------------------------- |
| 75 | ;;; Modules. |
| 76 | |
| 77 | (defclass module () |
| 78 | ((name :initarg :name |
| 79 | :type pathname |
| 80 | :accessor module-name) |
| 81 | (plist :initform nil |
| 82 | :initarg :plist |
| 83 | :type list |
| 84 | :accessor module-plist) |
| 85 | (classes :initform nil |
| 86 | :initarg :classes |
| 87 | :type list |
| 88 | :accessor module-classes) |
| 89 | (source-fragments :initform nil |
| 90 | :initarg :source-fragments |
| 91 | :type list |
| 92 | :accessor module-source-fragments) |
| 93 | (header-fragments :initform nil |
| 94 | :initarg :header-fragments |
| 95 | :type list |
| 96 | :accessor module-header-fragments) |
| 97 | (dependencies :initform nil |
| 98 | :initarg :dependencies |
| 99 | :type list |
| 100 | :accessor module-dependencies)) |
| 101 | (:documentation |
| 102 | "A module is a container for the definitions made in a source file. |
| 103 | |
| 104 | Modules are the fundamental units of translation. The main job of a |
| 105 | module is to remember which definitions it contains, so that they can be |
| 106 | translated and written to output files. The module contains the following |
| 107 | handy bits of information: |
| 108 | |
| 109 | * A (path) name, which is the filename we used to find it. The default |
| 110 | output filenames are derived from this. (We use the file's truename |
| 111 | as the hash key to prevent multiple inclusion, and that's a different |
| 112 | thing.) |
| 113 | |
| 114 | * A property list containing other useful things. |
| 115 | |
| 116 | * A list of the classes defined in the source file. |
| 117 | |
| 118 | * Lists of C fragments to be included in the output header and C source |
| 119 | files. |
| 120 | |
| 121 | * A list of other modules that this one depends on. |
| 122 | |
| 123 | Modules are usually constructed by the PARSE-MODULE function, which is in |
| 124 | turn usually invoked by IMPORT-MODULE, though there's nothing to stop |
| 125 | fancy extensions building modules programmatically.")) |
| 126 | |
| 127 | (defun import-module (pathname &key (truename (truename pathname))) |
| 128 | "Import a module. |
| 129 | |
| 130 | The module is returned if all went well; NIL is returned if an error |
| 131 | occurred. |
| 132 | |
| 133 | The PATHNAME argument is the file to read. TRUENAME should be the file's |
| 134 | truename, if known: often, the file will have been searched for using |
| 135 | PROBE-FILE or similar, which drops the truename into your lap." |
| 136 | |
| 137 | (let ((module (gethash truename *module-map*))) |
| 138 | (cond |
| 139 | |
| 140 | ;; The module's not there. (The *MODULE-MAP* never maps things to |
| 141 | ;; NIL.) |
| 142 | ((null module) |
| 143 | |
| 144 | ;; Mark the module as being in progress. Another attempt to import it |
| 145 | ;; will fail. |
| 146 | (setf (gethash truename *module-map*) :in-progress) |
| 147 | |
| 148 | ;; Be careful to restore the state of the module map on exit. |
| 149 | (unwind-protect |
| 150 | |
| 151 | ;; Open the module file and parse it. |
| 152 | (with-open-file (f-stream pathname :direction :input) |
| 153 | (let* ((pai-stream (make-instance 'position-aware-input-stream |
| 154 | :stream f-stream |
| 155 | :file pathname)) |
| 156 | (lexer (make-instance 'sod-lexer :stream pai-stream))) |
| 157 | (with-default-error-location (lexer) |
| 158 | (restart-case |
| 159 | (progn |
| 160 | (next-char lexer) |
| 161 | (next-token lexer) |
| 162 | (setf module (parse-module lexer))) |
| 163 | (continue () |
| 164 | :report "Ignore the import and continue" |
| 165 | nil)))))) |
| 166 | |
| 167 | ;; If we successfully parsed the module, then store it in the table; |
| 168 | ;; otherwise remove it because we might want to try again. (That |
| 169 | ;; might not work very well, but it could be worth a shot.) |
| 170 | (if module |
| 171 | (setf (gethash truename *module-map*) module) |
| 172 | (remhash truename *module-map*))) |
| 173 | |
| 174 | ;; A module which is being read can't be included again. |
| 175 | ((eql module :in-progress) |
| 176 | (error "Cyclic module dependency involving module ~A" pathname)) |
| 177 | |
| 178 | ;; A module which was successfully read. Just return it. |
| 179 | (t |
| 180 | module)))) |
| 181 | |
| 182 | (defun parse-module (lexer) |
| 183 | "Parse a module from the given LEXER. |
| 184 | |
| 185 | The newly constructed module is returned. This is the top-level parsing |
| 186 | function." |
| 187 | |
| 188 | (let ((hfrags nil) |
| 189 | (cfrags nil) |
| 190 | (classes nil) |
| 191 | (plist nil) |
| 192 | (deps nil)) |
| 193 | |
| 194 | (labels ((fragment (func) |
| 195 | (next-token lexer) |
| 196 | (when (require-token lexer #\{ :consumep nil) |
| 197 | (let ((frag (scan-c-fragment lexer '(#\})))) |
| 198 | (next-token lexer) |
| 199 | (require-token lexer #\}) |
| 200 | (funcall func frag))))) |
| 201 | |
| 202 | (tagbody |
| 203 | |
| 204 | top |
| 205 | ;; module : empty | module-def module |
| 206 | ;; |
| 207 | ;; Just read module-defs until we reach the end of the file. |
| 208 | (case (token-type lexer) |
| 209 | |
| 210 | (:eof |
| 211 | (go done)) |
| 212 | (#\; |
| 213 | (next-token lexer) |
| 214 | (go top)) |
| 215 | |
| 216 | ;; module-def : `import' string `;' |
| 217 | ;; |
| 218 | ;; Read another module of definitions from a file. |
| 219 | (:import |
| 220 | (next-token lexer) |
| 221 | (let ((name (require-token lexer :string))) |
| 222 | (when name |
| 223 | (find-file lexer |
| 224 | (merge-pathnames name (make-pathname |
| 225 | :type "SOD" |
| 226 | :case :common)) |
| 227 | "module" |
| 228 | (lambda (path true) |
| 229 | (handler-case |
| 230 | (let ((module (import-module path |
| 231 | :truename true))) |
| 232 | (when module |
| 233 | (push module deps))) |
| 234 | (file-error (error) |
| 235 | (cerror* "Error reading module ~S: ~A" |
| 236 | path error))))))) |
| 237 | (go semicolon)) |
| 238 | |
| 239 | ;; module-def : `load' string `;' |
| 240 | ;; |
| 241 | ;; Load a Lisp extension from a file. |
| 242 | (:load |
| 243 | (next-token lexer) |
| 244 | (let ((name (require-token lexer :string))) |
| 245 | (when name |
| 246 | (find-file lexer |
| 247 | (merge-pathnames name |
| 248 | (make-pathname :type "LISP" |
| 249 | :case :common)) |
| 250 | "Lisp file" |
| 251 | (lambda (path true) |
| 252 | (handler-case (load true |
| 253 | :verbose nil |
| 254 | :print nil) |
| 255 | (error (error) |
| 256 | (cerror* "Error loading Lisp file ~S: ~A" |
| 257 | path error))))))) |
| 258 | (go semicolon)) |
| 259 | |
| 260 | ;; module-def : `lisp' sexp |
| 261 | ;; |
| 262 | ;; Process an in-line Lisp form immediately. |
| 263 | (:lisp |
| 264 | (let ((form (with-lexer-stream (stream lexer) |
| 265 | (read stream t)))) |
| 266 | (handler-case |
| 267 | (eval form) |
| 268 | (error (error) |
| 269 | (cerror* "Error in Lisp form: ~A" error)))) |
| 270 | (next-token lexer) |
| 271 | (go top)) |
| 272 | |
| 273 | ;; module-def : `typename' ids `;' |
| 274 | ;; ids : id | ids `,' id |
| 275 | ;; |
| 276 | ;; Add ids as registered type names. We don't need to know what |
| 277 | ;; they mean at this level. |
| 278 | (:typename |
| 279 | (next-token lexer) |
| 280 | (loop |
| 281 | (let ((id (require-token lexer :id))) |
| 282 | (cond ((null id) |
| 283 | (return)) |
| 284 | ((gethash id *type-map*) |
| 285 | (cerror* "Type ~A is already defined" id)) |
| 286 | (t |
| 287 | (setf (gethash id *type-map*) |
| 288 | (make-instance 'simple-c-type :name id)))) |
| 289 | (unless (eql (token-type lexer) #\,) |
| 290 | (return)) |
| 291 | (next-token lexer))) |
| 292 | (go semicolon)) |
| 293 | |
| 294 | ;; module-def : `source' `{' c-stuff `}' |
| 295 | ;; module-def : `header' `{' c-stuff `}' |
| 296 | (:source |
| 297 | (fragment (lambda (frag) (push frag cfrags))) |
| 298 | (go top)) |
| 299 | (:header |
| 300 | (fragment (lambda (frag) (push frag hfrags))) |
| 301 | (go top)) |
| 302 | |
| 303 | ;; Anything else is an error. |
| 304 | (t |
| 305 | (cerror* "Unexpected token ~A ignored" (format-token lexer)) |
| 306 | (next-token lexer) |
| 307 | (go top))) |
| 308 | |
| 309 | semicolon |
| 310 | ;; Scan a terminating semicolon. |
| 311 | (require-token lexer #\;) |
| 312 | (go top) |
| 313 | |
| 314 | done) |
| 315 | |
| 316 | ;; Assemble the module and we're done. |
| 317 | (make-instance 'module |
| 318 | :name (stream-pathname (lexer-stream lexer)) |
| 319 | :plist plist |
| 320 | :classes classes |
| 321 | :header-fragments hfrags |
| 322 | :source-fragments cfrags |
| 323 | :dependencies deps)))) |
| 324 | |
| 325 | ;;;----- That's all, folks -------------------------------------------------- |