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

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Finishing touches for Sod
   4 ;;;
   5 ;;; (c) 2015 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 ;;; Debugging utilities.
  30
  31 (export '*debugout-pathname*)
  32 (defvar *debugout-pathname* #p"debugout.c")
  33
  34 (export 'test-module)
  35 (defun test-module (path reason)
  36   "Reset the translator's state, read a module from PATH and output it with
  37    REASON, returning the result as a string."
  38   (unless *builtin-module* (make-builtin-module))
  39   (clear-the-decks)
  40   (setf *module-map* (make-hash-table :test #'equal))
  41   (with-open-file (out *debugout-pathname*
  42                    :direction :output
  43                    :if-exists :supersede
  44                    :if-does-not-exist :create)
  45     (output-module (read-module path) reason out)))
  46
  47 ;;;--------------------------------------------------------------------------
  48 ;;; Calisthenics.
  49
  50 (export 'exercise)
  51 (defun exercise ()
  52   "Exercise the pieces of the metaobject protocol.
  53
  54    In some Lisps, the compiler is run the first time methods are called, to
  55    do fancy just-in-time optimization things.  This is great, only the
  56    program doesn't actually run for very long and a lot of that work is
  57    wasted because we're going to have to do it again next time the program
  58    starts.  Only, if we exercise the various methods, or at least a large
  59    fraction of them, before we dump an image, then everything will be fast.
  60
  61    That's the theory anyway.  Call this function before you dump an image and
  62    see what happens."
  63
  64   (clear-the-decks)
  65   (dolist (reason '(:h :c))
  66     (with-output-to-string (bitbucket)
  67       (output-module *builtin-module* reason bitbucket)))
  68
  69   (clear-the-decks))
  70
  71 ;;;----- That's all, folks --------------------------------------------------