[sod] / src / module-impl.lisp

;;; -*-lisp-*-
;;;
;;; Module protocol implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Module basics.

(defmethod module-import ((module module))
  (dolist (item (module-items module))
    (module-import item)))

(defmethod add-to-module ((module module) item)
  (setf (module-items module)
        (nconc (module-items module) (list item)))
  (module-import item))

(defmethod shared-initialize :after ((module module) slot-names &key pset)
  "Tick off known properties on the property set."
  (declare (ignore slot-names))
  (dolist (prop '(:guard))
    (get-property pset prop nil)))

(defmethod finalize-module ((module module))
  (let* ((pset (module-pset module))
         (class (get-property pset :module-class :symbol 'module)))

    ;; Always call `change-class', even if it's the same one; this will
    ;; exercise the property-set fiddling in `shared-initialize' and we can
    ;; catch unknown-property errors.
    (change-class module class :state t :pset pset)
    (check-unused-properties pset)))

;;;--------------------------------------------------------------------------
;;; Module objects.

(defvar-unbound *module-map*
  "Hash table mapping true names to module objects.")
(define-clear-the-decks reset-module-map
  (setf *module-map* (make-hash-table :test #'equal)))

(defun build-module
    (name thunk &key (truename (probe-file name)) location)
  "Construct a new module.

   This is the functionality underlying `define-module': see that macro for
   full information."

  ;; Check for an import cycle.
  (when truename
    (let ((existing (gethash truename *module-map*)))
      (cond ((null existing))
            ((eq (module-state existing) t)
             (when (plusp (module-errors existing))
               (error "Module `~A' contains errors" name))
             (return-from build-module existing))
            (t
             (error "Module `~A' already being imported at ~A"
                    name (module-state existing))))))

  ;; Construct the new module.
  (let ((*module* (make-instance 'module
                                 :name (pathname name)
                                 :state (file-location location))))
    (when truename
      (setf (gethash truename *module-map*) *module*))
    (unwind-protect
         (with-module-environment ()
           (module-import *builtin-module*)
           (funcall thunk)
           (finalize-module *module*)
           *module*)
      (when (and truename (not (eq (module-state *module*) t)))
        (remhash truename *module-map*)))))

(defun call-with-module-environment (thunk &optional (module *module*))
  "Invoke THUNK with bindings for the module variables in scope.

   This is the guts of `with-module-environment', which you should probably
   use instead."
  (progv
      (mapcar #'car *module-bindings-alist*)
      (module-variables module)
    (handler-bind ((error (lambda (cond)
                            (declare (ignore cond))
                            (incf (slot-value module 'errors))
                            :decline)))
      (unwind-protect (funcall thunk)
        (setf (module-variables module)
              (mapcar (compose #'car #'symbol-value)
                      *module-bindings-alist*))))))

(defun call-with-temporary-module (thunk)
  "Invoke THUNK in the context of a temporary module, returning its values.

   This is mainly useful for testing things which depend on module variables.
   This is the functionality underlying `with-temporary-module'."
  (let ((*module* (make-instance 'module
                                 :name "<temp>"
                                 :state nil)))
    (with-module-environment ()
      (module-import *builtin-module*)
      (funcall thunk))))

;;;--------------------------------------------------------------------------
;;; Type definitions.

(export 'type-item)
(defclass type-item ()
  ((name :initarg :name :type string :reader type-name))
  (:documentation
   "A note that a module exports a type.

   We can only export simple types, so we only need to remember the name.
   The magic simple-type cache will ensure that we get the same type object
   when we do the import."))

(defmethod module-import ((item type-item))
  (let* ((name (type-name item))
         (def (gethash name *module-type-map*))
         (type (make-simple-type name)))
    (cond ((not def)
           (setf (gethash name *module-type-map*) type))
          ((not (eq def type))
           (error "Conflicting types `~A'" name)))))

(defmethod module-import ((class sod-class))
  (record-sod-class class))

;;;--------------------------------------------------------------------------
;;; Code fragments.

(defun output-c-excursion (stream location func)
  "Invoke FUNC surrounding it by writing #line markers to STREAM.

   The first marker describes LOCATION; the second refers to the actual
   output position in STREAM.  If LOCATION doesn't provide a line number then
   no markers are output after all.  If the output stream isn't
   position-aware then no final marker is output.

   FUNC is passed the output stream as an argument.  Complicated games may be
   played with interposed streams.  Try not to worry about it."

  (flet ((doit (stream)
           (let* ((location (file-location location))
                  (line (file-location-line location))
                  (filename (file-location-filename location)))
             (cond (line
                    (when (typep stream 'position-aware-stream)
                      (format stream "~&#line ~D~@[ ~S~]~%" line filename))
                    (funcall func stream)
                    (when (typep stream 'position-aware-stream)
                      (fresh-line stream)
                      (format stream "#line ~D ~S~%"
                              (1+ (position-aware-stream-line stream))
                              (let ((path (stream-pathname stream)))
                                (if path (namestring path)
                                    "<sod-output>")))))
                   (t
                    (funcall func stream))))))
    (print-ugly-stuff stream #'doit)))

(defmethod print-object ((fragment c-fragment) stream)
  (let ((text (c-fragment-text fragment))
        (location (file-location fragment)))
    (if *print-escape*
        (print-unreadable-object (fragment stream :type t)
          (when location
            (format stream "~A " location))
          (cond ((< (length text) 40)
                 (prin1 text stream) stream)
                (t
                 (prin1 (subseq text 0 37) stream)
                 (write-string "..." stream))))
        (output-c-excursion stream location
                            (lambda (stream) (write-string text stream))))))

(defmethod make-load-form ((fragment c-fragment) &optional environment)
  (make-load-form-saving-slots fragment :environment environment))

(export '(code-fragment-item code-fragment code-fragment-reason
          code-fragment-name code-fragment-constraints))
(defclass code-fragment-item ()
  ((fragment :initarg :fragment :type (or string c-fragment)
             :reader code-fragment)
   (reason :initarg :reason :type keyword :reader code-fragment-reason)
   (name :initarg :name :type t :reader code-fragment-name)
   (constraints :initarg :constraints :type list
                :reader code-fragment-constraints))
  (:documentation
   "A plain fragment of C to be dropped in at top-level."))

;;;--------------------------------------------------------------------------
;;; File searching.

(export '*module-dirs*)
(defparameter *module-dirs* nil
  "A list of directories (as pathname designators) to search for files.

   Both SOD module files and Lisp extension files are searched for in this
   list.  The search works by merging the requested pathname with each
   element of this list in turn.  The list is prefixed by the pathname of the
   requesting file, so that it can refer to other files relative to wherever
   it was found.

   See `find-file' for the grubby details.")

(export 'find-file)
(defun find-file (home name what thunk)
  "Find a file called NAME on the module search path, and call THUNK on it.

   The file is searched for relative to the HOME file or directory, and also
   in the directories mentioned in the `*module-dirs*' list.  If the file is
   found, then THUNK is invoked with two arguments: the name we used to find
   it (which might be relative to the starting directory) and the truename
   found by `probe-file'.

   If the file wasn't found, or there was some kind of error, then an error
   is signalled; WHAT should be a noun phrase describing the kind of thing we
   were looking for, suitable for inclusion in the error message.

   While `find-file' establishes condition handlers for its own purposes,
   THUNK is not invoked with any additional handlers defined."

  (handler-case
      (dolist (dir (cons home *module-dirs*) (values nil nil))
        (let* ((path (merge-pathnames name dir))
               (probe (probe-file path)))
          (when probe
            (return (values path probe)))))
    (file-error (error)
      (error "Error searching for ~A ~S: ~A" what (namestring name) error))
    (:no-error (path probe)
      (cond ((null path)
             (error "Failed to find ~A ~S" what (namestring name)))
            (t
             (funcall thunk path probe))))))

;;;----- That's all, folks --------------------------------------------------