Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Module protocol implementation | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
e0808c47 | 10 | ;;; This file is part of the Sensible Object Design, an object system for C. |
dea4d055 MW |
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 | ||
a351d620 MW |
28 | ;; Establish a standard environment within the body of a module. This is an |
29 | ;; attempt -- but not a wholly successful one -- to present the same | |
30 | ;; environment to a module independent of the context in which we imported | |
31 | ;; it. | |
32 | ||
33 | ;;;-------------------------------------------------------------------------- | |
34 | ;;; Module variables. | |
35 | ||
36 | (eval-when (:load-toplevel :execute) | |
37 | (macrolet ((fix (var &optional (value var)) | |
38 | (once-only (value) | |
39 | `(add-module-binding ',var (lambda () ,value))))) | |
40 | ||
41 | ;; Use `sod-user' package by default. This seems the most useful. Alas, | |
42 | ;; some tenants might not keep it as tidy as we'd like, but there are | |
43 | ;; probably useful ways to side-effect the package too. | |
44 | (fix *package* (find-package "SOD-USER")) | |
45 | ||
46 | ;; Stream bindings. Hope that the values we find at load time are | |
47 | ;; sufficiently sensible. | |
48 | (fix *debug-io*) | |
49 | (fix *error-output*) | |
50 | (fix *query-io*) | |
51 | (fix *standard-input*) | |
52 | (fix *standard-output*) | |
53 | (fix *terminal-io*) | |
54 | (fix *trace-output*) | |
55 | ||
56 | ;; Print state. | |
57 | (fix *print-array* t) | |
58 | (fix *print-base* 10) | |
59 | (fix *print-case* :upcase) | |
60 | (fix *print-circle* nil) | |
61 | (fix *print-escape* t) | |
62 | (fix *print-gensym* t) | |
63 | (fix *print-length* nil) | |
64 | (fix *print-level* nil) | |
65 | (fix *print-lines* nil) | |
66 | (fix *print-miser-width*) | |
67 | (fix *print-pretty* t) | |
68 | (fix *print-radix* nil) | |
69 | (fix *print-readably* nil) | |
70 | (fix *print-right-margin*) | |
71 | ||
72 | ;; Read state. | |
73 | (fix *read-base* 10) | |
74 | (fix *read-eval* t) | |
75 | (fix *read-suppress* nil) | |
76 | (fix *readtable* (copy-readtable nil)))) | |
77 | ||
dea4d055 MW |
78 | ;;;-------------------------------------------------------------------------- |
79 | ;;; Module basics. | |
80 | ||
81 | (defmethod module-import ((module module)) | |
82 | (dolist (item (module-items module)) | |
83 | (module-import item))) | |
84 | ||
85 | (defmethod add-to-module ((module module) item) | |
86 | (setf (module-items module) | |
87 | (nconc (module-items module) (list item))) | |
88 | (module-import item)) | |
89 | ||
90 | (defmethod shared-initialize :after ((module module) slot-names &key pset) | |
91 | "Tick off known properties on the property set." | |
92 | (declare (ignore slot-names)) | |
93 | (dolist (prop '(:guard)) | |
94 | (get-property pset prop nil))) | |
95 | ||
96 | (defmethod finalize-module ((module module)) | |
97 | (let* ((pset (module-pset module)) | |
52a79ab8 | 98 | (class (get-property pset :module-class :symbol 'module))) |
dea4d055 MW |
99 | |
100 | ;; Always call `change-class', even if it's the same one; this will | |
101 | ;; exercise the property-set fiddling in `shared-initialize' and we can | |
102 | ;; catch unknown-property errors. | |
103 | (change-class module class :state t :pset pset) | |
8ce92a8f | 104 | (check-unused-properties pset))) |
dea4d055 MW |
105 | |
106 | ;;;-------------------------------------------------------------------------- | |
107 | ;;; Module objects. | |
108 | ||
e7d43325 | 109 | (defvar-unbound *module-map* |
dea4d055 | 110 | "Hash table mapping true names to module objects.") |
e7d43325 MW |
111 | (define-clear-the-decks reset-module-map |
112 | (setf *module-map* (make-hash-table :test #'equal))) | |
dea4d055 MW |
113 | |
114 | (defun build-module | |
115 | (name thunk &key (truename (probe-file name)) location) | |
116 | "Construct a new module. | |
117 | ||
bf090e02 MW |
118 | This is the functionality underlying `define-module': see that macro for |
119 | full information." | |
120 | ||
121 | ;; Check for an import cycle. | |
122 | (when truename | |
123 | (let ((existing (gethash truename *module-map*))) | |
124 | (cond ((null existing)) | |
125 | ((eq (module-state existing) t) | |
287e744e MW |
126 | (when (plusp (module-errors existing)) |
127 | (error "Module `~A' contains errors" name)) | |
bf090e02 MW |
128 | (return-from build-module existing)) |
129 | (t | |
287e744e | 130 | (error "Module `~A' already being imported at ~A" |
bf090e02 MW |
131 | name (module-state existing)))))) |
132 | ||
133 | ;; Construct the new module. | |
dea4d055 MW |
134 | (let ((*module* (make-instance 'module |
135 | :name (pathname name) | |
136 | :state (file-location location)))) | |
137 | (when truename | |
138 | (setf (gethash truename *module-map*) *module*)) | |
139 | (unwind-protect | |
9ec578d9 MW |
140 | (with-module-environment () |
141 | (module-import *builtin-module*) | |
142 | (funcall thunk) | |
8ce92a8f MW |
143 | (finalize-module *module*) |
144 | *module*) | |
dea4d055 MW |
145 | (when (and truename (not (eq (module-state *module*) t))) |
146 | (remhash truename *module-map*))))) | |
147 | ||
9ec578d9 MW |
148 | (defun call-with-module-environment (thunk &optional (module *module*)) |
149 | "Invoke THUNK with bindings for the module variables in scope. | |
150 | ||
151 | This is the guts of `with-module-environment', which you should probably | |
152 | use instead." | |
153 | (progv | |
154 | (mapcar #'car *module-bindings-alist*) | |
155 | (module-variables module) | |
287e744e MW |
156 | (handler-bind ((error (lambda (cond) |
157 | (declare (ignore cond)) | |
158 | (incf (slot-value module 'errors)) | |
159 | :decline))) | |
160 | (unwind-protect (funcall thunk) | |
161 | (setf (module-variables module) | |
162 | (mapcar (compose #'car #'symbol-value) | |
163 | *module-bindings-alist*)))))) | |
9ec578d9 | 164 | |
239fa5bd MW |
165 | (defun call-with-temporary-module (thunk) |
166 | "Invoke THUNK in the context of a temporary module, returning its values. | |
167 | ||
168 | This is mainly useful for testing things which depend on module variables. | |
169 | This is the functionality underlying `with-temporary-module'." | |
170 | (let ((*module* (make-instance 'module | |
171 | :name "<temp>" | |
172 | :state nil))) | |
9ec578d9 MW |
173 | (with-module-environment () |
174 | (module-import *builtin-module*) | |
175 | (funcall thunk)))) | |
239fa5bd | 176 | |
dea4d055 MW |
177 | ;;;-------------------------------------------------------------------------- |
178 | ;;; Type definitions. | |
179 | ||
180 | (export 'type-item) | |
181 | (defclass type-item () | |
182 | ((name :initarg :name :type string :reader type-name)) | |
183 | (:documentation | |
184 | "A note that a module exports a type. | |
185 | ||
186 | We can only export simple types, so we only need to remember the name. | |
187 | The magic simple-type cache will ensure that we get the same type object | |
188 | when we do the import.")) | |
189 | ||
190 | (defmethod module-import ((item type-item)) | |
191 | (let* ((name (type-name item)) | |
192 | (def (gethash name *module-type-map*)) | |
193 | (type (make-simple-type name))) | |
194 | (cond ((not def) | |
195 | (setf (gethash name *module-type-map*) type)) | |
196 | ((not (eq def type)) | |
197 | (error "Conflicting types `~A'" name))))) | |
198 | ||
199 | (defmethod module-import ((class sod-class)) | |
200 | (record-sod-class class)) | |
201 | ||
202 | ;;;-------------------------------------------------------------------------- | |
203 | ;;; Code fragments. | |
204 | ||
08b6e064 MW |
205 | (defun output-c-excursion (stream location func) |
206 | "Invoke FUNC surrounding it by writing #line markers to STREAM. | |
dea4d055 MW |
207 | |
208 | The first marker describes LOCATION; the second refers to the actual | |
209 | output position in STREAM. If LOCATION doesn't provide a line number then | |
210 | no markers are output after all. If the output stream isn't | |
08b6e064 MW |
211 | position-aware then no final marker is output. |
212 | ||
213 | FUNC is passed the output stream as an argument. Complicated games may be | |
214 | played with interposed streams. Try not to worry about it." | |
215 | ||
216 | (flet ((doit (stream) | |
217 | (let* ((location (file-location location)) | |
218 | (line (file-location-line location)) | |
219 | (filename (file-location-filename location))) | |
220 | (cond (line | |
221 | (when (typep stream 'position-aware-stream) | |
222 | (format stream "~&#line ~D~@[ ~S~]~%" line filename)) | |
223 | (funcall func stream) | |
224 | (when (typep stream 'position-aware-stream) | |
225 | (fresh-line stream) | |
226 | (format stream "#line ~D ~S~%" | |
227 | (1+ (position-aware-stream-line stream)) | |
228 | (let ((path (stream-pathname stream))) | |
229 | (if path (namestring path) | |
230 | "<sod-output>"))))) | |
231 | (t | |
232 | (funcall func stream)))))) | |
233 | (print-ugly-stuff stream #'doit))) | |
dea4d055 MW |
234 | |
235 | (defmethod print-object ((fragment c-fragment) stream) | |
236 | (let ((text (c-fragment-text fragment)) | |
88b38efd | 237 | (location (file-location fragment))) |
dea4d055 MW |
238 | (if *print-escape* |
239 | (print-unreadable-object (fragment stream :type t) | |
240 | (when location | |
241 | (format stream "~A " location)) | |
242 | (cond ((< (length text) 40) | |
243 | (prin1 text stream) stream) | |
244 | (t | |
245 | (prin1 (subseq text 0 37) stream) | |
246 | (write-string "..." stream)))) | |
247 | (output-c-excursion stream location | |
a61f73b9 MW |
248 | (lambda (stream) |
249 | (awhen (file-location-column location) | |
250 | (dotimes (i it) (write-char #\space stream))) | |
251 | (write-string text stream)))))) | |
dea4d055 MW |
252 | |
253 | (defmethod make-load-form ((fragment c-fragment) &optional environment) | |
254 | (make-load-form-saving-slots fragment :environment environment)) | |
255 | ||
7f2917d2 MW |
256 | (export '(code-fragment-item code-fragment code-fragment-reason |
257 | code-fragment-name code-fragment-constraints)) | |
dea4d055 | 258 | (defclass code-fragment-item () |
1645e433 MW |
259 | ((fragment :initarg :fragment :type (or string c-fragment) |
260 | :reader code-fragment) | |
dea4d055 MW |
261 | (reason :initarg :reason :type keyword :reader code-fragment-reason) |
262 | (name :initarg :name :type t :reader code-fragment-name) | |
263 | (constraints :initarg :constraints :type list | |
264 | :reader code-fragment-constraints)) | |
265 | (:documentation | |
266 | "A plain fragment of C to be dropped in at top-level.")) | |
267 | ||
bf090e02 MW |
268 | ;;;-------------------------------------------------------------------------- |
269 | ;;; File searching. | |
270 | ||
271 | (export '*module-dirs*) | |
272 | (defparameter *module-dirs* nil | |
273 | "A list of directories (as pathname designators) to search for files. | |
274 | ||
275 | Both SOD module files and Lisp extension files are searched for in this | |
276 | list. The search works by merging the requested pathname with each | |
277 | element of this list in turn. The list is prefixed by the pathname of the | |
278 | requesting file, so that it can refer to other files relative to wherever | |
279 | it was found. | |
280 | ||
281 | See `find-file' for the grubby details.") | |
282 | ||
283 | (export 'find-file) | |
fbd5be64 | 284 | (defun find-file (home name what thunk) |
bf090e02 MW |
285 | "Find a file called NAME on the module search path, and call THUNK on it. |
286 | ||
fbd5be64 | 287 | The file is searched for relative to the HOME file or directory, and also |
bf090e02 MW |
288 | in the directories mentioned in the `*module-dirs*' list. If the file is |
289 | found, then THUNK is invoked with two arguments: the name we used to find | |
290 | it (which might be relative to the starting directory) and the truename | |
291 | found by `probe-file'. | |
292 | ||
293 | If the file wasn't found, or there was some kind of error, then an error | |
294 | is signalled; WHAT should be a noun phrase describing the kind of thing we | |
295 | were looking for, suitable for inclusion in the error message. | |
296 | ||
297 | While `find-file' establishes condition handlers for its own purposes, | |
298 | THUNK is not invoked with any additional handlers defined." | |
299 | ||
300 | (handler-case | |
fbd5be64 | 301 | (dolist (dir (cons home *module-dirs*) (values nil nil)) |
bf090e02 MW |
302 | (let* ((path (merge-pathnames name dir)) |
303 | (probe (probe-file path))) | |
304 | (when probe | |
305 | (return (values path probe))))) | |
306 | (file-error (error) | |
307 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) | |
308 | (:no-error (path probe) | |
309 | (cond ((null path) | |
310 | (error "Failed to find ~A ~S" what (namestring name))) | |
311 | (t | |
312 | (funcall thunk path probe)))))) | |
313 | ||
dea4d055 | 314 | ;;;----- That's all, folks -------------------------------------------------- |