Massive reorganization in progress.

[sod] / src / impl-module.lisp

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

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble 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 :lisp-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))

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

(defparameter *module-map* (make-hash-table :test #'equal)
  "Hash table mapping true names to module objects.")

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

   This is the functionality underlying `define-module'."

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

;;;--------------------------------------------------------------------------
;;; 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.

(export 'c-fragment)
(defclass c-fragment ()
  ((location :initarg :location :type file-location
	     :accessor c-fragment-location)
   (text :initarg :text :type string :accessor c-fragment-text))
  (:documentation
   "Represents a fragment of C code to be written to an output file.

   A C fragment is aware of its original location, and will bear proper #line
   markers when written out."))

(defun output-c-excursion (stream location thunk)
  "Invoke THUNK 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."

  (let* ((location (file-location location))
	 (line (file-location-line location))
	 (filename (file-location-filename location)))
    (cond (line
	   (format stream "~&#line ~D~@[ ~S~]~%" line filename)
	   (funcall thunk)
	   (when (typep stream 'position-aware-stream)
	     (fresh-line stream)
	     (format stream "~&#line ~D ~S~%"
		     (1+ (position-aware-stream-line stream))
		     (namestring (stream-pathname stream)))))
	  (t
	   (funcall thunk)))))

(defmethod print-object ((fragment c-fragment) stream)
  (let ((text (c-fragment-text fragment))
	(location (c-fragment-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 () (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)
(defclass code-fragment-item ()
  ((fragment :initarg :fragment :type 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."))

(defmacro define-fragment ((reason name) &body things)
  (categorize (thing things)
      ((constraints (listp thing))
       (frags (typep thing '(or string c-fragment))))
    (when (null frags)
      (error "Missing code fragment"))
    (when (cdr frags)
      (error "Multiple code fragments"))
    `(add-to-module
      *module*
      (make-instance 'code-fragment-item
		     :fragment ',(car frags)
		     :name ,name
		     :reason ,reason
		     :constraints (list ,@(mapcar (lambda (constraint)
						    (cons 'list constraint))
						  constraints))))))

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