| 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 | |
| 67 | This is the functionality underlying `define-module'." |
| 68 | |
| 69 | (let ((*module* (make-instance 'module |
| 70 | :name (pathname name) |
| 71 | :state (file-location location)))) |
| 72 | (when truename |
| 73 | (setf (gethash truename *module-map*) *module*)) |
| 74 | (unwind-protect |
| 75 | (call-with-module-environment (lambda () |
| 76 | (module-import *builtin-module*) |
| 77 | (funcall thunk) |
| 78 | (finalize-module *module*))) |
| 79 | (when (and truename (not (eq (module-state *module*) t))) |
| 80 | (remhash truename *module-map*))))) |
| 81 | |
| 82 | ;;;-------------------------------------------------------------------------- |
| 83 | ;;; Type definitions. |
| 84 | |
| 85 | (export 'type-item) |
| 86 | (defclass type-item () |
| 87 | ((name :initarg :name :type string :reader type-name)) |
| 88 | (:documentation |
| 89 | "A note that a module exports a type. |
| 90 | |
| 91 | We can only export simple types, so we only need to remember the name. |
| 92 | The magic simple-type cache will ensure that we get the same type object |
| 93 | when we do the import.")) |
| 94 | |
| 95 | (defmethod module-import ((item type-item)) |
| 96 | (let* ((name (type-name item)) |
| 97 | (def (gethash name *module-type-map*)) |
| 98 | (type (make-simple-type name))) |
| 99 | (cond ((not def) |
| 100 | (setf (gethash name *module-type-map*) type)) |
| 101 | ((not (eq def type)) |
| 102 | (error "Conflicting types `~A'" name))))) |
| 103 | |
| 104 | (defmethod module-import ((class sod-class)) |
| 105 | (record-sod-class class)) |
| 106 | |
| 107 | ;;;-------------------------------------------------------------------------- |
| 108 | ;;; Code fragments. |
| 109 | |
| 110 | (export 'c-fragment) |
| 111 | (defclass c-fragment () |
| 112 | ((location :initarg :location :type file-location |
| 113 | :accessor c-fragment-location) |
| 114 | (text :initarg :text :type string :accessor c-fragment-text)) |
| 115 | (:documentation |
| 116 | "Represents a fragment of C code to be written to an output file. |
| 117 | |
| 118 | A C fragment is aware of its original location, and will bear proper #line |
| 119 | markers when written out.")) |
| 120 | |
| 121 | (defun output-c-excursion (stream location thunk) |
| 122 | "Invoke THUNK surrounding it by writing #line markers to STREAM. |
| 123 | |
| 124 | The first marker describes LOCATION; the second refers to the actual |
| 125 | output position in STREAM. If LOCATION doesn't provide a line number then |
| 126 | no markers are output after all. If the output stream isn't |
| 127 | position-aware then no final marker is output." |
| 128 | |
| 129 | (let* ((location (file-location location)) |
| 130 | (line (file-location-line location)) |
| 131 | (filename (file-location-filename location))) |
| 132 | (cond (line |
| 133 | (format stream "~&#line ~D~@[ ~S~]~%" line filename) |
| 134 | (funcall thunk) |
| 135 | (when (typep stream 'position-aware-stream) |
| 136 | (fresh-line stream) |
| 137 | (format stream "~&#line ~D ~S~%" |
| 138 | (1+ (position-aware-stream-line stream)) |
| 139 | (namestring (stream-pathname stream))))) |
| 140 | (t |
| 141 | (funcall thunk))))) |
| 142 | |
| 143 | (defmethod print-object ((fragment c-fragment) stream) |
| 144 | (let ((text (c-fragment-text fragment)) |
| 145 | (location (c-fragment-location fragment))) |
| 146 | (if *print-escape* |
| 147 | (print-unreadable-object (fragment stream :type t) |
| 148 | (when location |
| 149 | (format stream "~A " location)) |
| 150 | (cond ((< (length text) 40) |
| 151 | (prin1 text stream) stream) |
| 152 | (t |
| 153 | (prin1 (subseq text 0 37) stream) |
| 154 | (write-string "..." stream)))) |
| 155 | (output-c-excursion stream location |
| 156 | (lambda () (write-string text stream)))))) |
| 157 | |
| 158 | (defmethod make-load-form ((fragment c-fragment) &optional environment) |
| 159 | (make-load-form-saving-slots fragment :environment environment)) |
| 160 | |
| 161 | (export 'code-fragment-item) |
| 162 | (defclass code-fragment-item () |
| 163 | ((fragment :initarg :fragment :type c-fragment :reader code-fragment) |
| 164 | (reason :initarg :reason :type keyword :reader code-fragment-reason) |
| 165 | (name :initarg :name :type t :reader code-fragment-name) |
| 166 | (constraints :initarg :constraints :type list |
| 167 | :reader code-fragment-constraints)) |
| 168 | (:documentation |
| 169 | "A plain fragment of C to be dropped in at top-level.")) |
| 170 | |
| 171 | (defmacro define-fragment ((reason name) &body things) |
| 172 | (categorize (thing things) |
| 173 | ((constraints (listp thing)) |
| 174 | (frags (typep thing '(or string c-fragment)))) |
| 175 | (when (null frags) |
| 176 | (error "Missing code fragment")) |
| 177 | (when (cdr frags) |
| 178 | (error "Multiple code fragments")) |
| 179 | `(add-to-module |
| 180 | *module* |
| 181 | (make-instance 'code-fragment-item |
| 182 | :fragment ',(car frags) |
| 183 | :name ,name |
| 184 | :reason ,reason |
| 185 | :constraints (list ,@(mapcar (lambda (constraint) |
| 186 | (cons 'list constraint)) |
| 187 | constraints)))))) |
| 188 | |
| 189 | ;;;----- That's all, folks -------------------------------------------------- |