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