chiark - git - mdw - 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 Sensible 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 ;;; Miscellaneous details.
  30
  31 (export '*sod-version*)
  32 (defparameter *sod-version* sod-sysdef:*version*
  33   "The version of the SOD translator system, as a string.")
  34
  35 ;;;--------------------------------------------------------------------------
  36 ;;; Debugging utilities.
  37
  38 (export '*debugout-pathname*)
  39 (defvar *debugout-pathname* #p"debugout.c")
  40
  41 (export 'test-module)
  42 (defun test-module (path reason)
  43   "Reset the translator's state, read a module from PATH and output it with
  44    REASON, returning the result as a string."
  45   (clear-the-decks)
  46   (setf *module-map* (make-hash-table :test #'equal))
  47   (with-open-file (out *debugout-pathname*
  48                    :direction :output
  49                    :if-exists :supersede
  50                    :if-does-not-exist :create)
  51     (output-module (read-module path) reason out)))
  52
  53 (export 'test-parse-c-type)
  54 (defun test-parse-c-type (string)
  55   "Parse STRING as a C type, with optional kernel, and show the results."
  56   (with-input-from-string (in string)
  57     (let* ((*module-type-map* (make-hash-table))
  58            (charscan (make-instance 'charbuf-scanner
  59                                     :stream in
  60                                     :filename "<string>"))
  61            (tokscan (make-instance 'sod-token-scanner
  62                                    :char-scanner charscan
  63                                    :filename "<string>")))
  64       (with-parser-context (token-scanner-context :scanner tokscan)
  65         (multiple-value-bind (value winp consumedp)
  66             (parse (seq ((decls (parse-c-type tokscan))
  67                          (type (parse-declarator tokscan decls :abstractp t))
  68                          :eof)
  69                      type))
  70           (declare (ignore consumedp))
  71           (if winp
  72               (values t (car value) (cdr value)
  73                       (princ-to-string (car value)))
  74               (values nil value)))))))
  75
  76 (export 'test-parser)
  77 (defmacro test-parser ((scanner &key) parser input)
  78   "Convenient macro for testing parsers at the REPL.
  79
  80    This is a macro so that the parser can use the fancy syntax.  The name
  81    SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT
  82    string.  Then the PARSER is invoked and three values are returned: a
  83    `successp' flag indicating whether the parser succeeded; the result,
  84    output or error indicator, of the parser; and a list consisting of the
  85    lookahead token type and value, and a string containing the untokenized
  86    remaining input."
  87   (once-only (input)
  88     (with-gensyms (char-scanner value winp consumedp where)
  89       `(let* ((,char-scanner (make-string-scanner ,input))
  90               (,scanner (make-instance 'sod-token-scanner
  91                                        :char-scanner ,char-scanner
  92                                        :filename "<test-input>")))
  93          (with-parser-context (token-scanner-context :scanner ,scanner)
  94            (multiple-value-bind (,value ,winp ,consumedp) (parse ,parser)
  95              (declare (ignore ,consumedp))
  96              (let ((,where (scanner-capture-place ,char-scanner)))
  97                (values ,winp ,value
  98                        (list (token-type ,scanner) (token-value ,scanner)
  99                              (subseq ,input ,where))))))))))
 100
 101 ;;;--------------------------------------------------------------------------
 102 ;;; Calisthenics.
 103
 104 (export 'exercise)
 105 (defun exercise ()
 106   "Exercise the pieces of the metaobject protocol.
 107
 108    In some Lisps, the compiler is run the first time methods are called, to
 109    do fancy just-in-time optimization things.  This is great, only the
 110    program doesn't actually run for very long and a lot of that work is
 111    wasted because we're going to have to do it again next time the program
 112    starts.  Only, if we exercise the various methods, or at least a large
 113    fraction of them, before we dump an image, then everything will be fast.
 114
 115    That's the theory anyway.  Call this function before you dump an image and
 116    see what happens."
 117
 118   (clear-the-decks)
 119   (dolist (reason '(:h :c))
 120     (with-output-to-string (bitbucket)
 121       (output-module *builtin-module* reason bitbucket)))
 122
 123   (clear-the-decks))
 124
 125 ;;;----- That's all, folks --------------------------------------------------