mdw@git.distorted.org.uk Git - sod/blob - builtin.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Builtin module provides basic definitions
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  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 ;;; Output of class instances.
  30
  31 (defun output-imprint-function (class stream)
  32   (let ((ilayout (sod-class-ilayout class)))
  33     (format stream "~&~:
  34 /* Imprint raw memory with instance structure. */
  35 static void *~A__imprint(void *p)
  36 {
  37   struct ~A *sod__obj = p;
  38
  39   ~:{sod__obj.~A.~A._vt = &~A;~:^~%  ~}
  40   return (p);
  41 }~2%"
  42             class
  43             (ilayout-struct-tag class)
  44             (mapcar (lambda (ichain)
  45                       (let* ((head (ichain-head ichain))
  46                              (tail (ichain-tail ichain)))
  47                         (list (sod-class-nickname head)
  48                               (sod-class-nickname tail)
  49                               (vtable-name class head))))
  50                     (ilayout-ichains ilayout)))))
  51
  52 (defun output-init-function (class stream)
  53   ;; FIXME this needs a metaobject protocol
  54   (let ((ilayout (sod-class-ilayout class)))
  55     (format stream "~&~:
  56 static void *~A__init(void *p)
  57 {
  58   struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
  59             class
  60             (ilayout-struct-tag class))
  61     (dolist (ichain (ilayout-ichains ilayout))
  62       (let ((ich (format nil "sod__obj.~A.~A"
  63                          (sod-class-nickname (ichain-head ichain))
  64                          (sod-class-nickname (ichain-tail ichain)))))
  65         (dolist (item (ichain-body ichain))
  66           (etypecase item
  67             (vtable-pointer
  68              nil)
  69             (islots
  70              (let ((isl (format nil "~A.~A"
  71                                 ich
  72                                 (sod-class-nickname (islots-class item)))))
  73                (dolist (slot (islots-slots item))
  74                  (let ((dslot (effective-slot-direct-slot slot))
  75                        (init (effective-slot-initializer slot)))
  76                    (when init
  77                      (format stream "  ~A =" isl)
  78                      (ecase (sod-initializer-value-kind init)
  79                        (:simple (write (sod-initializer-value-form init)
  80                                        :stream stream
  81                                        :pretty nil :escape nil)
  82                                 (format stream ";~%"))
  83                        (:compound (format stream " (~A) {"
  84                                           (sod-slot-type dslot))
  85                                   (write (sod-initializer-value-form init)
  86                                          :stream stream
  87                                          :pretty nil :escape nil)
  88                                   (format stream "};~%"))))))))))))
  89     (format stream "~&~:
  90   return (p);
  91 }~2%")))
  92
  93 (defun output-supers-vector (class stream)
  94   (let ((supers (sod-class-direct-superclasses class)))
  95     (when supers
  96       (format stream "~&~:
  97 /* Direct superclasses. */
  98 static const SodClass *const ~A__supers[] = {
  99   ~{~A__class~^,~%  ~}
 100 };~2%"
 101               class supers))))
 102
 103 (defun output-cpl-vector (class stream)
 104   (format stream "~&~:
 105 /* Class precedence list. */
 106 static const SodClass *const ~A__cpl[] = {
 107   ~{~A__class~^,~%  ~}
 108 };~2%"
 109           class (sod-class-precedence-list class)))
 110
 111 (defun output-chains-vector (class stream)
 112   (let ((chains (sod-class-chains class)))
 113     (format stream "~&~:
 114 /* Chain structure. */
 115 ~1@*~:{static const SodClass *const ~A__chain_~A[] = {
 116   ~{~A__class~^,~%  ~}
 117 };~:^~2%~}
 118
 119 ~0@*static const struct sod_chain ~A__chains[] = {
 120 ~:{  { ~3@*~A,
 121     ~0@*&~A__chain_~A,
 122     ~4@*offsetof(struct ~A, ~A),
 123     (const struct sod_vtable *)&~A,
 124     sizeof(struct ~A) }~:^,~%~}
 125 };~2%"
 126             class                       ;0
 127             (mapcar (lambda (chain)     ;1
 128                       (let* ((head (sod-class-chain-head (car chain)))
 129                              (chain-nick (sod-class-nickname head)))
 130                         (list class chain-nick                      ;0 1
 131                               (reverse chain)                       ;2
 132                               (length chain)                        ;3
 133                               (ilayout-struct-tag class) chain-nick ;4 5
 134                               (vtable-name class head)              ;6
 135                               (ichain-struct-tag class head))))     ;7
 136                     chains))))
 137
 138 (defclass sod-class-slot (sod-slot)
 139   ((initializer-function :initarg :initializer-function
 140                          :type (or symbol function)
 141                          :reader sod-slot-initializer-function)
 142    (prepare-function :initarg :prepare-function :type (or symbol function)
 143                      :reader sod-slot-prepare-function))
 144   (:documentation
 145    "Special class for slots defined on SodClass.
 146
 147    These slots need class-specific initialization.  It's easier to keep all
 148    of the information (name, type, and how to initialize them) about these
 149    slots in one place, so that's what we do here."))
 150
 151 (defclass sod-magic-class-initializer (sod-class-initializer)
 152   ((initializer-function :initarg :initializer-function
 153                          :type (or symbol function)
 154                          :reader sod-initializer-function)
 155    (prepare-function  :initarg :prepare-function
 156                       :type (or symbol function)
 157                       :reader sod-initializer-prepare-function)))
 158
 159 (defmethod shared-initialize :after
 160     ((slot sod-class-slot) slot-names &key pset)
 161   (declare (ignore slot-names))
 162   (default-slot (slot 'initializer-function)
 163     (get-property pset :initializer-function t nil))
 164   (default-slot (slot 'prepare-function)
 165     (get-property pset :prepare-function t nil)))
 166
 167 (defclass sod-class-effective-slot (effective-slot)
 168   ((initializer-function :initarg :initializer-function
 169                          :type (or symbol function)
 170                          :reader effective-slot-initializer-function)
 171    (prepare-function :initarg :prepare-function :type (or symbol function)
 172                      :reader effective-slot-prepare-function))
 173   (:documentation
 174    "Special class for slots defined on SodClass.
 175
 176    This class ignores any explicit initializers and computes initializer
 177    values using the slot's INIT-FUNC slot and a magical protocol during
 178    metaclass instance construction."))
 179
 180 (defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
 181   (make-instance 'sod-class-effective-slot
 182                  :class class :slot slot
 183                  :initializer-function (sod-slot-initializer-function slot)
 184                  :prepare-function (sod-slot-prepare-function slot)
 185                  :initializer (find-slot-initializer class slot)))
 186
 187 ;;;--------------------------------------------------------------------------
 188 ;;; Class slots table.
 189
 190 (defparameter *sod-class-slots*
 191   `(
 192
 193     ;; Basic informtion.
 194     ("name" ,(c-type const-string)
 195             :initializer-function
 196             ,(lambda (class)
 197                (prin1-to-string (sod-class-name class))))
 198     ("nick" ,(c-type const-string)
 199             :initializer-function
 200             ,(lambda (class)
 201                (prin1-to-string (sod-class-nickname class))))
 202
 203     ;; Instance allocation and initialization.
 204     ("instsz" ,(c-type size-t)
 205               :initializer-function
 206               ,(lambda (class)
 207                  (format nil "sizeof(struct ~A)"
 208                          (ilayout-struct-tag class))))
 209     ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
 210                :prepare-function output-imprint-function
 211                :initializer-function
 212                ,(lambda (class)
 213                   (format nil "~A__imprint" class)))
 214     ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
 215             :prepare-function output-init-function
 216             :initializer-function
 217             ,(lambda (class)
 218                (format nil "~A__init" class)))
 219
 220     ;; Superclass structure.
 221     ("n_supers" ,(c-type size-t)
 222                 :initializer-function
 223                 ,(lambda (class)
 224                    (length (sod-class-direct-superclasses class))))
 225     ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
 226               :prepare-function output-supers-vector
 227               :initializer-function
 228               ,(lambda (class)
 229                  (if (sod-class-direct-superclasses class)
 230                      (format nil "~A__supers" class)
 231                      0)))
 232     ("n_cpl" ,(c-type size-t)
 233              :initializer-function
 234                 ,(lambda (class)
 235                    (length (sod-class-precedence-list class))))
 236     ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
 237            :prepare-function output-cpl-vector
 238            :initializer-function
 239            ,(lambda (class)
 240               (format nil "~A__cpl" class)))
 241
 242     ;; Chain structure.
 243     ("link" ,(c-type (* (class "SodClass" :const)))
 244             :initializer-function
 245             ,(lambda (class)
 246                (let ((link (sod-class-chain-link class)))
 247                  (if link
 248                      (format nil "~A__class" link)
 249                      0))))
 250     ("head" ,(c-type (* (class "SodClass" :const)))
 251             :initializer-function
 252             ,(lambda (class)
 253                (format nil "~A__class" (sod-class-chain-head class))))
 254     ("level" ,(c-type size-t)
 255              :initializer-function
 256              ,(lambda (class)
 257                 (position class (reverse (sod-class-chain class)))))
 258     ("n_chains" ,(c-type size-t)
 259                 :initializer-function
 260                 ,(lambda (class)
 261                    (length (sod-class-chains class))))
 262     ("chains" ,(c-type (* (struct "sod_chain" :const)))
 263               :prepare-function output-chains-vector
 264               :initializer-function
 265               ,(lambda (class)
 266                  (format nil "~A__chains" class)))
 267
 268     ;; Class-specific layout.
 269     ("off_islots" ,(c-type size-t)
 270                   :initializer-function
 271                   ,(lambda (class)
 272                      (format nil "offsetof(struct ~A, ~A)"
 273                              (ichain-struct-tag class
 274                                                 (sod-class-chain-head class))
 275                              (sod-class-nickname class))))
 276     ("islotsz" ,(c-type size-t)
 277                :initializer-function
 278                ,(lambda (class)
 279                   (format nil "sizeof(struct ~A)"
 280                           (islots-struct-tag class))))))
 281
 282 ;;;--------------------------------------------------------------------------
 283 ;;; Bootstrapping the class graph.
 284
 285 (defun bootstrap-classes (module)
 286   (let* ((sod-object (make-sod-class "SodObject" nil
 287                                      (make-property-set :nick 'obj)))
 288          (sod-class (make-sod-class "SodClass" (list sod-object)
 289                                     (make-property-set :nick 'cls)))
 290          (classes (list sod-object sod-class)))
 291
 292     ;; Sort out the recursion.
 293     (setf (slot-value sod-class 'chain-link) sod-object)
 294     (dolist (class classes)
 295       (setf (slot-value class 'metaclass) sod-class))
 296
 297     ;; Predeclare the class types.
 298     (dolist (class classes)
 299       (make-class-type (sod-class-name class)))
 300
 301     ;; Attach the class slots.
 302     (loop for (name type . plist) in *sod-class-slots*
 303           do (make-sod-slot sod-class name type
 304                             (apply #'make-property-set
 305                                    :lisp-class 'sod-class-slot
 306                                    plist)))
 307
 308     ;; These classes are too closely intertwined.  We must partially finalize
 309     ;; them together by hand.  This is cloned from FINALIZE-SOD-CLASS.
 310     (dolist (class classes)
 311       (with-slots (class-precedence-list chain-head chain chains) class
 312         (setf class-precedence-list (compute-cpl class))
 313         (setf (values chain-head chain chains) (compute-chains class))))
 314
 315     ;; Done.
 316     (dolist (class classes)
 317       (finalize-sod-class class)
 318       (add-to-module module class))))
 319
 320 (defun make-builtin-module ()
 321   (let ((module (make-instance 'module
 322                                :name (make-pathname :name "SOD-BASE"
 323                                                     :type "SOD"
 324                                                     :case :common)
 325                                :state nil))
 326         (*type-map* (make-hash-table :test #'equal)))
 327     (dolist (name '("va_list" "size_t" "ptrdiff_t"))
 328       (add-to-module module (make-instance 'type-item :name name)))
 329     (bootstrap-classes module)
 330     module))
 331
 332 (defun reset-builtin-module ()
 333   (setf *builtin-module* (make-builtin-module))
 334   (module-import *builtin-module*))
 335
 336 ;;;--------------------------------------------------------------------------
 337 ;;; Testing.
 338
 339 #+test
 340 (define-sod-class "AbstractStack" ("SodObject")
 341   :nick 'abstk
 342   (message "emptyp" (fun int))
 343   (message "push" (fun void ("item" (* void))))
 344   (message "pop" (fun (* void)))
 345   (method "abstk" "pop" (fun void) #{
 346      assert(!me->_vt.emptyp());
 347    }
 348    :role :before))
 349
 350 ;;;----- That's all, folks --------------------------------------------------