chiark - git - mdw - sod/blob - class-output.lisp

   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 :methods :start) (class :methods) (class :methods :end)
  78      (class :ichains :start) (class :ichains :end)
  79      (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
  80      (class :conversions)
  81      (class :object)
  82      (:classes :end))
  83
  84     (:typedefs
  85      (format stream "typedef struct ~A ~A;~%"
  86              (ichain-struct-tag class (sod-class-chain-head class)) class))
  87
  88     ((class :banner)
  89      (banner (format nil "Class ~A" class) stream))
  90     ((class :vtable-externs-after)
  91      (terpri stream))
  92
  93     ((class :vtable-externs)
  94      (format stream "/* Vtable structures. */~%"))
  95
  96     ((class :object)
  97      (let ((metaclass (sod-class-metaclass class))
  98            (metaroot (find-root-metaclass class)))
  99        (format stream "/* The class object. */~%~
 100                        extern struct ~A ~A__classobj;~%~
 101                        #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
 102                (ilayout-struct-tag metaclass) class
 103                (sod-class-nickname (sod-class-chain-head metaroot))
 104                (sod-class-nickname metaroot)))))
 105
 106   ;; Maybe generate an islots structure.
 107   (when (sod-class-slots class)
 108     (dolist (slot (sod-class-slots class))
 109       (add-output-hooks slot 'populate-islots sequencer))
 110     (sequence-output (stream sequencer)
 111       ((class :islots :start)
 112        (format stream "/* Instance slots. */~%~
 113                        struct ~A {~%"
 114                (islots-struct-tag class)))
 115       ((class :islots :end)
 116        (format stream "};~2%"))))
 117
 118   ;; Declare the direct methods.
 119   (when (sod-class-methods class)
 120     (sequence-output (stream sequencer)
 121       ((class :methods :start)
 122        (format stream "/* Direct methods. */~%"))
 123       ((class :methods :end)
 124        (terpri stream))))
 125
 126   ;; Provide upcast macros which do the right thing.
 127   (when (sod-class-direct-superclasses class)
 128     (sequence-output (stream sequencer)
 129       ((class :conversions)
 130        (let ((chain-head (sod-class-chain-head class)))
 131          (format stream "/* Conversion macros. */~%")
 132          (dolist (super (cdr (sod-class-precedence-list class)))
 133            (let ((super-head (sod-class-chain-head super)))
 134              (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
 135                                      ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
 136                      class (sod-class-nickname super) super
 137                      (eq chain-head super-head)
 138                      (sod-class-nickname super-head))))
 139          (terpri stream)))))
 140
 141   ;; Generate vtmsgs structure for all superclasses.
 142   (add-output-hooks (car (sod-class-vtables class))
 143                     'populate-vtmsgs
 144                     sequencer))
 145
 146 (defmethod add-output-hooks progn ((class sod-class) reason sequencer)
 147   (with-slots (ilayout vtables methods) class
 148     (add-output-hooks ilayout reason sequencer)
 149     (dolist (method methods) (add-output-hooks method reason sequencer))
 150     (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
 151
 152 ;;;--------------------------------------------------------------------------
 153 ;;; Instance structure.
 154
 155 (defmethod add-output-hooks progn
 156     ((slot sod-slot) (reason (eql 'populate-islots)) sequencer)
 157   (sequence-output (stream sequencer)
 158     (((sod-slot-class slot) :islots :slots)
 159      (pprint-logical-block (stream nil :prefix "  " :suffix ";")
 160        (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
 161      (terpri stream))))
 162
 163 (defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer)
 164   (with-slots (ichains) ilayout
 165     (dolist (ichain ichains) (add-output-hooks ichain reason sequencer))))
 166
 167 (defmethod add-output-hooks progn
 168     ((ilayout ilayout) (reason (eql :h)) sequencer)
 169   (with-slots (class ichains) ilayout
 170     (sequence-output (stream sequencer)
 171       ((class :ilayout :start)
 172        (format stream "/* Instance layout. */~%~
 173                        struct ~A {~%"
 174                (ilayout-struct-tag class)))
 175       ((class :ilayout :end)
 176        (format stream "};~2%")))
 177     (dolist (ichain ichains)
 178       (add-output-hooks ichain 'populate-ilayout sequencer))))
 179
 180 (defmethod add-output-hooks progn
 181     ((ichain ichain) (reason (eql :h)) sequencer)
 182   (with-slots (class chain-head chain-tail) ichain
 183     (when (eq class chain-tail)
 184       (sequence-output (stream sequencer)
 185         :constraint ((class :ichains :start)
 186                      (class :ichain chain-head :start)
 187                      (class :ichain chain-head :slots)
 188                      (class :ichain chain-head :end)
 189                      (class :ichains :end))
 190         ((class :ichain chain-head :start)
 191          (format stream "/* Instance chain structure. */~%~
 192                          struct ~A {~%"
 193                  (ichain-struct-tag chain-tail chain-head)))
 194         ((class :ichain chain-head :end)
 195          (format stream "};~2%")
 196          (format stream "/* Union of equivalent superclass chains. */~%~
 197                          union ~A {~%~
 198                          ~:{  struct ~A ~A;~%~}~
 199                          };~2%"
 200                  (ichain-union-tag chain-tail chain-head)
 201                  (mapcar (lambda (super)
 202                            (list (ichain-struct-tag super chain-head)
 203                                  (sod-class-nickname super)))
 204                          (sod-class-chain chain-tail))))))))
 205
 206 (defmethod add-output-hooks progn
 207     ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
 208   (with-slots (class chain-head chain-tail) ichain
 209     (sequence-output (stream sequencer)
 210       ((class :ilayout :slots)
 211        (format stream "  union ~A ~A;~%"
 212                (ichain-union-tag chain-tail chain-head)
 213                (sod-class-nickname chain-head))))))
 214
 215 (defmethod add-output-hooks progn
 216     ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
 217   (with-slots (class chain-head chain-tail) vtptr
 218     (sequence-output (stream sequencer)
 219       ((class :ichain chain-head :slots)
 220        (format stream "  const struct ~A *_vt;~%"
 221                (vtable-struct-tag chain-tail chain-head))))))
 222
 223 (defmethod add-output-hooks progn
 224     ((islots islots) (reason (eql :h)) sequencer)
 225   (with-slots (class subclass slots) islots
 226     (sequence-output (stream sequencer)
 227       ((subclass :ichain (sod-class-chain-head class) :slots)
 228        (format stream "  struct ~A ~A;~%"
 229                (islots-struct-tag class)
 230                (sod-class-nickname class))))))
 231
 232 ;;;--------------------------------------------------------------------------
 233 ;;; Vtable structure.
 234
 235 (defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
 236   (with-slots (body) vtable
 237     (dolist (item body) (add-output-hooks item reason sequencer))))
 238
 239 (defmethod add-output-hooks progn
 240     ((method sod-method) (reason (eql :h)) sequencer)
 241   (with-slots (class) method
 242     (sequence-output (stream sequencer)
 243       ((class :methods)
 244        (let ((type (sod-method-function-type method)))
 245          (princ "extern " stream)
 246          (pprint-c-type (commentify-function-type type) stream
 247                         (sod-method-function-name method))
 248          (format stream ";~%"))))))
 249
 250 (defmethod add-output-hooks progn
 251     ((vtable vtable) (reason (eql :h)) sequencer)
 252   (with-slots (class chain-head chain-tail) vtable
 253     (when (eq class chain-tail)
 254       (sequence-output (stream sequencer)
 255         :constraint ((class :vtables :start)
 256                      (class :vtable chain-head :start)
 257                      (class :vtable chain-head :slots)
 258                      (class :vtable chain-head :end)
 259                      (class :vtables :end))
 260         ((class :vtable chain-head :start)
 261          (format stream "/* Vtable structure. */~%~
 262                          struct ~A {~%"
 263                  (vtable-struct-tag chain-tail chain-head)))
 264         ((class :vtable chain-head :end)
 265          (format stream "};~2%"))))
 266     (sequence-output (stream sequencer)
 267       ((class :vtable-externs)
 268        (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
 269                (vtable-struct-tag chain-tail chain-head)
 270                class (sod-class-nickname chain-head))))))
 271
 272 (defmethod add-output-hooks progn
 273     ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
 274   (with-slots (class subclass chain-head chain-tail) vtmsgs
 275     (sequence-output (stream sequencer)
 276       ((subclass :vtable chain-head :slots)
 277        (format stream "  struct ~A ~A;~%"
 278                (vtmsgs-struct-tag subclass class)
 279                (sod-class-nickname class))))))
 280
 281 (defmethod add-output-hooks progn
 282     ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer)
 283   (when (vtmsgs-entries vtmsgs)
 284     (with-slots (class subclass) vtmsgs
 285       (sequence-output (stream sequencer)
 286         :constraint ((subclass :vtmsgs :start)
 287                      (subclass :vtmsgs class :start)
 288                      (subclass :vtmsgs class :slots)
 289                      (subclass :vtmsgs class :end)
 290                      (subclass :vtmsgs :end))
 291         ((subclass :vtmsgs class :start)
 292          (format stream "/* Messages protocol from class ~A */~%~
 293                          struct ~A {~%"
 294                  class
 295                  (vtmsgs-struct-tag subclass class)))
 296         ((subclass :vtmsgs class :end)
 297          (format stream "};~2%"))))))
 298
 299 (defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer)
 300   (with-slots (entries) vtmsgs
 301     (dolist (entry entries) (add-output-hooks entry reason sequencer))))
 302
 303 (defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
 304   (with-slots (method) entry
 305     (add-output-hooks method reason sequencer)))
 306
 307 (defmethod add-output-hooks progn
 308     ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
 309   (let* ((method (method-entry-effective-method entry))
 310          (message (effective-method-message method))
 311          (class (effective-method-class method))
 312          (type (method-entry-function-type entry))
 313          (commented-type (commentify-function-type type)))
 314     (sequence-output (stream sequencer)
 315       ((class :vtmsgs (sod-message-class message) :slots)
 316        (pprint-logical-block (stream nil :prefix "  " :suffix ";")
 317          (pprint-c-type commented-type stream (sod-message-name message)))
 318        (terpri stream)))))
 319
 320 (defmethod add-output-hooks progn
 321     ((cptr class-pointer) (reason (eql :h)) sequencer)
 322   (with-slots (class chain-head metaclass meta-chain-head) cptr
 323     (sequence-output (stream sequencer)
 324       ((class :vtable chain-head :slots)
 325        (format stream "  const ~A *~:[_class~;~:*_cls_~A~];~%"
 326                metaclass
 327                (if (sod-class-direct-superclasses meta-chain-head)
 328                    (sod-class-nickname meta-chain-head)
 329                    nil))))))
 330
 331 (defmethod add-output-hooks progn
 332     ((boff base-offset) (reason (eql :h)) sequencer)
 333   (with-slots (class chain-head) boff
 334     (sequence-output (stream sequencer)
 335       ((class :vtable chain-head :slots)
 336        (write-line "  size_t _base;" stream)))))
 337
 338 (defmethod add-output-hooks progn
 339     ((choff chain-offset) (reason (eql :h)) sequencer)
 340   (with-slots (class chain-head target-head) choff
 341     (sequence-output (stream sequencer)
 342       ((class :vtable chain-head :slots)
 343        (format stream "  ptrdiff_t _off_~A;~%"
 344                (sod-class-nickname target-head))))))
 345
 346 ;;;--------------------------------------------------------------------------
 347 ;;; Testing.
 348
 349 #+test
 350 (defun test (name)
 351   (let ((sequencer (make-instance 'sequencer))
 352         (class (find-sod-class name)))
 353     (add-output-hooks class :h sequencer)
 354     (invoke-sequencer-items sequencer *standard-output*)
 355     sequencer))
 356
 357 ;;;----- That's all, folks --------------------------------------------------