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