chiark - git - mdw - sod/blob - src/module-impl.lisp

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