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