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 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 (define-class-slot "init" (class stream)
 116     (* (fun (* void) ("/*p*/" (* void))))
 117   (format nil "~A__init" class)
 118
 119   ;; FIXME this needs a metaobject protocol
 120   (let ((ilayout (sod-class-ilayout class))
 121         (used nil))
 122     (format stream "~&~:
 123 /* Provide initial values for an instance's slots. */
 124 static void *~A__init(void *p)~%{~%" class)
 125     (dolist (ichain (ilayout-ichains ilayout))
 126       (let ((ich (format nil "sod__obj->~A.~A"
 127                          (sod-class-nickname (ichain-head ichain))
 128                          (sod-class-nickname (ichain-tail ichain)))))
 129         (dolist (item (ichain-body ichain))
 130           (etypecase item
 131             (vtable-pointer
 132              nil)
 133             (islots
 134              (let ((isl (format nil "~A.~A"
 135                                 ich
 136                                 (sod-class-nickname (islots-class item)))))
 137                (dolist (slot (islots-slots item))
 138                  (let ((dslot (effective-slot-direct-slot slot))
 139                        (init (effective-slot-initializer slot)))
 140                    (when init
 141                      (unless used
 142                        (format stream
 143                                "  struct ~A *sod__obj = ~A__imprint(p);~2%"
 144                                (ilayout-struct-tag class) class)
 145                        (setf used t))
 146                      (format stream "  {~%    ")
 147                      (pprint-c-type (sod-slot-type dslot) stream
 148                                     *sod-tmp-val*)
 149                      (format stream " =")
 150                      (ecase (sod-initializer-value-kind init)
 151                        (:simple (write (sod-initializer-value-form init)
 152                                        :stream stream
 153                                        :pretty nil :escape nil)
 154                                 (format stream ";~%"))
 155                        (:compound (format stream " {")
 156                                   (write (sod-initializer-value-form init)
 157                                          :stream stream
 158                                          :pretty nil :escape nil)
 159                                   (format stream "    };~%")))
 160                      (format stream "    ~A.~A = ~A;~%  }~%"
 161                              isl (sod-slot-name dslot)
 162                              *sod-tmp-val*))))))))))
 163     (unless used
 164       (format stream "  ~A__imprint(p);~%" class))
 165     (format stream "~&~:
 166   return (p);
 167 }~2%")))
 168
 169 ;;;--------------------------------------------------------------------------
 170 ;;; Superclass structure.
 171
 172 (define-class-slot "n_supers" (class) size-t
 173   (length (sod-class-direct-superclasses class)))
 174
 175 (define-class-slot "supers" (class stream)
 176     (* (* (class "SodClass" :const) :const))
 177   (if (null (sod-class-direct-superclasses class)) 0
 178       (format nil "~A__supers" class))
 179   (let ((supers (sod-class-direct-superclasses class)))
 180     (when supers
 181       (format stream "~&~:
 182 /* Direct superclasses. */
 183 static const SodClass *const ~A__supers[] = {
 184   ~{~A__class~^,~%  ~}
 185 };~2%"
 186               class supers))))
 187
 188 (define-class-slot "n_cpl" (class) size-t
 189   (length (sod-class-precedence-list class)))
 190
 191 (define-class-slot "cpl" (class stream)
 192     (* (* (class "SodClass" :const) :const))
 193   (format nil "~A__cpl" class)
 194   (format stream "~&~:
 195 /* Class precedence list. */
 196 static const SodClass *const ~A__cpl[] = {
 197   ~{~A__class~^,~%  ~}
 198 };~2%"
 199           class (sod-class-precedence-list class)))
 200
 201 ;;;--------------------------------------------------------------------------
 202 ;;; Chain structure.
 203
 204 (define-class-slot "link" (class) (* (class "SodClass" :const))
 205   (aif (sod-class-chain-link class)
 206        (format nil "~A__class" it)
 207        0))
 208
 209 (define-class-slot "head" (class) (* (class "SodClass" :const))
 210   (format nil "~A__class" (sod-class-chain-head class)))
 211
 212 (define-class-slot "level" (class) size-t
 213   (position class (reverse (sod-class-chain class))))
 214
 215 (define-class-slot "n_chains" (class) size-t
 216   (length (sod-class-chains class)))
 217
 218 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
 219   (format nil "~A__chains" class)
 220   (let ((chains (sod-class-chains class)))
 221     (format stream "~&~:
 222 /* Chain structure. */
 223 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 224   ~{~A__class~^,~%  ~}
 225 };~:^~2%~}
 226
 227 ~0@*static const struct sod_chain ~A__chains[] = {
 228 ~:{  { ~
 229     /*           n_classes = */ ~3@*~A,
 230     /*             classes = */ ~0@*~A__chain_~A,
 231     /*          off_ichain = */ ~4@*offsetof(struct ~A, ~A),
 232     /*                  vt = */ (const struct sod_vtable *)&~A,
 233     /*            ichainsz = */ sizeof(struct ~A) }~:^,~%~}
 234 };~2%"
 235             class                       ;0
 236             (mapcar (lambda (chain)     ;1
 237                       (let* ((head (sod-class-chain-head (car chain)))
 238                              (chain-nick (sod-class-nickname head)))
 239                         (list class chain-nick                        ;0 1
 240                               (reverse chain)                         ;2
 241                               (length chain)                          ;3
 242                               (ilayout-struct-tag class) chain-nick   ;4 5
 243                               (vtable-name class head)                ;6
 244                               (ichain-struct-tag (car chain) head)))) ;7
 245                     chains))))
 246
 247 ;;;--------------------------------------------------------------------------
 248 ;;; Class-specific layout.
 249
 250 (define-class-slot "off_islots" (class) size-t
 251   (if (sod-class-slots class)
 252       (format nil "offsetof(struct ~A, ~A)"
 253               (ichain-struct-tag class (sod-class-chain-head class))
 254               (sod-class-nickname class))
 255       "0"))
 256
 257 (define-class-slot "islotsz" (class) size-t
 258   (if (sod-class-slots class)
 259       (format nil "sizeof(struct ~A)"
 260               (islots-struct-tag class))
 261       "0"))
 262
 263 ;;;--------------------------------------------------------------------------
 264 ;;; Bootstrapping the class graph.
 265
 266 (defun bootstrap-classes (module)
 267   "Bootstrap the braid in MODULE.
 268
 269    This builds the fundamental recursive braid, where `SodObject' is an
 270    instance of `SodClass', and `SodClass' is a subclass of `SodObject' (and
 271    an instance of itself)."
 272   (let* ((sod-object (make-sod-class "SodObject" nil
 273                                      (make-property-set :nick 'obj)))
 274          (sod-class (make-sod-class "SodClass" (list sod-object)
 275                                     (make-property-set :nick 'cls)))
 276          (classes (list sod-object sod-class)))
 277
 278     ;; Sort out the recursion.
 279     (setf (slot-value sod-class 'chain-link) sod-object)
 280     (dolist (class classes)
 281       (setf (slot-value class 'metaclass) sod-class))
 282
 283     ;; Predeclare the class types.
 284     (dolist (class classes)
 285       (make-class-type (sod-class-name class)))
 286
 287     ;; Attach the class slots.
 288     (dolist (slot *class-slot-alist*)
 289       (funcall (cdr slot) sod-class))
 290
 291     ;; These classes are too closely intertwined.  We must partially finalize
 292     ;; them together by hand.  This is cloned from `finalize-sod-class'.
 293     (dolist (class classes)
 294       (with-slots (class-precedence-list chain-head chain chains) class
 295         (setf class-precedence-list (compute-cpl class))
 296         (setf (values chain-head chain chains) (compute-chains class))))
 297
 298     ;; Done.
 299     (dolist (class classes)
 300       (finalize-sod-class class)
 301       (add-to-module module class))))
 302
 303 (export '*builtin-module*)
 304 (defvar *builtin-module* nil
 305   "The builtin module.")
 306
 307 (export 'make-builtin-module)
 308 (defun make-builtin-module ()
 309   "Construct the builtin module.
 310
 311    This involves constructing the braid (which is done in
 312    `bootstrap-classes') and defining a few obvious type names which users
 313    will find handy.
 314
 315    Returns the newly constructed module, and stores it in the variable
 316    `*builtin-module*'."
 317   (let ((module (make-instance 'module
 318                                :name (make-pathname :name "SOD-BASE"
 319                                                     :type "SOD"
 320                                                     :case :common)
 321                                :state nil)))
 322     (with-module-environment (module)
 323       (dolist (name '("va_list" "size_t" "ptrdiff_t" "wchar_t"))
 324         (add-to-module module (make-instance 'type-item :name name)))
 325       (flet ((header-name (name)
 326                (concatenate 'string "\"" (string-downcase name) ".h\""))
 327              (add-includes (reason &rest names)
 328                (let ((text (with-output-to-string (out)
 329                              (dolist (name names)
 330                                (format out "#include ~A~%" name)))))
 331                  (add-to-module module
 332                                 (make-instance 'code-fragment-item
 333                                                :reason reason
 334                                                :constraints nil
 335                                                :name :includes
 336                                                :fragment text)))))
 337         (add-includes :c (header-name "sod"))
 338         (add-includes :h "<stddef.h>"))
 339       (bootstrap-classes module))
 340     (setf *builtin-module* module)))
 341
 342 (define-clear-the-decks builtin-module
 343   (unless *builtin-module* (make-builtin-module)))
 344
 345 ;;;----- That's all, folks --------------------------------------------------