--- /dev/null
+;;; -*-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': 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)
+ (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
+ (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))))))
+
+;;;--------------------------------------------------------------------------
+;;; 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 (scanner 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 SCANNER's current file, 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 (pathname (scanner-filename scanner)) *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 --------------------------------------------------
~mdw / sod / blobdiff