chiark - git - mdw - 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 "align" (class) size-t
  89   (format nil "SOD__ALIGNOF(struct ~A)" (ilayout-struct-tag class)))
  90
  91 (define-class-slot "imprint" (class stream)
  92     (* (fun (* void) ("/*p*/" (* void))))
  93   (format nil "~A__imprint" class)
  94   (let ((ilayout (sod-class-ilayout class)))
  95     (format stream "~&~:
  96 /* Imprint raw memory with class `~A' instance structure. */
  97 static void *~:*~A__imprint(void *p)
  98 {
  99   struct ~A *sod__obj = p;
 100
 101   ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~%  ~}
 102   return (p);
 103 }~2%"
 104             class
 105             (ilayout-struct-tag class)
 106             (mapcar (lambda (ichain)
 107                       (let* ((head (ichain-head ichain))
 108                              (tail (ichain-tail ichain)))
 109                         (list (sod-class-nickname head)
 110                               (sod-class-nickname tail)
 111                               (vtable-name class head)
 112                               (sod-class-nickname tail))))
 113                     (ilayout-ichains ilayout)))))
 114
 115 ;;;--------------------------------------------------------------------------
 116 ;;; Superclass structure.
 117
 118 (define-class-slot "n_supers" (class) size-t
 119   (length (sod-class-direct-superclasses class)))
 120
 121 (define-class-slot "supers" (class stream)
 122     (* (* (class "SodClass" :const) :const))
 123   (if (null (sod-class-direct-superclasses class)) 0
 124       (format nil "~A__supers" class))
 125   (let ((supers (sod-class-direct-superclasses class)))
 126     (when supers
 127       (format stream "~&~:
 128 /* Direct superclasses. */
 129 static const SodClass *const ~A__supers[] = {
 130   ~{~A__class~^,~%  ~}
 131 };~2%"
 132               class supers))))
 133
 134 (define-class-slot "n_cpl" (class) size-t
 135   (length (sod-class-precedence-list class)))
 136
 137 (define-class-slot "cpl" (class stream)
 138     (* (* (class "SodClass" :const) :const))
 139   (format nil "~A__cpl" class)
 140   (format stream "~&~:
 141 /* Class precedence list. */
 142 static const SodClass *const ~A__cpl[] = {
 143   ~{~A__class~^,~%  ~}
 144 };~2%"
 145           class (sod-class-precedence-list class)))
 146
 147 ;;;--------------------------------------------------------------------------
 148 ;;; Chain structure.
 149
 150 (define-class-slot "link" (class) (* (class "SodClass" :const))
 151   (aif (sod-class-chain-link class)
 152        (format nil "~A__class" it)
 153        0))
 154
 155 (define-class-slot "head" (class) (* (class "SodClass" :const))
 156   (format nil "~A__class" (sod-class-chain-head class)))
 157
 158 (define-class-slot "level" (class) size-t
 159   (position class (reverse (sod-class-chain class))))
 160
 161 (define-class-slot "n_chains" (class) size-t
 162   (length (sod-class-chains class)))
 163
 164 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
 165   (format nil "~A__chains" class)
 166   (let ((chains (sod-class-chains class)))
 167     (format stream "~&~:
 168 /* Chain structure. */
 169 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 170   ~{~A__class~^,~%  ~}
 171 };~:^~2%~}
 172
 173 ~0@*static const struct sod_chain ~A__chains[] = {
 174 ~:{  { ~
 175     /*           n_classes = */ ~3@*~A,
 176     /*             classes = */ ~0@*~A__chain_~A,
 177     /*          off_ichain = */ ~4@*offsetof(struct ~A, ~A),
 178     /*                  vt = */ (const struct sod_vtable *)&~A,
 179     /*            ichainsz = */ sizeof(struct ~A) }~:^,~%~}
 180 };~2%"
 181             class                       ;0
 182             (mapcar (lambda (chain)     ;1
 183                       (let* ((head (sod-class-chain-head (car chain)))
 184                              (chain-nick (sod-class-nickname head)))
 185                         (list class chain-nick                        ;0 1
 186                               (reverse chain)                         ;2
 187                               (length chain)                          ;3
 188                               (ilayout-struct-tag class) chain-nick   ;4 5
 189                               (vtable-name class head)                ;6
 190                               (ichain-struct-tag (car chain) head)))) ;7
 191                     chains))))
 192
 193 ;;;--------------------------------------------------------------------------
 194 ;;; Class-specific layout.
 195
 196 (define-class-slot "off_islots" (class) size-t
 197   (if (sod-class-slots class)
 198       (format nil "offsetof(struct ~A, ~A)"
 199               (ichain-struct-tag class (sod-class-chain-head class))
 200               (sod-class-nickname class))
 201       "0"))
 202
 203 (define-class-slot "islotsz" (class) size-t
 204   (if (sod-class-slots class)
 205       (format nil "sizeof(struct ~A)"
 206               (islots-struct-tag class))
 207       "0"))
 208
 209 ;;;--------------------------------------------------------------------------
 210 ;;; Built-in methods.
 211
 212 ;; Common protocol.
 213
 214 (defclass lifecycle-message (standard-message)
 215   ())
 216
 217 (defclass lifecycle-effective-method (standard-effective-method)
 218   ())
 219
 220 (defmethod effective-method-live-p ((method lifecycle-effective-method))
 221   t)
 222
 223 (defgeneric lifecycle-method-kernel (method codegen target)
 224   (:documentation
 225    "Compute (into CODEGEN) the class-specific part of the METHOD.
 226
 227    The result, if any, needs to find its way to the TARGET, as usual."))
 228
 229 (defmethod simple-method-body
 230     ((method lifecycle-effective-method) codegen target)
 231   (invoke-delegation-chain codegen target
 232                            (effective-method-basic-argument-names method)
 233                            (effective-method-primary-methods method)
 234                            (lambda (target)
 235                              (lifecycle-method-kernel method
 236                                                       codegen
 237                                                       target))))
 238
 239 ;; Utilities.
 240
 241 (defun declare-me (codegen class)
 242   "Emit, to CODEGEN, a declaration of `me' as a pointer to CLASS.
 243
 244    The pointer refers to a part of the prevailing `sod__obj' object, which is
 245    assumed to be a pointer to an appropriate `ilayout' structure."
 246   (emit-decl codegen (make-var-inst "me" (c-type (* (class class)))
 247                                     (format nil "&sod__obj->~A.~A"
 248                                             (sod-class-nickname
 249                                              (sod-class-chain-head class))
 250                                             (sod-class-nickname class)))))
 251
 252 (defun collect-initarg-keywords (class)
 253   "Return a list of keyword arguments corresponding to CLASS's initargs.
 254
 255    For each distinct name among the initargs defined on CLASS and its
 256    superclasses, return a single `argument' object containing the (agreed
 257    common) type, and the (unique, if present) default value from the most
 258    specific defining superclass.
 259
 260    The arguments are not returned in any especially meaningful order."
 261
 262   (let ((map (make-hash-table :test #'equal))
 263         (default-map (make-hash-table :test #'equal))
 264         (list nil))
 265     (dolist (super (sod-class-precedence-list class))
 266       (dolist (initarg (sod-class-initargs super))
 267         (let ((name (sod-initarg-name initarg))
 268               (default (sod-initarg-default initarg)))
 269           (unless (gethash name default-map)
 270             (when (or default (not (gethash name map)))
 271               (setf (gethash name map) (sod-initarg-argument initarg)))
 272             (when default
 273               (setf (gethash name default-map) t))))))
 274     (maphash (lambda (key value)
 275                (declare (ignore key))
 276                (push value list))
 277              map)
 278     list))
 279
 280 (definst suppliedp-struct (stream) (flags var)
 281   "Declare a `suppliedp' structure VAR containing a bit for each named FLAG.
 282
 283    The output looks like this:
 284
 285         struct {
 286           unsigned FLAG: 1;
 287           /* ... */
 288         } VAR;
 289
 290    Note that this will not be valid C unless there is at least one flag."
 291   (format stream
 292           "~@<struct { ~2I~_~{unsigned ~A: 1;~^ ~_~} ~I~_} ~A;~:>"
 293           flags var))
 294
 295 ;; Initialization.
 296
 297 (defclass initialization-message (lifecycle-message)
 298   ())
 299
 300 (defclass initialization-effective-method (lifecycle-effective-method)
 301   ())
 302
 303 (defmethod sod-message-effective-method-class
 304     ((message initialization-message))
 305   'initialization-effective-method)
 306
 307 (defmethod sod-message-keyword-argument-lists
 308     ((message initialization-message) (class sod-class) direct-methods state)
 309   (append (call-next-method)
 310           (mapcan (lambda (class)
 311                     (let* ((initargs (sod-class-initargs class))
 312                            (map (make-hash-table))
 313                            (arglist (mapcar
 314                                      (lambda (initarg)
 315                                        (let ((arg (sod-initarg-argument
 316                                                    initarg)))
 317                                          (setf (gethash arg map) initarg)
 318                                          arg))
 319                                      initargs)))
 320                       (and initargs
 321                            (list (cons (lambda (arg)
 322                                          (info-with-location
 323                                           (gethash arg map)
 324                                           "Type `~A' from initarg ~
 325                                            in class `~A' (here)"
 326                                           (argument-type arg) class)
 327                                          (report-inheritance-path
 328                                           state class))
 329                                        arglist)))))
 330                   (sod-class-precedence-list class))))
 331
 332 (defmethod lifecycle-method-kernel
 333     ((method initialization-effective-method) codegen target)
 334   (let* ((class (effective-method-class method))
 335          (keywords (collect-initarg-keywords class))
 336          (ilayout (sod-class-ilayout class))
 337          (obj-tag (ilayout-struct-tag class))
 338          (kw-tag (effective-method-keyword-struct-tag method))
 339          (kw-tail (and keywords
 340                        (list (make-argument
 341                               "sod__kw"
 342                               (c-type (* (struct kw-tag :const)))))))
 343          (func-type (c-type (fun void
 344                                  ("sod__obj" (* (struct obj-tag)))
 345                                  . kw-tail)))
 346          (func-name (format nil "~A__init" class))
 347          (done-setup-p nil))
 348
 349     ;; Start building the initialization function.
 350     (codegen-push codegen)
 351
 352     (labels ((set-from-initializer (var type init)
 353                ;; Store the value of INIT, which has the given TYPE, in VAR.
 354                ;; INIT has the syntax of an initializer: declare and
 355                ;; initialize a temporary, and then copy the result.
 356                ;; Compilers seem to optimize this properly.  Return the
 357                ;; resulting code as an instruction.
 358                (codegen-push codegen)
 359                (emit-decl codegen (make-var-inst *sod-tmp-val* type init))
 360                (deliver-expr codegen var *sod-tmp-val*)
 361                (codegen-pop-block codegen))
 362              (setup ()
 363                ;; Do any necessary one-time initialization required to set up
 364                ;; the environment for the initialization code.
 365                (unless done-setup-p
 366
 367                  ;; Extract the keyword arguments into local variables.
 368                  (when keywords
 369                    (emit-decl codegen
 370                               (make-suppliedp-struct-inst
 371                                (mapcar #'argument-name keywords)
 372                                "suppliedp"))
 373                    (emit-banner codegen "Collect the keyword arguments.")
 374                    (dolist (arg keywords)
 375                      (let* ((name (argument-name arg))
 376                             (type (argument-type arg))
 377                             (default (argument-default arg))
 378                             (kwvar (format nil "sod__kw->~A" name))
 379                             (kwset (make-set-inst name kwvar))
 380                             (suppliedp (format nil "suppliedp.~A" name)))
 381                        (emit-decl codegen (make-var-inst name type))
 382                        (deliver-expr codegen suppliedp
 383                                      (format nil "sod__kw->~A__suppliedp"
 384                                              name))
 385                        (emit-inst
 386                         codegen
 387                         (if default
 388                             (make-if-inst suppliedp kwset
 389                                           (set-from-initializer name
 390                                                                 type
 391                                                                 default))
 392                             kwset))))
 393
 394                    (deliver-call codegen :void
 395                                  "SOD__IGNORE" "suppliedp")
 396                    (dolist (arg keywords)
 397                      (deliver-call codegen :void
 398                                    "SOD__IGNORE" (argument-name arg))))
 399
 400                  (setf done-setup-p t))))
 401
 402       ;; Initialize the structure defined by the various superclasses, in
 403       ;; reverse precedence order.
 404       (dolist (super (reverse (sod-class-precedence-list class)))
 405         (let* ((ichain (find (sod-class-chain-head super)
 406                              (ilayout-ichains ilayout)
 407                              :key #'ichain-head))
 408                (islots (find super (ichain-body ichain)
 409                              :test (lambda (class item)
 410                                      (and (typep item 'islots)
 411                                           (eq (islots-class item) class)))))
 412                (frags (sod-class-initfrags super))
 413                (this-class-focussed-p nil)
 414                (isl (format nil "me->~A" (sod-class-nickname super))))
 415
 416           (flet ((focus-this-class ()
 417                    ;; Delayed initial preparation.  Don't bother defining the
 418                    ;; `me' pointer if there's actually nothing to do.
 419                    (setup)
 420                    (unless this-class-focussed-p
 421                      (emit-banner codegen
 422                                   "Initialization for class `~A'." super)
 423                      (codegen-push codegen)
 424                      (declare-me codegen super)
 425                      (setf this-class-focussed-p t))))
 426
 427             ;; Work through each slot in turn.
 428             (dolist (slot (and islots (islots-slots islots)))
 429               (let ((dslot (effective-slot-direct-slot slot))
 430                     (init (effective-slot-initializer slot))
 431                     (initargs (effective-slot-initargs slot)))
 432                 (when (or init initargs)
 433                   (focus-this-class)
 434                   (let* ((slot-type (sod-slot-type dslot))
 435                          (target (format nil "~A.~A"
 436                                          isl (sod-slot-name dslot)))
 437                          (initinst (and init
 438                                         (set-from-initializer
 439                                          target slot-type
 440                                          (sod-initializer-value init)))))
 441
 442                     ;; If there are applicable initialization arguments,
 443                     ;; check to see whether they were supplied.
 444                     (dolist (initarg (reverse (remove-duplicates
 445                                                initargs
 446                                                :key #'sod-initarg-name
 447                                                :test #'string=
 448                                                :from-end t)))
 449                       (let ((arg-name (sod-initarg-name initarg)))
 450                         (setf initinst (make-if-inst
 451                                         (format nil "suppliedp.~A" arg-name)
 452                                         (make-set-inst target arg-name)
 453                                         initinst))))
 454
 455                     (emit-inst codegen initinst)))))
 456
 457             ;; Emit the class's initialization fragments.
 458             (when frags
 459               (let ((used-me-p this-class-focussed-p))
 460                 (focus-this-class)
 461                 (unless used-me-p
 462                   (deliver-call codegen :void "SOD__IGNORE" "me")))
 463               (dolist (frag frags)
 464                 (codegen-push codegen)
 465                 (emit-inst codegen frag)
 466                 (emit-inst codegen (codegen-pop-block codegen))))
 467
 468             ;; If we opened a block to initialize this class then close it
 469             ;; again.
 470             (when this-class-focussed-p
 471               (emit-inst codegen (codegen-pop-block codegen)))))))
 472
 473     ;; Done making the initialization function.
 474     (codegen-pop-function codegen func-name func-type
 475                           "Instance initialization function ~:_~
 476                            for class `~A'."
 477                           class)
 478
 479     (apply #'deliver-call codegen :void func-name
 480            "sod__obj" (and keywords (list (keyword-struct-pointer))))))
 481
 482 ;; Teardown.
 483
 484 (defclass teardown-message (lifecycle-message)
 485   ())
 486
 487 (defclass teardown-effective-method (lifecycle-effective-method)
 488   ())
 489
 490 (defmethod sod-message-effective-method-class ((message teardown-message))
 491   'teardown-effective-method)
 492
 493 (defmethod lifecycle-method-kernel
 494     ((method teardown-effective-method) codegen target)
 495   (let* ((class (effective-method-class method))
 496          (obj-tag (ilayout-struct-tag class))
 497          (func-type (c-type (fun void ("sod__obj" (* (struct obj-tag))))))
 498          (func-name (format nil "~A__teardown" class)))
 499     (codegen-push codegen)
 500     (dolist (super (sod-class-precedence-list class))
 501       (let ((frags (sod-class-tearfrags super)))
 502         (when frags
 503           (emit-banner codegen "Teardown for class `~A'." super)
 504           (codegen-push codegen)
 505           (declare-me codegen super)
 506           (deliver-call codegen :void "SOD__IGNORE" "me")
 507           (dolist (frag frags)
 508             (codegen-push codegen)
 509             (emit-inst codegen frag)
 510             (emit-inst codegen (codegen-pop-block codegen)))
 511           (emit-inst codegen (codegen-pop-block codegen)))))
 512     (codegen-pop-function codegen func-name func-type
 513                           "Instance teardown function ~:_~
 514                            for class `~A'."
 515                           class)
 516     (deliver-call codegen :void
 517                   (format nil "~A__teardown" class) "sod__obj")
 518     (deliver-expr codegen target 0)))
 519
 520 ;;;--------------------------------------------------------------------------
 521 ;;; Bootstrapping the class graph.
 522
 523 (defun bootstrap-classes (module)
 524   "Bootstrap the braid in MODULE.
 525
 526    This builds the fundamental recursive braid, where `SodObject' is an
 527    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
 528    an instance of itself)."
 529   (let* ((sod-object (make-sod-class "SodObject" nil
 530                                      (make-property-set :nick 'obj
 531                                                         :%bootstrapping t)))
 532          (sod-class (make-sod-class "SodClass" (list sod-object)
 533                                     (make-property-set :nick 'cls
 534                                                        :%bootstrapping t)))
 535          (classes (list sod-object sod-class)))
 536
 537     ;; Attach the built-in messages.
 538     (make-sod-message sod-object "init"
 539                       (c-type (fun void :keys))
 540                       (make-property-set
 541                        :message-class 'initialization-message))
 542     (make-sod-message sod-object "teardown" (c-type (fun int))
 543                       (make-property-set :message-class 'teardown-message))
 544
 545     ;; Sort out the recursion.
 546     (setf (slot-value sod-class 'chain-link) sod-object)
 547     (dolist (class classes)
 548       (setf (slot-value class 'metaclass) sod-class))
 549
 550     ;; Predeclare the class types.
 551     (dolist (class classes)
 552       (make-class-type (sod-class-name class)))
 553
 554     ;; Attach the class slots.
 555     (dolist (slot *class-slot-alist*)
 556       (funcall (cdr slot) sod-class))
 557
 558     ;; These classes are too closely intertwined.  We must partially finalize
 559     ;; them together by hand.  This is cloned from `finalize-sod-class'.
 560     (dolist (class classes)
 561       (with-slots (class-precedence-list chain-head chain chains) class
 562         (setf class-precedence-list (compute-cpl class))
 563         (setf (values chain-head chain chains) (compute-chains class))))
 564
 565     ;; Done.
 566     (dolist (class classes)
 567       (unless (finalize-sod-class class)
 568         (error "Failed to finalize built-in class"))
 569       (add-to-module module class))))
 570
 571 (export '*builtin-module*)
 572 (defvar-unbound *builtin-module*
 573   "The builtin module.")
 574
 575 (export 'make-builtin-module)
 576 (defun make-builtin-module ()
 577   "Construct the builtin module.
 578
 579    This involves constructing the braid (which is done in
 580    `bootstrap-classes') and defining a few obvious type names which users
 581    will find handy.
 582
 583    Returns the newly constructed module, and stores it in the variable
 584    `*builtin-module*'."
 585   (let ((module (make-instance 'module
 586                                :name (make-pathname :name "SOD-BASE"
 587                                                     :type "SOD"
 588                                                     :case :common)
 589                                :state nil)))
 590     (with-module-environment (module)
 591       (flet ((header-name (name)
 592                (concatenate 'string "\"" (string-downcase name) ".h\""))
 593              (add-includes (reason &rest names)
 594                (let ((text (with-output-to-string (out)
 595                              (dolist (name names)
 596                                (format out "#include ~A~%" name)))))
 597                  (add-to-module module
 598                                 (make-instance 'code-fragment-item
 599                                                :reason reason
 600                                                :constraints nil
 601                                                :name :includes
 602                                                :fragment text)))))
 603         (add-includes :c (header-name "sod"))
 604         (add-includes :h "<stddef.h>"))
 605       (bootstrap-classes module))
 606     (setf *builtin-module* module)))
 607
 608 (define-clear-the-decks builtin-module
 609   (unless (boundp '*builtin-module*) (make-builtin-module)))
 610
 611 ;;;----- That's all, folks --------------------------------------------------