| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Module protocol implementation |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
| 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 basics. |
| 30 | |
| 31 | (defmethod module-import ((module module)) |
| 32 | (dolist (item (module-items module)) |
| 33 | (module-import item))) |
| 34 | |
| 35 | (defmethod add-to-module ((module module) item) |
| 36 | (setf (module-items module) |
| 37 | (nconc (module-items module) (list item))) |
| 38 | (module-import item)) |
| 39 | |
| 40 | (defmethod shared-initialize :after ((module module) slot-names &key pset) |
| 41 | "Tick off known properties on the property set." |
| 42 | (declare (ignore slot-names)) |
| 43 | (dolist (prop '(:guard)) |
| 44 | (get-property pset prop nil))) |
| 45 | |
| 46 | (defmethod finalize-module ((module module)) |
| 47 | (let* ((pset (module-pset module)) |
| 48 | (class (get-property pset :module-class :symbol 'module))) |
| 49 | |
| 50 | ;; Always call `change-class', even if it's the same one; this will |
| 51 | ;; exercise the property-set fiddling in `shared-initialize' and we can |
| 52 | ;; catch unknown-property errors. |
| 53 | (change-class module class :state t :pset pset) |
| 54 | (check-unused-properties pset))) |
| 55 | |
| 56 | ;;;-------------------------------------------------------------------------- |
| 57 | ;;; Module objects. |
| 58 | |
| 59 | (defvar-unbound *module-map* |
| 60 | "Hash table mapping true names to module objects.") |
| 61 | (define-clear-the-decks reset-module-map |
| 62 | (setf *module-map* (make-hash-table :test #'equal))) |
| 63 | |
| 64 | (defun build-module |
| 65 | (name thunk &key (truename (probe-file name)) location) |
| 66 | "Construct a new module. |
| 67 | |
| 68 | This is the functionality underlying `define-module': see that macro for |
| 69 | full information." |
| 70 | |
| 71 | ;; Check for an import cycle. |
| 72 | (when truename |
| 73 | (let ((existing (gethash truename *module-map*))) |
| 74 | (cond ((null existing)) |
| 75 | ((eq (module-state existing) t) |
| 76 | (return-from build-module existing)) |
| 77 | (t |
| 78 | (error "Module ~A already being imported at ~A" |
| 79 | name (module-state existing)))))) |
| 80 | |
| 81 | ;; Construct the new module. |
| 82 | (let ((*module* (make-instance 'module |
| 83 | :name (pathname name) |
| 84 | :state (file-location location)))) |
| 85 | (when truename |
| 86 | (setf (gethash truename *module-map*) *module*)) |
| 87 | (unwind-protect |
| 88 | (with-module-environment () |
| 89 | (module-import *builtin-module*) |
| 90 | (funcall thunk) |
| 91 | (finalize-module *module*) |
| 92 | *module*) |
| 93 | (when (and truename (not (eq (module-state *module*) t))) |
| 94 | (remhash truename *module-map*))))) |
| 95 | |
| 96 | (defun call-with-module-environment (thunk &optional (module *module*)) |
| 97 | "Invoke THUNK with bindings for the module variables in scope. |
| 98 | |
| 99 | This is the guts of `with-module-environment', which you should probably |
| 100 | use instead." |
| 101 | (progv |
| 102 | (mapcar #'car *module-bindings-alist*) |
| 103 | (module-variables module) |
| 104 | (unwind-protect (funcall thunk) |
| 105 | (setf (module-variables module) |
| 106 | (mapcar (compose #'car #'symbol-value) |
| 107 | *module-bindings-alist*))))) |
| 108 | |
| 109 | (defun call-with-temporary-module (thunk) |
| 110 | "Invoke THUNK in the context of a temporary module, returning its values. |
| 111 | |
| 112 | This is mainly useful for testing things which depend on module variables. |
| 113 | This is the functionality underlying `with-temporary-module'." |
| 114 | (let ((*module* (make-instance 'module |
| 115 | :name "<temp>" |
| 116 | :state nil))) |
| 117 | (with-module-environment () |
| 118 | (module-import *builtin-module*) |
| 119 | (funcall thunk)))) |
| 120 | |
| 121 | ;;;-------------------------------------------------------------------------- |
| 122 | ;;; Type definitions. |
| 123 | |
| 124 | (export 'type-item) |
| 125 | (defclass type-item () |
| 126 | ((name :initarg :name :type string :reader type-name)) |
| 127 | (:documentation |
| 128 | "A note that a module exports a type. |
| 129 | |
| 130 | We can only export simple types, so we only need to remember the name. |
| 131 | The magic simple-type cache will ensure that we get the same type object |
| 132 | when we do the import.")) |
| 133 | |
| 134 | (defmethod module-import ((item type-item)) |
| 135 | (let* ((name (type-name item)) |
| 136 | (def (gethash name *module-type-map*)) |
| 137 | (type (make-simple-type name))) |
| 138 | (cond ((not def) |
| 139 | (setf (gethash name *module-type-map*) type)) |
| 140 | ((not (eq def type)) |
| 141 | (error "Conflicting types `~A'" name))))) |
| 142 | |
| 143 | (defmethod module-import ((class sod-class)) |
| 144 | (record-sod-class class)) |
| 145 | |
| 146 | ;;;-------------------------------------------------------------------------- |
| 147 | ;;; Code fragments. |
| 148 | |
| 149 | (export '(c-fragment c-fragment-text)) |
| 150 | (defclass c-fragment () |
| 151 | ((location :initarg :location :type file-location :reader file-location) |
| 152 | (text :initarg :text :type string :reader c-fragment-text)) |
| 153 | (:documentation |
| 154 | "Represents a fragment of C code to be written to an output file. |
| 155 | |
| 156 | A C fragment is aware of its original location, and will bear proper #line |
| 157 | markers when written out.")) |
| 158 | |
| 159 | (defun output-c-excursion (stream location func) |
| 160 | "Invoke FUNC surrounding it by writing #line markers to STREAM. |
| 161 | |
| 162 | The first marker describes LOCATION; the second refers to the actual |
| 163 | output position in STREAM. If LOCATION doesn't provide a line number then |
| 164 | no markers are output after all. If the output stream isn't |
| 165 | position-aware then no final marker is output. |
| 166 | |
| 167 | FUNC is passed the output stream as an argument. Complicated games may be |
| 168 | played with interposed streams. Try not to worry about it." |
| 169 | |
| 170 | (flet ((doit (stream) |
| 171 | (let* ((location (file-location location)) |
| 172 | (line (file-location-line location)) |
| 173 | (filename (file-location-filename location))) |
| 174 | (cond (line |
| 175 | (when (typep stream 'position-aware-stream) |
| 176 | (format stream "~&#line ~D~@[ ~S~]~%" line filename)) |
| 177 | (funcall func stream) |
| 178 | (when (typep stream 'position-aware-stream) |
| 179 | (fresh-line stream) |
| 180 | (format stream "#line ~D ~S~%" |
| 181 | (1+ (position-aware-stream-line stream)) |
| 182 | (let ((path (stream-pathname stream))) |
| 183 | (if path (namestring path) |
| 184 | "<sod-output>"))))) |
| 185 | (t |
| 186 | (funcall func stream)))))) |
| 187 | (print-ugly-stuff stream #'doit))) |
| 188 | |
| 189 | (defmethod print-object ((fragment c-fragment) stream) |
| 190 | (let ((text (c-fragment-text fragment)) |
| 191 | (location (file-location fragment))) |
| 192 | (if *print-escape* |
| 193 | (print-unreadable-object (fragment stream :type t) |
| 194 | (when location |
| 195 | (format stream "~A " location)) |
| 196 | (cond ((< (length text) 40) |
| 197 | (prin1 text stream) stream) |
| 198 | (t |
| 199 | (prin1 (subseq text 0 37) stream) |
| 200 | (write-string "..." stream)))) |
| 201 | (output-c-excursion stream location |
| 202 | (lambda (stream) (write-string text stream)))))) |
| 203 | |
| 204 | (defmethod make-load-form ((fragment c-fragment) &optional environment) |
| 205 | (make-load-form-saving-slots fragment :environment environment)) |
| 206 | |
| 207 | (export '(code-fragment-item code-fragment code-fragment-reason |
| 208 | code-fragment-name code-fragment-constraints)) |
| 209 | (defclass code-fragment-item () |
| 210 | ((fragment :initarg :fragment :type (or string c-fragment) |
| 211 | :reader code-fragment) |
| 212 | (reason :initarg :reason :type keyword :reader code-fragment-reason) |
| 213 | (name :initarg :name :type t :reader code-fragment-name) |
| 214 | (constraints :initarg :constraints :type list |
| 215 | :reader code-fragment-constraints)) |
| 216 | (:documentation |
| 217 | "A plain fragment of C to be dropped in at top-level.")) |
| 218 | |
| 219 | ;;;-------------------------------------------------------------------------- |
| 220 | ;;; File searching. |
| 221 | |
| 222 | (export '*module-dirs*) |
| 223 | (defparameter *module-dirs* nil |
| 224 | "A list of directories (as pathname designators) to search for files. |
| 225 | |
| 226 | Both SOD module files and Lisp extension files are searched for in this |
| 227 | list. The search works by merging the requested pathname with each |
| 228 | element of this list in turn. The list is prefixed by the pathname of the |
| 229 | requesting file, so that it can refer to other files relative to wherever |
| 230 | it was found. |
| 231 | |
| 232 | See `find-file' for the grubby details.") |
| 233 | |
| 234 | (export 'find-file) |
| 235 | (defun find-file (scanner name what thunk) |
| 236 | "Find a file called NAME on the module search path, and call THUNK on it. |
| 237 | |
| 238 | The file is searched for relative to the SCANNER's current file, and also |
| 239 | in the directories mentioned in the `*module-dirs*' list. If the file is |
| 240 | found, then THUNK is invoked with two arguments: the name we used to find |
| 241 | it (which might be relative to the starting directory) and the truename |
| 242 | found by `probe-file'. |
| 243 | |
| 244 | If the file wasn't found, or there was some kind of error, then an error |
| 245 | is signalled; WHAT should be a noun phrase describing the kind of thing we |
| 246 | were looking for, suitable for inclusion in the error message. |
| 247 | |
| 248 | While `find-file' establishes condition handlers for its own purposes, |
| 249 | THUNK is not invoked with any additional handlers defined." |
| 250 | |
| 251 | (handler-case |
| 252 | (dolist (dir (cons (pathname (scanner-filename scanner)) *module-dirs*) |
| 253 | (values nil nil)) |
| 254 | (let* ((path (merge-pathnames name dir)) |
| 255 | (probe (probe-file path))) |
| 256 | (when probe |
| 257 | (return (values path probe))))) |
| 258 | (file-error (error) |
| 259 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) |
| 260 | (:no-error (path probe) |
| 261 | (cond ((null path) |
| 262 | (error "Failed to find ~A ~S" what (namestring name))) |
| 263 | (t |
| 264 | (funcall thunk path probe)))))) |
| 265 | |
| 266 | ;;;----- That's all, folks -------------------------------------------------- |