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 ;; Utilities.
 237
 238 (defun declare-me (codegen class)
 239   "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.
 240
 241    The pointer refers to a part of the prevailing `sod__obj' object, which is
 242    assumed to be a pointer to an appropriate `ilayout' structure."
 243   (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
 244                                     (format nil "&sod__obj->~A.~A"
 245                                             (sod-class-nickname
 246                                              (sod-class-chain-head class))
 247                                             (sod-class-nickname class)))))
 248
 249 (defun collect-initarg-keywords (class)
 250   "Return a list of keyword arguments corresponding to CLASS's initargs.
 251
 252    For each distinct name among the initargs defined on CLASS and its
 253    superclasses, return a single `argument' object containing the (agreed
 254    common) type, and the (unique, if present) default value from the most
 255    specific defining superclass.
 256
 257    The arguments are not returned in any especially meaningful order."
 258
 259   (let ((map (make-hash-table :test #'equal))
 260         (default-map (make-hash-table :test #'equal))
 261         (list nil))
 262     (dolist (super (sod-class-precedence-list class))
 263       (dolist (initarg (sod-class-initargs super))
 264         (let ((name (sod-initarg-name initarg))
 265               (default (sod-initarg-default initarg)))
 266           (unless (gethash name default-map)
 267             (when (or default (not (gethash name map)))
 268               (setf (gethash name map) (sod-initarg-argument initarg)))
 269             (when default
 270               (setf (gethash name default-map) t))))))
 271     (maphash (lambda (key value)
 272                (declare (ignore key))
 273                (push value list))
 274              map)
 275     list))
 276
 277 (definst suppliedp-struct (stream) (flags var)
 278   (format stream
 279           "~@<struct { ~2I~_~{unsigned ~A : 1;~^ ~_~} ~I~_} ~A;~:>"
 280           flags var))
 281
 282 ;; Initialization.
 283
 284 (defclass initialization-message (lifecycle-message)
 285   ())
 286
 287 (defclass initialization-effective-method (lifecycle-effective-method)
 288   ())
 289
 290 (defmethod sod-message-effective-method-class
 291     ((message initialization-message))
 292   'initialization-effective-method)
 293
 294 (defmethod method-keyword-argument-lists
 295     ((method initialization-effective-method) direct-methods)
 296   (append (call-next-method)
 297           (delete-duplicates
 298            (mapcan (lambda (class)
 299                      (let ((initargs (sod-class-initargs class)))
 300                        (and initargs
 301                             (list (cons (mapcar #'sod-initarg-argument
 302                                                 initargs)
 303                                         (format nil "initargs for ~A"
 304                                                 class))))))
 305                    (sod-class-precedence-list
 306                     (effective-method-class method)))
 307            :key #'argument-name)))
 308
 309 (defmethod lifecycle-method-kernel
 310     ((method initialization-effective-method) codegen target)
 311   (let* ((class (effective-method-class method))
 312          (keywords (collect-initarg-keywords class))
 313          (ilayout (sod-class-ilayout class))
 314          (obj-tag (ilayout-struct-tag class))
 315          (kw-tag (effective-method-keyword-struct-tag method))
 316          (kw-tail (and keywords
 317                        (list (make-argument
 318                               "sod__kw"
 319                               (c-type (* (struct kw-tag :const)))))))
 320          (func-type (c-type (fun void
 321                                  ("sod__obj" (* (struct obj-tag)))
 322                                  . kw-tail)))
 323          (func-name (format nil "~A__init" class))
 324          (done-setup-p nil))
 325
 326     ;; Start building the initialization function.
 327     (codegen-push codegen)
 328
 329     (labels ((set-from-initializer (var type init)
 330                ;; Store the value of INIT, which has the given TYPE, in VAR.
 331                ;; INIT has the syntax of an initializer: declare and
 332                ;; initialize a temporary, and then copy the result.
 333                ;; Compilers seem to optimize this properly.  Return the
 334                ;; resulting code as an instruction.
 335                (codegen-push codegen)
 336                (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
 337                (deliver-expr codegen var *sod-tmp-val*)
 338                (codegen-pop-block codegen))
 339              (setup ()
 340                ;; Do any necessary one-time initialization required to set up
 341                ;; the environment for the initialization code.
 342                (unless done-setup-p
 343
 344                  ;; Extract the keyword arguments into local variables.
 345                  (when keywords
 346                    (emit-decl codegen
 347                               (make-suppliedp-struct-inst
 348                                (mapcar #'argument-name keywords)
 349                                "suppliedp"))
 350                    (emit-banner codegen "Collect the keyword arguments.")
 351                    (dolist (arg keywords)
 352                      (let* ((name (argument-name arg))
 353                             (type (argument-type arg))
 354                             (default (argument-default arg))
 355                             (kwvar (format nil "sod__kw->~A" name))
 356                             (kwset (make-set-inst name kwvar))
 357                             (suppliedp (format nil "suppliedp.~A" name)))
 358                        (emit-decl codegen (make-var-inst name type))
 359                        (deliver-expr codegen suppliedp
 360                                      (format nil "sod__kw->~A__suppliedp"
 361                                              name))
 362                        (emit-inst
 363                         codegen
 364                         (if default
 365                             (make-if-inst suppliedp kwset
 366                                           (set-from-initializer name
 367                                                                 type
 368                                                                 default))
 369                             kwset))))
 370
 371                    (deliver-call codegen :void
 372                                  "SOD__IGNORE" "suppliedp")
 373                    (dolist (arg keywords)
 374                      (deliver-call codegen :void
 375                                    "SOD__IGNORE" (argument-name arg))))
 376
 377                  (setf done-setup-p t))))
 378
 379       ;; Initialize the structure defined by the various superclasses, in
 380       ;; reverse precedence order.
 381       (dolist (super (reverse (sod-class-precedence-list class)))
 382         (let* ((ichain (find (sod-class-chain-head super)
 383                              (ilayout-ichains ilayout)
 384                              :key #'ichain-head))
 385                (islots (find super (ichain-body ichain)
 386                              :test (lambda (class item)
 387                                      (and (typep item 'islots)
 388                                           (eq (islots-class item) class)))))
 389                (frags (sod-class-initfrags super))
 390                (this-class-focussed-p nil)
 391                (isl (format nil "me->~A" (sod-class-nickname super))))
 392
 393           (flet ((focus-this-class ()
 394                    ;; Delayed initial preparation.  Don't bother defining the
 395                    ;; `me' pointer if there's actually nothing to do.
 396                    (setup)
 397                    (unless this-class-focussed-p
 398                      (emit-banner codegen
 399                                   "Initialization for class `~A'." super)
 400                      (codegen-push codegen)
 401                      (declare-me codegen super)
 402                      (setf this-class-focussed-p t))))
 403
 404             ;; Work through each slot in turn.
 405             (dolist (slot (and islots (islots-slots islots)))
 406               (let ((dslot (effective-slot-direct-slot slot))
 407                     (init (effective-slot-initializer slot))
 408                     (initargs (effective-slot-initargs slot)))
 409                 (when (or init initargs)
 410                   (focus-this-class)
 411                   (let* ((slot-type (sod-slot-type dslot))
 412                          (slot-default (sod-initializer-value init))
 413                          (target (format nil "~A.~A"
 414                                          isl (sod-slot-name dslot)))
 415                          (initinst (set-from-initializer target
 416                                                          slot-type
 417                                                          slot-default)))
 418
 419                     ;; If there are applicable initialization arguments,
 420                     ;; check to see whether they were supplied.
 421                     (dolist (initarg (reverse (remove-duplicates
 422                                                initargs
 423                                                :key #'sod-initarg-name
 424                                                :test #'string=)))
 425                       (let ((arg-name (sod-initarg-name initarg)))
 426                         (setf initinst (make-if-inst
 427                                         (format nil "suppliedp.~A" arg-name)
 428                                         (make-set-inst target arg-name)
 429                                         initinst))))
 430
 431                     (emit-inst codegen initinst)))))
 432
 433             ;; Emit the class's initialization fragments.
 434             (when frags
 435               (let ((used-me-p this-class-focussed-p))
 436                 (focus-this-class)
 437                 (unless used-me-p
 438                   (deliver-call codegen :void "SOD__IGNORE" "me")))
 439               (dolist (frag frags)
 440                 (codegen-push codegen)
 441                 (emit-inst codegen frag)
 442                 (emit-inst codegen (codegen-pop-block codegen))))
 443
 444             ;; If we opened a block to initialize this class then close it
 445             ;; again.
 446             (when this-class-focussed-p
 447               (emit-inst codegen (codegen-pop-block codegen)))))))
 448
 449     ;; Done making the initialization function.
 450     (codegen-pop-function codegen func-name func-type
 451                           "Instance initialization function ~:_~
 452                            for class `~A'."
 453                           class)
 454
 455     (apply #'deliver-call codegen :void func-name
 456            "sod__obj" (and keywords (list (keyword-struct-pointer))))))
 457
 458 ;; Teardown.
 459
 460 (defclass teardown-message (lifecycle-message)
 461   ())
 462
 463 (defclass teardown-effective-method (lifecycle-effective-method)
 464   ())
 465
 466 (defmethod sod-message-effective-method-class ((message teardown-message))
 467   'teardown-effective-method)
 468
 469 (defmethod lifecycle-method-kernel
 470     ((method teardown-effective-method) codegen target)
 471   (let* ((class (effective-method-class method))
 472          (obj-tag (ilayout-struct-tag class))
 473          (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
 474          (func-name (format nil "~A__teardown" class)))
 475     (codegen-push codegen)
 476     (dolist (super (sod-class-precedence-list class))
 477       (let ((frags (sod-class-tearfrags super)))
 478         (when frags
 479           (emit-banner codegen "Teardown for class `~A'." super)
 480           (codegen-push codegen)
 481           (declare-me codegen super)
 482           (deliver-call codegen :void "SOD__IGNORE" "me")
 483           (dolist (frag frags)
 484             (codegen-push codegen)
 485             (emit-inst codegen frag)
 486             (emit-inst codegen (codegen-pop-block codegen)))
 487           (emit-inst codegen (codegen-pop-block codegen)))))
 488     (codegen-pop-function codegen func-name func-type
 489                           "Instance teardown function ~:_~
 490                            for class `~A'."
 491                           class)
 492     (deliver-call codegen :void
 493                   (format nil "~A__teardown" class) "sod__obj")
 494     (deliver-expr codegen target 0)))
 495
 496 ;;;--------------------------------------------------------------------------
 497 ;;; Bootstrapping the class graph.
 498
 499 (defun bootstrap-classes (module)
 500   "Bootstrap the braid in MODULE.
 501
 502    This builds the fundamental recursive braid, where `SodObject' is an
 503    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
 504    an instance of itself)."
 505   (let* ((sod-object (make-sod-class "SodObject" nil
 506                                      (make-property-set :nick 'obj)))
 507          (sod-class (make-sod-class "SodClass" (list sod-object)
 508                                     (make-property-set :nick 'cls)))
 509          (classes (list sod-object sod-class)))
 510
 511     ;; Attach the built-in messages.
 512     (make-sod-message sod-object "init"
 513                       (c-type (fun void :keys))
 514                       (make-property-set
 515                        :message-class 'initialization-message))
 516     (make-sod-message sod-object "teardown" (c-type (fun int))
 517                       (make-property-set :message-class 'teardown-message))
 518
 519     ;; Sort out the recursion.
 520     (setf (slot-value sod-class 'chain-link) sod-object)
 521     (dolist (class classes)
 522       (setf (slot-value class 'metaclass) sod-class))
 523
 524     ;; Predeclare the class types.
 525     (dolist (class classes)
 526       (make-class-type (sod-class-name class)))
 527
 528     ;; Attach the class slots.
 529     (dolist (slot *class-slot-alist*)
 530       (funcall (cdr slot) sod-class))
 531
 532     ;; These classes are too closely intertwined.  We must partially finalize
 533     ;; them together by hand.  This is cloned from `finalize-sod-class'.
 534     (dolist (class classes)
 535       (with-slots (class-precedence-list chain-head chain chains) class
 536         (setf class-precedence-list (compute-cpl class))
 537         (setf (values chain-head chain chains) (compute-chains class))))
 538
 539     ;; Done.
 540     (dolist (class classes)
 541       (finalize-sod-class class)
 542       (add-to-module module class))))
 543
 544 (export '*builtin-module*)
 545 (defvar *builtin-module* nil
 546   "The builtin module.")
 547
 548 (export 'make-builtin-module)
 549 (defun make-builtin-module ()
 550   "Construct the builtin module.
 551
 552    This involves constructing the braid (which is done in
 553    `bootstrap-classes') and defining a few obvious type names which users
 554    will find handy.
 555
 556    Returns the newly constructed module, and stores it in the variable
 557    `*builtin-module*'."
 558   (let ((module (make-instance 'module
 559                                :name (make-pathname :name "SOD-BASE"
 560                                                     :type "SOD"
 561                                                     :case :common)
 562                                :state nil)))
 563     (with-module-environment (module)
 564       (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
 565         (add-to-module module (make-instance 'type-item :name name)))
 566       (flet ((header-name (name)
 567                (concatenate 'string "\"" (string-downcase name) ".h\""))
 568              (add-includes (reason &rest names)
 569                (let ((text (with-output-to-string (out)
 570                              (dolist (name names)
 571                                (format out "#include ~A~%" name)))))
 572                  (add-to-module module
 573                                 (make-instance 'code-fragment-item
 574                                                :reason reason
 575                                                :constraints nil
 576                                                :name :includes
 577                                                :fragment text)))))
 578         (add-includes :c (header-name "sod"))
 579         (add-includes :h "<stddef.h>"))
 580       (bootstrap-classes module))
 581     (setf *builtin-module* module)))
 582
 583 (define-clear-the-decks builtin-module
 584   (unless *builtin-module* (make-builtin-module)))
 585
 586 ;;;----- That's all, folks --------------------------------------------------