mdw@git.distorted.org.uk Git - sod/blob - src/builtin.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Builtin module provides the root of the class graph
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Sensible 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 ;;; Infrastructure.
  30
  31 (defvar *class-slot-alist* nil)
  32
  33 (defun add-class-slot-function (name function)
  34   "Attach a slot function to the `*class-slot-alist*'.
  35
  36    The FUNCTION is invoked with one argument, which is a `sod-class' object
  37    to which it should add a slot.  If a function with the same NAME is
  38    already defined then that function is replaced; otherwise a new name/
  39    function pair is defined.
  40
  41    Functions are are invoked in the order in which their names were first
  42    added."
  43
  44   (aif (assoc name *class-slot-alist* :test #'string=)
  45        (setf (cdr it) function)
  46        (asetf *class-slot-alist* (append it (list (cons name function))))))
  47
  48 (defmacro define-class-slot
  49     (name (class &optional stream) type init &body prepare)
  50   "Define a new class slot.
  51
  52    The slot will be called NAME (a string) and will be of TYPE (which should
  53    be a type S-expression).  The slot's (static) initializer will be
  54    constructed by printing the value of INIT, which is evaluated with CLASS
  55    bound to the class object being constructed.  If any PREPARE forms are
  56    provided, then they are evaluated as a progn, with CLASS bound to the
  57    class object, and STREAM bound to the output stream it should write on."
  58
  59   (with-gensyms (classvar)
  60     `(add-class-slot-function
  61       ',name
  62       (lambda (,classvar)
  63         (make-sod-slot ,classvar ,name (c-type ,type)
  64                        (make-property-set :slot-class 'sod-class-slot
  65                                           :initializer-function
  66                                           (lambda (,class)
  67                                             ,init)
  68                                           ,@(and prepare
  69                                                  `(:prepare-function
  70                                                    (lambda (,class ,stream)
  71                                                      ,@prepare)))))))))
  72
  73 ;;;--------------------------------------------------------------------------
  74 ;;; Basic information.
  75
  76 (define-class-slot "name" (class) const-string
  77   (prin1-to-string (sod-class-name class)))
  78
  79 (define-class-slot "nick" (class) const-string
  80   (prin1-to-string (sod-class-nickname class)))
  81
  82 ;;;--------------------------------------------------------------------------
  83 ;;; Instance allocation and initialization.
  84
  85 (define-class-slot "initsz" (class) size-t
  86   (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
  87
  88 (define-class-slot "imprint" (class stream)
  89     (* (fun (* void) ("/*p*/" (* void))))
  90   (format nil "~A__imprint" class)
  91   (let ((ilayout (sod-class-ilayout class)))
  92     (format stream "~&~:
  93 /* Imprint raw memory with class `~A' instance structure. */
  94 static void *~:*~A__imprint(void *p)
  95 {
  96   struct ~A *sod__obj = p;
  97
  98   ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~%  ~}
  99   return (p);
 100 }~2%"
 101             class
 102             (ilayout-struct-tag class)
 103             (mapcar (lambda (ichain)
 104                       (let* ((head (ichain-head ichain))
 105                              (tail (ichain-tail ichain)))
 106                         (list (sod-class-nickname head)
 107                               (sod-class-nickname tail)
 108                               (vtable-name class head)
 109                               (sod-class-nickname tail))))
 110                     (ilayout-ichains ilayout)))))
 111
 112 ;;;--------------------------------------------------------------------------
 113 ;;; Superclass structure.
 114
 115 (define-class-slot "n_supers" (class) size-t
 116   (length (sod-class-direct-superclasses class)))
 117
 118 (define-class-slot "supers" (class stream)
 119     (* (* (class "SodClass" :const) :const))
 120   (if (null (sod-class-direct-superclasses class)) 0
 121       (format nil "~A__supers" class))
 122   (let ((supers (sod-class-direct-superclasses class)))
 123     (when supers
 124       (format stream "~&~:
 125 /* Direct superclasses. */
 126 static const SodClass *const ~A__supers[] = {
 127   ~{~A__class~^,~%  ~}
 128 };~2%"
 129               class supers))))
 130
 131 (define-class-slot "n_cpl" (class) size-t
 132   (length (sod-class-precedence-list class)))
 133
 134 (define-class-slot "cpl" (class stream)
 135     (* (* (class "SodClass" :const) :const))
 136   (format nil "~A__cpl" class)
 137   (format stream "~&~:
 138 /* Class precedence list. */
 139 static const SodClass *const ~A__cpl[] = {
 140   ~{~A__class~^,~%  ~}
 141 };~2%"
 142           class (sod-class-precedence-list class)))
 143
 144 ;;;--------------------------------------------------------------------------
 145 ;;; Chain structure.
 146
 147 (define-class-slot "link" (class) (* (class "SodClass" :const))
 148   (aif (sod-class-chain-link class)
 149        (format nil "~A__class" it)
 150        0))
 151
 152 (define-class-slot "head" (class) (* (class "SodClass" :const))
 153   (format nil "~A__class" (sod-class-chain-head class)))
 154
 155 (define-class-slot "level" (class) size-t
 156   (position class (reverse (sod-class-chain class))))
 157
 158 (define-class-slot "n_chains" (class) size-t
 159   (length (sod-class-chains class)))
 160
 161 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
 162   (format nil "~A__chains" class)
 163   (let ((chains (sod-class-chains class)))
 164     (format stream "~&~:
 165 /* Chain structure. */
 166 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 167   ~{~A__class~^,~%  ~}
 168 };~:^~2%~}
 169
 170 ~0@*static const struct sod_chain ~A__chains[] = {
 171 ~:{  { ~
 172     /*           n_classes = */ ~3@*~A,
 173     /*             classes = */ ~0@*~A__chain_~A,
 174     /*          off_ichain = */ ~4@*offsetof(struct ~A, ~A),
 175     /*                  vt = */ (const struct sod_vtable *)&~A,
 176     /*            ichainsz = */ sizeof(struct ~A) }~:^,~%~}
 177 };~2%"
 178             class                       ;0
 179             (mapcar (lambda (chain)     ;1
 180                       (let* ((head (sod-class-chain-head (car chain)))
 181                              (chain-nick (sod-class-nickname head)))
 182                         (list class chain-nick                        ;0 1
 183                               (reverse chain)                         ;2
 184                               (length chain)                          ;3
 185                               (ilayout-struct-tag class) chain-nick   ;4 5
 186                               (vtable-name class head)                ;6
 187                               (ichain-struct-tag (car chain) head)))) ;7
 188                     chains))))
 189
 190 ;;;--------------------------------------------------------------------------
 191 ;;; Class-specific layout.
 192
 193 (define-class-slot "off_islots" (class) size-t
 194   (if (sod-class-slots class)
 195       (format nil "offsetof(struct ~A, ~A)"
 196               (ichain-struct-tag class (sod-class-chain-head class))
 197               (sod-class-nickname class))
 198       "0"))
 199
 200 (define-class-slot "islotsz" (class) size-t
 201   (if (sod-class-slots class)
 202       (format nil "sizeof(struct ~A)"
 203               (islots-struct-tag class))
 204       "0"))
 205
 206 ;;;--------------------------------------------------------------------------
 207 ;;; Built-in methods.
 208
 209 ;; Common protocol.
 210
 211 (defclass lifecycle-message (standard-message)
 212   ())
 213
 214 (defclass lifecycle-effective-method (standard-effective-method)
 215   ())
 216
 217 (defmethod effective-method-live-p ((method lifecycle-effective-method))
 218   t)
 219
 220 (defgeneric lifecycle-method-kernel (method codegen target)
 221   (:documentation
 222    "Compute (into CODEGEN) the class-specific part of the METHOD.
 223
 224    The result, if any, needs to find its way to the TARGET, as usual."))
 225
 226 (defmethod simple-method-body
 227     ((method lifecycle-effective-method) codegen target)
 228   (invoke-delegation-chain codegen target
 229                            (effective-method-basic-argument-names method)
 230                            (effective-method-primary-methods method)
 231                            (lambda (target)
 232                              (lifecycle-method-kernel method
 233                                                       codegen
 234                                                       target))))
 235
 236 ;; Initialization.
 237
 238 (defclass initialization-message (lifecycle-message)
 239   ())
 240
 241 (defclass initialization-effective-method (lifecycle-effective-method)
 242   ())
 243
 244 (defmethod sod-message-effective-method-class
 245     ((message initialization-message))
 246   'initialization-effective-method)
 247
 248 (defmethod lifecycle-method-kernel
 249     ((method initialization-effective-method) codegen target)
 250   (let* ((class (effective-method-class method))
 251          (ilayout (sod-class-ilayout class))
 252          (obj-tag (ilayout-struct-tag class))
 253          (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
 254          (func-name (format nil "~A__init" class)))
 255
 256     ;; Start building the initialization function.
 257     (codegen-push codegen)
 258
 259     (labels ((set-from-initializer (var type init)
 260                ;; Store the value of INIT, which has the given TYPE, in VAR.
 261                ;; INIT has the syntax of an initializer: declare and
 262                ;; initialize a temporary, and then copy the result.
 263                ;; Compilers seem to optimize this properly.  Return the
 264                ;; resulting code as an instruction.
 265                (codegen-push codegen)
 266                (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
 267                (deliver-expr codegen var *sod-tmp-val*)
 268                (codegen-pop-block codegen)))
 269
 270       ;; Loop over the instance layout emitting initializers as we find them.
 271       (dolist (ichain (ilayout-ichains ilayout))
 272         (let ((ich (format nil "sod__obj->~A.~A"
 273                            (sod-class-nickname (ichain-head ichain))
 274                            (sod-class-nickname (ichain-tail ichain)))))
 275           (dolist (item (ichain-body ichain))
 276             (etypecase item
 277               (vtable-pointer
 278                nil)
 279               (islots
 280                (let ((isl (format nil "~A.~A"
 281                                   ich
 282                                   (sod-class-nickname (islots-class item)))))
 283                  (dolist (slot (islots-slots item))
 284                    (let ((dslot (effective-slot-direct-slot slot))
 285                          (init (effective-slot-initializer slot)))
 286                      (when init
 287                        (let* ((slot-type (sod-slot-type dslot))
 288                               (slot-default (sod-initializer-value init))
 289                               (target (format nil "~A.~A"
 290                                               isl (sod-slot-name dslot)))
 291                               (initinst (set-from-initializer target
 292                                                               slot-type
 293                                                               slot-default)))
 294                          (emit-inst codegen initinst))))))))))))
 295
 296     ;; Done making the initialization function.
 297     (codegen-pop-function codegen func-name func-type
 298                           "Instance initialization function ~:_~
 299                            for class `~A'."
 300                           class)
 301
 302     (deliver-call codegen :void func-name "sod__obj")))
 303
 304 ;;;--------------------------------------------------------------------------
 305 ;;; Bootstrapping the class graph.
 306
 307 (defun bootstrap-classes (module)
 308   "Bootstrap the braid in MODULE.
 309
 310    This builds the fundamental recursive braid, where `SodObject' is an
 311    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
 312    an instance of itself)."
 313   (let* ((sod-object (make-sod-class "SodObject" nil
 314                                      (make-property-set :nick 'obj)))
 315          (sod-class (make-sod-class "SodClass" (list sod-object)
 316                                     (make-property-set :nick 'cls)))
 317          (classes (list sod-object sod-class)))
 318
 319     ;; Attach the built-in messages.
 320     (make-sod-message sod-object "init"
 321                       (c-type (fun void :keys))
 322                       (make-property-set
 323                        :message-class 'initialization-message))
 324
 325     ;; Sort out the recursion.
 326     (setf (slot-value sod-class 'chain-link) sod-object)
 327     (dolist (class classes)
 328       (setf (slot-value class 'metaclass) sod-class))
 329
 330     ;; Predeclare the class types.
 331     (dolist (class classes)
 332       (make-class-type (sod-class-name class)))
 333
 334     ;; Attach the class slots.
 335     (dolist (slot *class-slot-alist*)
 336       (funcall (cdr slot) sod-class))
 337
 338     ;; These classes are too closely intertwined.  We must partially finalize
 339     ;; them together by hand.  This is cloned from `finalize-sod-class'.
 340     (dolist (class classes)
 341       (with-slots (class-precedence-list chain-head chain chains) class
 342         (setf class-precedence-list (compute-cpl class))
 343         (setf (values chain-head chain chains) (compute-chains class))))
 344
 345     ;; Done.
 346     (dolist (class classes)
 347       (finalize-sod-class class)
 348       (add-to-module module class))))
 349
 350 (export '*builtin-module*)
 351 (defvar *builtin-module* nil
 352   "The builtin module.")
 353
 354 (export 'make-builtin-module)
 355 (defun make-builtin-module ()
 356   "Construct the builtin module.
 357
 358    This involves constructing the braid (which is done in
 359    `bootstrap-classes') and defining a few obvious type names which users
 360    will find handy.
 361
 362    Returns the newly constructed module, and stores it in the variable
 363    `*builtin-module*'."
 364   (let ((module (make-instance 'module
 365                                :name (make-pathname :name "SOD-BASE"
 366                                                     :type "SOD"
 367                                                     :case :common)
 368                                :state nil)))
 369     (with-module-environment (module)
 370       (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
 371         (add-to-module module (make-instance 'type-item :name name)))
 372       (flet ((header-name (name)
 373                (concatenate 'string "\"" (string-downcase name) ".h\""))
 374              (add-includes (reason &rest names)
 375                (let ((text (with-output-to-string (out)
 376                              (dolist (name names)
 377                                (format out "#include ~A~%" name)))))
 378                  (add-to-module module
 379                                 (make-instance 'code-fragment-item
 380                                                :reason reason
 381                                                :constraints nil
 382                                                :name :includes
 383                                                :fragment text)))))
 384         (add-includes :c (header-name "sod"))
 385         (add-includes :h "<stddef.h>"))
 386       (bootstrap-classes module))
 387     (setf *builtin-module* module)))
 388
 389 (define-clear-the-decks builtin-module
 390   (unless *builtin-module* (make-builtin-module)))
 391
 392 ;;;----- That's all, folks --------------------------------------------------