chiark - git - mdw - sod/blob - output.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Output driver for SOD translator
   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 ;;; Sequencing machinery.
  30
  31 (defclass sequencer-item ()
  32   ((name :initarg :name :reader sequencer-item-name)
  33    (functions :initarg :functions :initform nil
  34               :type list :accessor sequencer-item-functions))
  35   (:documentation
  36    "Represents a distinct item to be sequenced by a SEQUENCER.
  37
  38    A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
  39    sequencer is invoked.  This class is not intended to be subclassed."))
  40
  41 (defmethod print-object ((item sequencer-item) stream)
  42   (print-unreadable-object (item stream :type t)
  43     (prin1 (sequencer-item-name item) stream)))
  44
  45 (defclass sequencer ()
  46   ((constraints :initarg :constraints :initform nil
  47                 :type list :accessor sequencer-constraints)
  48    (table :initform (make-hash-table :test #'equal)
  49           :reader sequencer-table))
  50   (:documentation
  51    "A sequencer tracks items and invokes them in the proper order.
  52
  53    The job of a SEQUENCER object is threefold.  Firstly, it collects
  54    sequencer items and stores them in its table indexed by name.  Secondly,
  55    it gathers CONSTRAINTS, which impose an ordering on the items.  Thirdly,
  56    it can be instructed to invoke the items in an order compatible with the
  57    established constraints.
  58
  59    Sequencer item names may may any kind of object which can be compared with
  60    EQUAL.  In particular, symbols, integers and strings are reasonable
  61    choices for atomic names, and lists work well for compound names -- so
  62    it's possible to construct a hierarchy."))
  63
  64 (defgeneric ensure-sequencer-item (sequencer name)
  65   (:documentation
  66    "Arrange that SEQUENCER has a sequencer-item called NAME.
  67
  68    Returns the corresponding SEQUENCER-ITEM object."))
  69
  70 (defgeneric add-sequencer-constraint (sequencer constraint)
  71   (:documentation
  72    "Attach the given CONSTRAINT to an SEQUENCER.
  73
  74    The CONSTRAINT should be a list of sequencer-item names; see
  75    ENSURE-SEQUENCER-ITEM for what they look like.  Note that the names
  76    needn't have been declared in advance; indeed, they needn't be mentioned
  77    anywhere else at all."))
  78
  79 (defgeneric add-sequencer-item-function (sequencer name function)
  80   (:documentation
  81    "Arranges to call FUNCTION when the item called NAME is traversed.
  82
  83    More than one function can be associated with a given sequencer item.
  84    They are called in the same order in which they were added.
  85
  86    Note that an item must be mentioned in at least one constraint in order to
  87    be traversed by INVOKE-SEQUENCER-ITEMS.  If there are no special ordering
  88    requirments for a particular item, then the trivial constraint (NAME) will
  89    suffice."))
  90
  91 (defgeneric invoke-sequencer-items (sequencer &rest arguments)
  92   (:documentation
  93    "Invoke functions attached to the SEQUENCER's items in the right order.
  94
  95    Each function is invoked in turn with the list of ARGUMENTS.  The return
  96    values of the functions are discarded."))
  97
  98 (defmethod ensure-sequencer-item ((sequencer sequencer) name)
  99   (with-slots (table) sequencer
 100     (or (gethash name table)
 101         (setf (gethash name table)
 102               (make-instance 'sequencer-item :name name)))))
 103
 104 (defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
 105   (let ((converted-constraint (mapcar (lambda (name)
 106                                         (ensure-sequencer-item sequencer
 107                                                                name))
 108                                       constraint)))
 109     (with-slots (constraints) sequencer
 110       (pushnew converted-constraint constraints :test #'equal))))
 111
 112 (defmethod add-sequencer-item-function ((sequencer sequencer) name function)
 113   (let ((item (ensure-sequencer-item sequencer name)))
 114     (pushnew function (sequencer-item-functions item))))
 115
 116 (defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
 117   (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
 118     (dolist (function (reverse (sequencer-item-functions item)))
 119       (apply function arguments))))
 120
 121 ;;;--------------------------------------------------------------------------
 122 ;;; Output preparation.
 123
 124 (defgeneric add-output-hooks (object reason sequencer)
 125   (:documentation
 126    "Announces the intention to write SEQUENCER, with a particular REASON.
 127
 128    The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
 129    can be matched using an EQL-specializer.  In response, OBJECT should add
 130    any constrains and item functions that it wishes, and pass the
 131    announcement to its sub-objects.")
 132   (:method-combination progn)
 133   (:method progn (object reason sequencer)
 134     nil))
 135
 136 (defvar *seen-announcement*)            ;Keep me unbound!
 137 #+hmm
 138 (defmethod add-output-hooks :around (object reason sequencer &rest stuff)
 139   "Arrange not to invoke any object more than once during a particular
 140    announcement."
 141   (declare (ignore stuff))
 142   (cond ((not (boundp '*seen-announcement*))
 143          (let ((*seen-announcement* (make-hash-table)))
 144            (setf (gethash object *seen-announcement*) t)
 145            (call-next-method)))
 146         ((gethash object *seen-announcement*)
 147          nil)
 148         (t
 149          (setf (gethash object *seen-announcement*) t)
 150          (call-next-method))))
 151
 152 ;;;--------------------------------------------------------------------------
 153 ;;; Utilities.
 154
 155 ;;;--------------------------------------------------------------------------
 156 ;;; Header output.
 157
 158 (defun write-module-header (module)
 159   (let* ((file (merge-pathnames (make-pathname :type "H" :case :common)
 160                                 (module-name module)))
 161          (fakename (make-pathname :name (pathname-name file)
 162                                   :type (pathname-type file))))
 163     (with-open-file (uoutput file
 164                              :direction :output
 165                              :if-exists :supersede
 166                              :if-does-not-exist :create)
 167       (let ((output (make-instance 'position-aware-output-stream
 168                                    :stream uoutput
 169                                    :file fakename)))
 170
 171         ;; Format the header and guards.
 172         (format output "~
 173 /* -*-c-*-
 174  *
 175  * Header file generated by SOD for ~A
 176  */
 177
 178 #ifndef ~A
 179 #define ~:*~A
 180
 181 #ifdef __cplusplus
 182   extern \"C\" {
 183 #endif~%"
 184                 (namestring (module-name module))
 185                 (or (getf (module-plist module) 'include-guard)
 186                     ))
 187
 188           ;; Forward declarations of all the structures and types.  Nothing
 189           ;; interesting gets said here; this is just so that the user code
 190           ;; can talk meainingfully about the things we're meant to be
 191           ;; defining here.
 192           ;;
 193           ;; FIXME
 194
 195           ;; The user fragments.
 196           (when (module-header-fragments module)
 197             (banner "User code" output)
 198             (dolist (frag (module-header-fragments module))
 199               (princ frag output)))
 200
 201           ;; The definitions of the necessary structures.
 202           ;;
 203           ;; FIXME
 204
 205           ;; The definitions of the necessary direct-methods.
 206           ;;
 207           ;; FIXME
 208
 209           ;; The trailer section.
 210           (banner "That's all, folks" output)
 211           (format output "~
 212 #ifdef __cplusplus
 213   }
 214 #endif
 215
 216 #endif~%")))))
 217
 218 ;;;--------------------------------------------------------------------------
 219 ;;; Source output.
 220
 221 (defun write-module-source (module)
 222   (let* ((file (merge-pathnames (make-pathname :type "C" :case :common)
 223                                 (module-name module)))
 224          (fakename (make-pathname :name (pathname-name file)
 225                                   :type (pathname-type file))))
 226     (with-open-file (uoutput file
 227                              :direction :output
 228                              :if-exists :supersede
 229                              :if-does-not-exist :create)
 230       (let ((output (make-instance 'position-aware-output-stream
 231                                    :stream uoutput
 232                                    :file fakename)))
 233
 234         ;; Format the header.
 235         (format output "~
 236 /* -*-c-*-
 237  *
 238  * Source file generated by SOD for ~A
 239  */~%"
 240                 (namestring (module-name module)))
 241
 242           ;; The user fragments.
 243           (when (module-source-fragments module)
 244             (banner "User code" output)
 245             (dolist (frag (module-source-fragments module))
 246               (princ frag output)))
 247
 248           ;; The definitions of the necessary tables.
 249           ;;
 250           ;; FIXME
 251
 252           ;; The definitions of the necessary effective-methods.
 253           ;;
 254           ;; FIXME
 255
 256           ;; The trailer section.
 257           (banner "That's all, folks" output :blank-line-p nil)))))
 258
 259 ;;;----- That's all, folks --------------------------------------------------