| 1 | ;;; -*-lisp-*- |
| 2 | ;;; |
| 3 | ;;; Output functions for classes |
| 4 | ;;; |
| 5 | ;;; (c) 2009 Straylight/Edgeware |
| 6 | ;;; |
| 7 | |
| 8 | ;;;----- Licensing notice --------------------------------------------------- |
| 9 | ;;; |
| 10 | ;;; This file is part of the Simple Object Definition system. |
| 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 | ;;; Utility macro. |
| 30 | |
| 31 | (defmacro sequence-output |
| 32 | ((streamvar sequencer) &body clauses) |
| 33 | (let ((seqvar (gensym "SEQ"))) |
| 34 | (labels ((convert-item-name (name) |
| 35 | (if (listp name) |
| 36 | (cons 'list name) |
| 37 | name)) |
| 38 | (convert-constraint (constraint) |
| 39 | (cons 'list (mapcar #'convert-item-name constraint))) |
| 40 | (process-body (clauses) |
| 41 | (if (eq (car clauses) :constraint) |
| 42 | (cons `(add-sequencer-constraint |
| 43 | ,seqvar |
| 44 | ,(convert-constraint (cadr clauses))) |
| 45 | (process-body (cddr clauses))) |
| 46 | (mapcar (lambda (clause) |
| 47 | (let ((name (car clause)) |
| 48 | (body (cdr clause))) |
| 49 | `(add-sequencer-item-function |
| 50 | ,seqvar |
| 51 | ,(convert-item-name name) |
| 52 | (lambda (,streamvar) |
| 53 | ,@body)))) |
| 54 | clauses)))) |
| 55 | `(let ((,seqvar ,sequencer)) |
| 56 | ,@(process-body clauses))))) |
| 57 | |
| 58 | ;;;-------------------------------------------------------------------------- |
| 59 | ;;; Classes. |
| 60 | |
| 61 | (defmethod add-output-hooks progn |
| 62 | ((class sod-class) (reason (eql :h)) sequencer) |
| 63 | |
| 64 | ;; Main output sequencing. |
| 65 | (sequence-output (stream sequencer) |
| 66 | |
| 67 | :constraint |
| 68 | (:typedefs) |
| 69 | |
| 70 | :constraint |
| 71 | ((:classes :start) |
| 72 | (class :banner) |
| 73 | (class :islots :start) (class :islots :slots) (class :islots :end) |
| 74 | (class :vtmsgs :start) (class :vtmsgs :end) |
| 75 | (class :vtables :start) (class :vtables :end) |
| 76 | (class :vtable-externs) (class :vtable-externs-after) |
| 77 | (class :direct-methods) |
| 78 | (class :ichains :start) (class :ichains :end) |
| 79 | (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end) |
| 80 | (class :conversions) |
| 81 | (:classes :end)) |
| 82 | |
| 83 | (:typedefs |
| 84 | (format stream "typedef struct ~A ~A;~%" |
| 85 | (ichain-struct-tag class (sod-class-chain-head class)) class)) |
| 86 | |
| 87 | ((class :banner) |
| 88 | (banner (format nil "Class ~A" class) stream)) |
| 89 | ((class :vtable-externs-after) |
| 90 | (terpri stream))) |
| 91 | |
| 92 | ;; Maybe generate an islots structure. |
| 93 | (when (sod-class-slots class) |
| 94 | (dolist (slot (sod-class-slots class)) |
| 95 | (add-output-hooks slot 'populate-islots sequencer)) |
| 96 | (sequence-output (stream sequencer) |
| 97 | ((class :islots :start) |
| 98 | (format stream "struct ~A {~%" (islots-struct-tag class))) |
| 99 | ((class :islots :end) |
| 100 | (format stream "};~2%")))) |
| 101 | |
| 102 | ;; Declare the direct methods. |
| 103 | (when (sod-class-methods class) |
| 104 | (dolist (method (sod-class-methods class)) |
| 105 | (add-output-hooks method :declare-direct-methods sequencer)) |
| 106 | (sequence-output (stream sequencer) |
| 107 | ((class :direct-methods) |
| 108 | (terpri stream)))) |
| 109 | |
| 110 | ;; Provide upcast macros which do the right thing. |
| 111 | (when (sod-class-direct-superclasses class) |
| 112 | (sequence-output (stream sequencer) |
| 113 | ((class :conversions) |
| 114 | (let ((chain-head (sod-class-chain-head class))) |
| 115 | (dolist (super (cdr (sod-class-precedence-list class))) |
| 116 | (let ((super-head (sod-class-chain-head super))) |
| 117 | (format stream (concatenate 'string "#define " |
| 118 | "~:@(~A__CONV_~A~)(p) ((~A *)" |
| 119 | "~:[SOD_XCHAIN(~A, p)~;p~])~%") |
| 120 | class (sod-class-nickname super) super |
| 121 | (eq chain-head super-head) |
| 122 | (sod-class-nickname super-head)))))))) |
| 123 | |
| 124 | ;; Generate vtmsgs structure for all superclasses. |
| 125 | (add-output-hooks (car (sod-class-vtables class)) |
| 126 | 'populate-vtmsgs |
| 127 | sequencer)) |
| 128 | |
| 129 | (defmethod add-output-hooks progn ((class sod-class) reason sequencer) |
| 130 | (with-slots (ilayout vtables) class |
| 131 | (add-output-hooks ilayout reason sequencer) |
| 132 | (dolist (vtable vtables) (add-output-hooks vtable reason sequencer)))) |
| 133 | |
| 134 | ;;;-------------------------------------------------------------------------- |
| 135 | ;;; Instance structure. |
| 136 | |
| 137 | (defmethod add-output-hooks progn |
| 138 | ((slot sod-slot) (reason (eql 'populate-islots)) sequencer) |
| 139 | (sequence-output (stream sequencer) |
| 140 | (((sod-slot-class slot) :islots :slots) |
| 141 | (pprint-logical-block (stream nil :prefix " " :suffix ";") |
| 142 | (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot))) |
| 143 | (terpri stream)))) |
| 144 | |
| 145 | (defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer) |
| 146 | (with-slots (ichains) ilayout |
| 147 | (dolist (ichain ichains) (add-output-hooks ichain reason sequencer)))) |
| 148 | |
| 149 | (defmethod add-output-hooks progn |
| 150 | ((ilayout ilayout) (reason (eql :h)) sequencer) |
| 151 | (with-slots (class ichains) ilayout |
| 152 | (sequence-output (stream sequencer) |
| 153 | ((class :ilayout :start) |
| 154 | (format stream "struct ~A {~%" (ilayout-struct-tag class))) |
| 155 | ((class :ilayout :end) |
| 156 | (format stream "};~2%"))) |
| 157 | (dolist (ichain ichains) |
| 158 | (add-output-hooks ichain 'populate-ilayout sequencer)))) |
| 159 | |
| 160 | (defmethod add-output-hooks progn |
| 161 | ((ichain ichain) (reason (eql :h)) sequencer) |
| 162 | (with-slots (class chain-head) ichain |
| 163 | (sequence-output (stream sequencer) |
| 164 | :constraint ((class :ichains :start) |
| 165 | (class :ichain chain-head :start) |
| 166 | (class :ichain chain-head :slots) |
| 167 | (class :ichain chain-head :end) |
| 168 | (class :ichains :end)) |
| 169 | ((class :ichain chain-head :start) |
| 170 | (format stream "struct ~A {~%" (ichain-struct-tag class chain-head))) |
| 171 | ((class :ichain chain-head :end) |
| 172 | (format stream "};~2%"))))) |
| 173 | |
| 174 | (defmethod add-output-hooks progn |
| 175 | ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer) |
| 176 | (with-slots (class chain-head) ichain |
| 177 | (sequence-output (stream sequencer) |
| 178 | ((class :ilayout :slots) |
| 179 | (format stream " struct ~A ~A;~%" |
| 180 | (ichain-struct-tag class chain-head) |
| 181 | (sod-class-nickname chain-head)))))) |
| 182 | |
| 183 | (defmethod add-output-hooks progn ((ichain ichain) reason sequencer) |
| 184 | (with-slots (body) ichain |
| 185 | (dolist (item body) (add-output-hooks item reason sequencer)))) |
| 186 | |
| 187 | (defmethod add-output-hooks progn |
| 188 | ((vtptr vtable-pointer) (reason (eql :h)) sequencer) |
| 189 | (with-slots (class chain-head) vtptr |
| 190 | (sequence-output (stream sequencer) |
| 191 | ((class :ichain chain-head :slots) |
| 192 | (format stream " const struct ~A *_vt;~%" |
| 193 | (vtable-struct-tag class chain-head)))))) |
| 194 | |
| 195 | (defmethod add-output-hooks progn |
| 196 | ((islots islots) (reason (eql :h)) sequencer) |
| 197 | (with-slots (class subclass slots) islots |
| 198 | (sequence-output (stream sequencer) |
| 199 | ((subclass :ichain (sod-class-chain-head class) :slots) |
| 200 | (format stream " struct ~A ~A;~%" |
| 201 | (islots-struct-tag class) |
| 202 | (sod-class-nickname class)))))) |
| 203 | |
| 204 | ;;;-------------------------------------------------------------------------- |
| 205 | ;;; Vtable structure. |
| 206 | |
| 207 | (defmethod add-output-hooks progn ((vtable vtable) reason sequencer) |
| 208 | (with-slots (body) vtable |
| 209 | (dolist (item body) (add-output-hooks item reason sequencer)))) |
| 210 | |
| 211 | (defmethod add-output-hooks progn |
| 212 | ((vtable vtable) (reason (eql :h)) sequencer) |
| 213 | (with-slots (class chain-head) vtable |
| 214 | (sequence-output (stream sequencer) |
| 215 | :constraint ((class :vtables :start) |
| 216 | (class :vtable chain-head :start) |
| 217 | (class :vtable chain-head :slots) |
| 218 | (class :vtable chain-head :end) |
| 219 | (class :vtables :end)) |
| 220 | ((class :vtable chain-head :start) |
| 221 | (format stream "struct ~A {~%" (vtable-struct-tag class chain-head))) |
| 222 | ((class :vtable chain-head :end) |
| 223 | (format stream "};~2%")) |
| 224 | ((class :vtable-externs) |
| 225 | (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%" |
| 226 | (vtable-struct-tag class chain-head) |
| 227 | class (sod-class-nickname chain-head)))))) |
| 228 | |
| 229 | (defmethod add-output-hooks progn |
| 230 | ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) |
| 231 | (with-slots (class subclass chain-head) vtmsgs |
| 232 | (sequence-output (stream sequencer) |
| 233 | ((subclass :vtable chain-head :slots) |
| 234 | (format stream " struct ~A ~A;~%" |
| 235 | (vtmsgs-struct-tag subclass class) |
| 236 | (sod-class-nickname class)))))) |
| 237 | |
| 238 | (defmethod add-output-hooks progn |
| 239 | ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer) |
| 240 | (when (vtmsgs-entries vtmsgs) |
| 241 | (with-slots (class subclass) vtmsgs |
| 242 | (sequence-output (stream sequencer) |
| 243 | :constraint ((subclass :vtmsgs :start) |
| 244 | (subclass :vtmsgs class :start) |
| 245 | (subclass :vtmsgs class :slots) |
| 246 | (subclass :vtmsgs class :end) |
| 247 | (subclass :vtmsgs :end)) |
| 248 | ((subclass :vtmsgs class :start) |
| 249 | (format stream "struct ~A {~%" (vtmsgs-struct-tag subclass class))) |
| 250 | ((subclass :vtmsgs class :end) |
| 251 | (format stream "};~2%")))))) |
| 252 | |
| 253 | (defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer) |
| 254 | (with-slots (entries) vtmsgs |
| 255 | (dolist (entry entries) (add-output-hooks entry reason sequencer)))) |
| 256 | |
| 257 | (defmethod add-output-hooks progn ((entry method-entry) reason sequencer) |
| 258 | (with-slots (method) entry |
| 259 | (add-output-hooks method reason sequencer))) |
| 260 | |
| 261 | (defmethod add-output-hooks progn |
| 262 | ((method effective-method) (reason (eql 'populate-vtmsgs)) sequencer) |
| 263 | (let* ((message (effective-method-message method)) |
| 264 | (class (effective-method-class method)) |
| 265 | (class-type (find-class-type (sod-class-name class))) |
| 266 | (raw-type (sod-message-type message)) |
| 267 | (type (c-type (* (fun (lisp (c-type-subtype raw-type)) |
| 268 | ("/*me*/" (* (lisp class-type))) |
| 269 | . (commentify-argument-names |
| 270 | (c-function-arguments raw-type))))))) |
| 271 | (sequence-output (stream sequencer) |
| 272 | ((class :vtmsgs (sod-message-class message) :slots) |
| 273 | (pprint-logical-block (stream nil :prefix " " :suffix ";") |
| 274 | (pprint-c-type type stream (sod-message-name message))) |
| 275 | (terpri stream))))) |
| 276 | |
| 277 | (defmethod add-output-hooks progn |
| 278 | ((cptr class-pointer) (reason (eql :h)) sequencer) |
| 279 | (with-slots (class chain-head metaclass meta-chain-head) cptr |
| 280 | (sequence-output (stream sequencer) |
| 281 | ((class :vtable chain-head :slots) |
| 282 | (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" |
| 283 | metaclass |
| 284 | (if (sod-class-direct-superclasses meta-chain-head) |
| 285 | (sod-class-nickname meta-chain-head) |
| 286 | nil)))))) |
| 287 | |
| 288 | (defmethod add-output-hooks progn |
| 289 | ((boff base-offset) (reason (eql :h)) sequencer) |
| 290 | (with-slots (class chain-head) boff |
| 291 | (sequence-output (stream sequencer) |
| 292 | ((class :vtable chain-head :slots) |
| 293 | (write-line " size_t _base;" stream))))) |
| 294 | |
| 295 | (defmethod add-output-hooks progn |
| 296 | ((choff chain-offset) (reason (eql :h)) sequencer) |
| 297 | (with-slots (class chain-head target-head) choff |
| 298 | (sequence-output (stream sequencer) |
| 299 | ((class :vtable chain-head :slots) |
| 300 | (format stream " ptrdiff_t _off_~A;~%" |
| 301 | (sod-class-nickname target-head)))))) |
| 302 | |
| 303 | ;;;-------------------------------------------------------------------------- |
| 304 | ;;; Testing. |
| 305 | |
| 306 | #+test |
| 307 | (defun test (name) |
| 308 | (let ((sequencer (make-instance 'sequencer)) |
| 309 | (class (find-sod-class name))) |
| 310 | (add-output-hooks class :h sequencer) |
| 311 | (invoke-sequencer-items sequencer *standard-output*) |
| 312 | sequencer)) |
| 313 | |
| 314 | ;;;----- That's all, folks -------------------------------------------------- |