Commit | Line | Data |
---|---|---|
dea4d055 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Module protocol implementation | |
4 | ;;; | |
5 | ;;; (c) 2009 Straylight/Edgeware | |
6 | ;;; | |
7 | ||
8 | ;;;----- Licensing notice --------------------------------------------------- | |
9 | ;;; | |
10 | ;;; This file is part of the Sensble Object Design, an object system for C. | |
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 | ||
28 | ;;;-------------------------------------------------------------------------- | |
29 | ;;; Module basics. | |
30 | ||
31 | (defmethod module-import ((module module)) | |
32 | (dolist (item (module-items module)) | |
33 | (module-import item))) | |
34 | ||
35 | (defmethod add-to-module ((module module) item) | |
36 | (setf (module-items module) | |
37 | (nconc (module-items module) (list item))) | |
38 | (module-import item)) | |
39 | ||
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))) | |
45 | ||
46 | (defmethod finalize-module ((module module)) | |
47 | (let* ((pset (module-pset module)) | |
48 | (class (get-property pset :lisp-class :symbol 'module))) | |
49 | ||
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) | |
55 | module)) | |
56 | ||
57 | ;;;-------------------------------------------------------------------------- | |
58 | ;;; Module objects. | |
59 | ||
60 | (defparameter *module-map* (make-hash-table :test #'equal) | |
61 | "Hash table mapping true names to module objects.") | |
62 | ||
63 | (defun build-module | |
64 | (name thunk &key (truename (probe-file name)) location) | |
65 | "Construct a new module. | |
66 | ||
bf090e02 MW |
67 | This is the functionality underlying `define-module': see that macro for |
68 | full information." | |
69 | ||
70 | ;; Check for an import cycle. | |
71 | (when truename | |
72 | (let ((existing (gethash truename *module-map*))) | |
73 | (cond ((null existing)) | |
74 | ((eq (module-state existing) t) | |
75 | (return-from build-module existing)) | |
76 | (t | |
77 | (error "Module ~A already being imported at ~A" | |
78 | name (module-state existing)))))) | |
79 | ||
80 | ;; Construct the new module. | |
dea4d055 MW |
81 | (let ((*module* (make-instance 'module |
82 | :name (pathname name) | |
83 | :state (file-location location)))) | |
84 | (when truename | |
85 | (setf (gethash truename *module-map*) *module*)) | |
86 | (unwind-protect | |
87 | (call-with-module-environment (lambda () | |
88 | (module-import *builtin-module*) | |
89 | (funcall thunk) | |
90 | (finalize-module *module*))) | |
91 | (when (and truename (not (eq (module-state *module*) t))) | |
92 | (remhash truename *module-map*))))) | |
93 | ||
94 | ;;;-------------------------------------------------------------------------- | |
95 | ;;; Type definitions. | |
96 | ||
97 | (export 'type-item) | |
98 | (defclass type-item () | |
99 | ((name :initarg :name :type string :reader type-name)) | |
100 | (:documentation | |
101 | "A note that a module exports a type. | |
102 | ||
103 | We can only export simple types, so we only need to remember the name. | |
104 | The magic simple-type cache will ensure that we get the same type object | |
105 | when we do the import.")) | |
106 | ||
107 | (defmethod module-import ((item type-item)) | |
108 | (let* ((name (type-name item)) | |
109 | (def (gethash name *module-type-map*)) | |
110 | (type (make-simple-type name))) | |
111 | (cond ((not def) | |
112 | (setf (gethash name *module-type-map*) type)) | |
113 | ((not (eq def type)) | |
114 | (error "Conflicting types `~A'" name))))) | |
115 | ||
116 | (defmethod module-import ((class sod-class)) | |
117 | (record-sod-class class)) | |
118 | ||
119 | ;;;-------------------------------------------------------------------------- | |
120 | ;;; Code fragments. | |
121 | ||
122 | (export 'c-fragment) | |
123 | (defclass c-fragment () | |
124 | ((location :initarg :location :type file-location | |
125 | :accessor c-fragment-location) | |
126 | (text :initarg :text :type string :accessor c-fragment-text)) | |
127 | (:documentation | |
128 | "Represents a fragment of C code to be written to an output file. | |
129 | ||
130 | A C fragment is aware of its original location, and will bear proper #line | |
131 | markers when written out.")) | |
132 | ||
133 | (defun output-c-excursion (stream location thunk) | |
134 | "Invoke THUNK surrounding it by writing #line markers to STREAM. | |
135 | ||
136 | The first marker describes LOCATION; the second refers to the actual | |
137 | output position in STREAM. If LOCATION doesn't provide a line number then | |
138 | no markers are output after all. If the output stream isn't | |
139 | position-aware then no final marker is output." | |
140 | ||
141 | (let* ((location (file-location location)) | |
142 | (line (file-location-line location)) | |
143 | (filename (file-location-filename location))) | |
144 | (cond (line | |
145 | (format stream "~&#line ~D~@[ ~S~]~%" line filename) | |
146 | (funcall thunk) | |
147 | (when (typep stream 'position-aware-stream) | |
148 | (fresh-line stream) | |
149 | (format stream "~&#line ~D ~S~%" | |
150 | (1+ (position-aware-stream-line stream)) | |
151 | (namestring (stream-pathname stream))))) | |
152 | (t | |
153 | (funcall thunk))))) | |
154 | ||
155 | (defmethod print-object ((fragment c-fragment) stream) | |
156 | (let ((text (c-fragment-text fragment)) | |
157 | (location (c-fragment-location fragment))) | |
158 | (if *print-escape* | |
159 | (print-unreadable-object (fragment stream :type t) | |
160 | (when location | |
161 | (format stream "~A " location)) | |
162 | (cond ((< (length text) 40) | |
163 | (prin1 text stream) stream) | |
164 | (t | |
165 | (prin1 (subseq text 0 37) stream) | |
166 | (write-string "..." stream)))) | |
167 | (output-c-excursion stream location | |
168 | (lambda () (write-string text stream)))))) | |
169 | ||
170 | (defmethod make-load-form ((fragment c-fragment) &optional environment) | |
171 | (make-load-form-saving-slots fragment :environment environment)) | |
172 | ||
173 | (export 'code-fragment-item) | |
174 | (defclass code-fragment-item () | |
175 | ((fragment :initarg :fragment :type c-fragment :reader code-fragment) | |
176 | (reason :initarg :reason :type keyword :reader code-fragment-reason) | |
177 | (name :initarg :name :type t :reader code-fragment-name) | |
178 | (constraints :initarg :constraints :type list | |
179 | :reader code-fragment-constraints)) | |
180 | (:documentation | |
181 | "A plain fragment of C to be dropped in at top-level.")) | |
182 | ||
183 | (defmacro define-fragment ((reason name) &body things) | |
184 | (categorize (thing things) | |
185 | ((constraints (listp thing)) | |
186 | (frags (typep thing '(or string c-fragment)))) | |
187 | (when (null frags) | |
188 | (error "Missing code fragment")) | |
189 | (when (cdr frags) | |
190 | (error "Multiple code fragments")) | |
191 | `(add-to-module | |
192 | *module* | |
193 | (make-instance 'code-fragment-item | |
194 | :fragment ',(car frags) | |
195 | :name ,name | |
196 | :reason ,reason | |
197 | :constraints (list ,@(mapcar (lambda (constraint) | |
198 | (cons 'list constraint)) | |
199 | constraints)))))) | |
200 | ||
bf090e02 MW |
201 | ;;;-------------------------------------------------------------------------- |
202 | ;;; File searching. | |
203 | ||
204 | (export '*module-dirs*) | |
205 | (defparameter *module-dirs* nil | |
206 | "A list of directories (as pathname designators) to search for files. | |
207 | ||
208 | Both SOD module files and Lisp extension files are searched for in this | |
209 | list. The search works by merging the requested pathname with each | |
210 | element of this list in turn. The list is prefixed by the pathname of the | |
211 | requesting file, so that it can refer to other files relative to wherever | |
212 | it was found. | |
213 | ||
214 | See `find-file' for the grubby details.") | |
215 | ||
216 | (export 'find-file) | |
217 | (defun find-file (scanner name what thunk) | |
218 | "Find a file called NAME on the module search path, and call THUNK on it. | |
219 | ||
220 | The file is searched for relative to the SCANNER's current file, and also | |
221 | in the directories mentioned in the `*module-dirs*' list. If the file is | |
222 | found, then THUNK is invoked with two arguments: the name we used to find | |
223 | it (which might be relative to the starting directory) and the truename | |
224 | found by `probe-file'. | |
225 | ||
226 | If the file wasn't found, or there was some kind of error, then an error | |
227 | is signalled; WHAT should be a noun phrase describing the kind of thing we | |
228 | were looking for, suitable for inclusion in the error message. | |
229 | ||
230 | While `find-file' establishes condition handlers for its own purposes, | |
231 | THUNK is not invoked with any additional handlers defined." | |
232 | ||
233 | (handler-case | |
234 | (dolist (dir (cons (pathname (scanner-filename scanner)) *module-dirs*) | |
235 | (values nil nil)) | |
236 | (let* ((path (merge-pathnames name dir)) | |
237 | (probe (probe-file path))) | |
238 | (when probe | |
239 | (return (values path probe))))) | |
240 | (file-error (error) | |
241 | (error "Error searching for ~A ~S: ~A" what (namestring name) error)) | |
242 | (:no-error (path probe) | |
243 | (cond ((null path) | |
244 | (error "Failed to find ~A ~S" what (namestring name))) | |
245 | (t | |
246 | (funcall thunk path probe)))))) | |
247 | ||
dea4d055 | 248 | ;;;----- That's all, folks -------------------------------------------------- |