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 Sensble 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 caled NAME, and will be of TYPE (which should be a type
  53    S-expression).  The slot's (static) initializer will be constructed by
  54    printing the value of INIT, which is evaluated with CLASS bound to the
  55    class object being constructed.  If any PREPARE forms are provided, then
  56    they are evaluated as a progn; they are evaluated 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 :lisp-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;~:^~%  ~}
  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                     (ilayout-ichains ilayout)))))
 110
 111 (define-class-slot "init" (class stream)
 112     (* (fun (* void) ("/*p*/" (* void))))
 113   (format nil "~A__init" class)
 114
 115   ;; FIXME this needs a metaobject protocol
 116   (let ((ilayout (sod-class-ilayout class)))
 117     (format stream "~&~:
 118 static void *~A__init(void *p)
 119 {
 120   struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
 121             class
 122             (ilayout-struct-tag class))
 123     (dolist (ichain (ilayout-ichains ilayout))
 124       (let ((ich (format nil "sod__obj.~A.~A"
 125                          (sod-class-nickname (ichain-head ichain))
 126                          (sod-class-nickname (ichain-tail ichain)))))
 127         (dolist (item (ichain-body ichain))
 128           (etypecase item
 129             (vtable-pointer
 130              nil)
 131             (islots
 132              (let ((isl (format nil "~A.~A"
 133                                 ich
 134                                 (sod-class-nickname (islots-class item)))))
 135                (dolist (slot (islots-slots item))
 136                  (let ((dslot (effective-slot-direct-slot slot))
 137                        (init (effective-slot-initializer slot)))
 138                    (when init
 139                      (format stream "  ~A.~A =" isl
 140                              (sod-slot-name dslot))
 141                      (ecase (sod-initializer-value-kind init)
 142                        (:simple (write (sod-initializer-value-form init)
 143                                        :stream stream
 144                                        :pretty nil :escape nil)
 145                                 (format stream ";~%"))
 146                        (:compound (format stream " (~A) {"
 147                                           (sod-slot-type dslot))
 148                                   (write (sod-initializer-value-form init)
 149                                          :stream stream
 150                                          :pretty nil :escape nil)
 151                                   (format stream "};~%"))))))))))))
 152     (format stream "~&~:
 153   return (p);
 154 }~2%")))
 155
 156 ;;;--------------------------------------------------------------------------
 157 ;;; Superclass structure.
 158
 159 (define-class-slot "n_supers" (class) size-t
 160   (length (sod-class-direct-superclasses class)))
 161
 162 (define-class-slot "supers" (class stream)
 163     (* (* (class "SodClass" :const) :const))
 164   (if (null (sod-class-direct-superclasses class)) 0
 165       (format nil "~A__supers" class))
 166   (let ((supers (sod-class-direct-superclasses class)))
 167     (when supers
 168       (format stream "~&~:
 169 /* Direct superclasses. */
 170 static const SodClass *const ~A__supers[] = {
 171   ~{~A__class~^,~%  ~}
 172 };~2%"
 173               class supers))))
 174
 175 (define-class-slot "n_cpl" (class) size-t
 176   (length (sod-class-precedence-list class)))
 177
 178 (define-class-slot "cpl" (class stream)
 179     (* (* (class "SodClass" :const) :const))
 180   (format nil "~A__cpl" class)
 181   (format stream "~&~:
 182 /* Class precedence list. */
 183 static const SodClass *const ~A__cpl[] = {
 184   ~{~A__class~^,~%  ~}
 185 };~2%"
 186           class (sod-class-precedence-list class)))
 187
 188 ;;;--------------------------------------------------------------------------
 189 ;;; Chain structure.
 190
 191 (define-class-slot "link" (class) (* (class "SodClass" :const))
 192   (aif (sod-class-chain-link class)
 193        (format nil "~A__class" it)
 194        0))
 195
 196 (define-class-slot "head" (class) (* (class "SodClass" :const))
 197   (format nil "~A__class" (sod-class-chain-head class)))
 198
 199 (define-class-slot "level" (class) size-t
 200   (position class (reverse (sod-class-chain class))))
 201
 202 (define-class-slot "n_chains" (class) size-t
 203   (length (sod-class-chains class)))
 204
 205 (define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
 206   (format nil "~A__chains" class)
 207   (let ((chains (sod-class-chains class)))
 208     (format stream "~&~:
 209 /* Chain structure. */
 210 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 211   ~{~A__class~^,~%  ~}
 212 };~:^~2%~}
 213
 214 ~0@*static const struct sod_chain ~A__chains[] = {
 215 ~:{  { ~3@*~A,
 216     ~0@*&~A__chain_~A,
 217     ~4@*offsetof(struct ~A, ~A),
 218     (const struct sod_vtable *)&~A,
 219     sizeof(struct ~A) }~:^,~%~}
 220 };~2%"
 221             class                       ;0
 222             (mapcar (lambda (chain)     ;1
 223                       (let* ((head (sod-class-chain-head (car chain)))
 224                              (chain-nick (sod-class-nickname head)))
 225                         (list class chain-nick                      ;0 1
 226                               (reverse chain)                       ;2
 227                               (length chain)                        ;3
 228                               (ilayout-struct-tag class) chain-nick ;4 5
 229                               (vtable-name class head)              ;6
 230                               (ichain-struct-tag class head))))     ;7
 231                     chains))))
 232
 233 ;;;--------------------------------------------------------------------------
 234 ;;; Class-specific layout.
 235
 236 (define-class-slot "off_islots" (class) size-t
 237   (format nil "offsetof(struct ~A, ~A)"
 238           (ichain-struct-tag class (sod-class-chain-head class))
 239           (sod-class-nickname class)))
 240
 241 (define-class-slot "islotsz" (class) size-t
 242   (format nil "sizeof(struct ~A)"
 243           (islots-struct-tag class)))
 244
 245 ;;;--------------------------------------------------------------------------
 246 ;;; Bootstrapping the class graph.
 247
 248 (defun bootstrap-classes (module)
 249   (let* ((sod-object (make-sod-class "SodObject" nil
 250                                      (make-property-set :nick 'obj)))
 251          (sod-class (make-sod-class "SodClass" (list sod-object)
 252                                     (make-property-set :nick 'cls)))
 253          (classes (list sod-object sod-class)))
 254
 255     ;; Sort out the recursion.
 256     (setf (slot-value sod-class 'chain-link) sod-object)
 257     (dolist (class classes)
 258       (setf (slot-value class 'metaclass) sod-class))
 259
 260     ;; Predeclare the class types.
 261     (dolist (class classes)
 262       (make-class-type (sod-class-name class)))
 263
 264     ;; Attach the class slots.
 265     (dolist (slot *class-slot-alist*)
 266       (funcall (cdr slot) sod-class))
 267
 268     ;; These classes are too closely intertwined.  We must partially finalize
 269     ;; them together by hand.  This is cloned from `finalize-sod-class'.
 270     (dolist (class classes)
 271       (with-slots (class-precedence-list chain-head chain chains) class
 272         (setf class-precedence-list (compute-cpl class))
 273         (setf (values chain-head chain chains) (compute-chains class))))
 274
 275     ;; Done.
 276     (dolist (class classes)
 277       (finalize-sod-class class)
 278       (add-to-module module class))))
 279
 280 (defun make-builtin-module ()
 281   (let ((module (make-instance 'module
 282                                :name (make-pathname :name "SOD-BASE"
 283                                                     :type "SOD"
 284                                                     :case :common)
 285                                :state nil))
 286         (include (format nil "#include \"~A\"~%"
 287                          (make-pathname :name "SOD" :type "H"
 288                                         :case :common))))
 289     (call-with-module-environment
 290      (lambda ()
 291        (dolist (name '("va_list" "size_t" "ptrdiff_t"))
 292          (add-to-module module (make-instance 'type-item :name name)))
 293        (add-to-module module (make-instance 'code-fragment-item
 294                                             :reason :c
 295                                             :constraints nil
 296                                             :name :includes
 297                                             :fragment include))
 298        (bootstrap-classes module)))
 299     module))
 300
 301 (defvar *builtin-module* nil)
 302
 303 (define-clear-the-decks reset-builtin-module
 304   (setf *builtin-module* (make-builtin-module)))
 305
 306 ;;;----- That's all, folks --------------------------------------------------