3 ;;; Module protocol implementation
5 ;;; (c) 2009 Straylight/Edgeware
8 ;;;----- Licensing notice ---------------------------------------------------
10 ;;; This file is part of the Sensble Object Design, an object system for C.
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.
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.
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.
28 ;;;--------------------------------------------------------------------------
31 (defmethod module-import ((module module))
32 (dolist (item (module-items module))
33 (module-import item)))
35 (defmethod add-to-module ((module module) item)
36 (setf (module-items module)
37 (nconc (module-items module) (list item)))
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)))
46 (defmethod finalize-module ((module module))
47 (let* ((pset (module-pset module))
48 (class (get-property pset :module-class :symbol 'module)))
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)
57 ;;;--------------------------------------------------------------------------
60 (defparameter *module-map* (make-hash-table :test #'equal)
61 "Hash table mapping true names to module objects.")
64 (name thunk &key (truename (probe-file name)) location)
65 "Construct a new module.
67 This is the functionality underlying `define-module': see that macro for
70 ;; Check for an import cycle.
72 (let ((existing (gethash truename *module-map*)))
73 (cond ((null existing))
74 ((eq (module-state existing) t)
75 (return-from build-module existing))
77 (error "Module ~A already being imported at ~A"
78 name (module-state existing))))))
80 ;; Construct the new module.
81 (let ((*module* (make-instance 'module
83 :state (file-location location))))
85 (setf (gethash truename *module-map*) *module*))
87 (with-module-environment ()
88 (module-import *builtin-module*)
90 (finalize-module *module*))
91 (when (and truename (not (eq (module-state *module*) t)))
92 (remhash truename *module-map*)))))
94 (defun call-with-module-environment (thunk &optional (module *module*))
95 "Invoke THUNK with bindings for the module variables in scope.
97 This is the guts of `with-module-environment', which you should probably
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*)))))
107 (defun call-with-temporary-module (thunk)
108 "Invoke THUNK in the context of a temporary module, returning its values.
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
115 (with-module-environment ()
116 (module-import *builtin-module*)
119 ;;;--------------------------------------------------------------------------
120 ;;; Type definitions.
123 (defclass type-item ()
124 ((name :initarg :name :type string :reader type-name))
126 "A note that a module exports a type.
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."))
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)))
137 (setf (gethash name *module-type-map*) type))
139 (error "Conflicting types `~A'" name)))))
141 (defmethod module-import ((class sod-class))
142 (record-sod-class class))
144 ;;;--------------------------------------------------------------------------
148 (defclass c-fragment ()
149 ((location :initarg :location :type file-location
150 :accessor c-fragment-location)
151 (text :initarg :text :type string :accessor c-fragment-text))
153 "Represents a fragment of C code to be written to an output file.
155 A C fragment is aware of its original location, and will bear proper #line
156 markers when written out."))
158 (defun output-c-excursion (stream location thunk)
159 "Invoke THUNK surrounding it by writing #line markers to STREAM.
161 The first marker describes LOCATION; the second refers to the actual
162 output position in STREAM. If LOCATION doesn't provide a line number then
163 no markers are output after all. If the output stream isn't
164 position-aware then no final marker is output."
166 (let* ((location (file-location location))
167 (line (file-location-line location))
168 (filename (file-location-filename location)))
170 (when (typep stream 'position-aware-stream)
171 (format stream "~&#line ~D~@[ ~S~]~%" line filename))
173 (when (typep stream 'position-aware-stream)
175 (format stream "~&#line ~D ~S~%"
176 (1+ (position-aware-stream-line stream))
177 (let ((path (stream-pathname stream)))
178 (if path (namestring path) "<sod-output>")))))
182 (defmethod print-object ((fragment c-fragment) stream)
183 (let ((text (c-fragment-text fragment))
184 (location (c-fragment-location fragment)))
186 (print-unreadable-object (fragment stream :type t)
188 (format stream "~A " location))
189 (cond ((< (length text) 40)
190 (prin1 text stream) stream)
192 (prin1 (subseq text 0 37) stream)
193 (write-string "..." stream))))
194 (output-c-excursion stream location
195 (lambda () (write-string text stream))))))
197 (defmethod make-load-form ((fragment c-fragment) &optional environment)
198 (make-load-form-saving-slots fragment :environment environment))
200 (export 'code-fragment-item)
201 (defclass code-fragment-item ()
202 ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
203 (reason :initarg :reason :type keyword :reader code-fragment-reason)
204 (name :initarg :name :type t :reader code-fragment-name)
205 (constraints :initarg :constraints :type list
206 :reader code-fragment-constraints))
208 "A plain fragment of C to be dropped in at top-level."))
210 (defmacro define-fragment ((reason name) &body things)
211 (categorize (thing things)
212 ((constraints (listp thing))
213 (frags (typep thing '(or string c-fragment))))
215 (error "Missing code fragment"))
217 (error "Multiple code fragments"))
220 (make-instance 'code-fragment-item
221 :fragment ',(car frags)
224 :constraints (list ,@(mapcar (lambda (constraint)
225 (cons 'list constraint))
228 ;;;--------------------------------------------------------------------------
231 (export '*module-dirs*)
232 (defparameter *module-dirs* nil
233 "A list of directories (as pathname designators) to search for files.
235 Both SOD module files and Lisp extension files are searched for in this
236 list. The search works by merging the requested pathname with each
237 element of this list in turn. The list is prefixed by the pathname of the
238 requesting file, so that it can refer to other files relative to wherever
241 See `find-file' for the grubby details.")
244 (defun find-file (scanner name what thunk)
245 "Find a file called NAME on the module search path, and call THUNK on it.
247 The file is searched for relative to the SCANNER's current file, and also
248 in the directories mentioned in the `*module-dirs*' list. If the file is
249 found, then THUNK is invoked with two arguments: the name we used to find
250 it (which might be relative to the starting directory) and the truename
251 found by `probe-file'.
253 If the file wasn't found, or there was some kind of error, then an error
254 is signalled; WHAT should be a noun phrase describing the kind of thing we
255 were looking for, suitable for inclusion in the error message.
257 While `find-file' establishes condition handlers for its own purposes,
258 THUNK is not invoked with any additional handlers defined."
261 (dolist (dir (cons (pathname (scanner-filename scanner)) *module-dirs*)
263 (let* ((path (merge-pathnames name dir))
264 (probe (probe-file path)))
266 (return (values path probe)))))
268 (error "Error searching for ~A ~S: ~A" what (namestring name) error))
269 (:no-error (path probe)
271 (error "Failed to find ~A ~S" what (namestring name)))
273 (funcall thunk path probe))))))
275 ;;;----- That's all, folks --------------------------------------------------