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 &key reason clear backtrace)
  43   "Read a module from PATH, to exercise the machinery.
  44
  45    If CLEAR is non-nil, then reset the translator's state before proceeding.
  46
  47    If REASON is non-nil, then output the module to `*debugout-pathname*' with
  48    that REASON.
  49
  50    Return a two-element list (NERROR NWARNING) of the number of errors and
  51    warnings encountered while processing the module."
  52   (when clear (clear-the-decks))
  53   (multiple-value-bind (module nerror nwarning)
  54       (if backtrace (read-module path)
  55           (count-and-report-errors () (read-module path)))
  56     (when (and module reason)
  57       (with-open-file (out *debugout-pathname*
  58                        :direction :output
  59                        :if-exists :supersede
  60                        :if-does-not-exist :create)
  61         (output-module module reason out)))
  62     (list nerror nwarning)))
  63
  64 (defmacro with-test-scanner ((scanner string) &body body)
  65   "Common machinery for `test-parse-MUMBLE' below.
  66
  67    This is too specialized to make more widely available."
  68   (with-gensyms (in charscan)
  69     (once-only (string)
  70       `(with-input-from-string (,in ,string)
  71          (let* ((*module-type-map* (make-hash-table))
  72                 (,charscan (make-instance 'charbuf-scanner
  73                                           :stream ,in
  74                                           :filename "<string>"))
  75                 (,scanner (make-instance 'sod-token-scanner
  76                                          :char-scanner ,charscan
  77                                          :filename "<string>")))
  78            (with-parser-context (token-scanner-context :scanner ,scanner)
  79              ,@body))))))
  80
  81 (export 'test-parse-c-type)
  82 (defun test-parse-c-type (string)
  83   "Parse STRING as a C type, with optional kernel, and show the results."
  84   (with-test-scanner (scanner string)
  85     (multiple-value-bind (value winp consumedp)
  86         (parse (seq ((decls (parse-c-type scanner))
  87                      (type (parse-declarator scanner decls :abstractp t))
  88                      :eof)
  89                     type))
  90       (declare (ignore consumedp))
  91       (if winp
  92           (values t (car value) (cdr value)
  93                   (princ-to-string (car value)))
  94           (values nil value)))))
  95
  96 (export 'test-parse-pset)
  97 (defun test-parse-pset (string)
  98   "Parse STRING as a property set, and show the results."
  99   (with-test-scanner (scanner string)
 100     (multiple-value-bind (value winp consumedp)
 101         (parse-property-set scanner)
 102       (declare (ignore consumedp))
 103       (values winp value))))
 104
 105 (export 'test-parser)
 106 (defmacro test-parser ((scanner &key backtrace) parser input)
 107   "Convenient macro for testing parsers at the REPL.
 108
 109    This is a macro so that the parser can use the fancy syntax.  The name
 110    SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT
 111    string.  Then the PARSER is invoked and three values are returned: the
 112    result of the parse, or `nil' if the main parse failed; a list containing
 113    the number of errors and warnings (respectively) reported during the
 114    parse; and a list consisting of the lookahead token type and value, and a
 115    string containing the untokenized remaining input.
 116
 117    If BACKTRACE is nil (the default) then leave errors to the calling
 118    environment to sort out (e.g., by entering the Lisp debugger); otherwise,
 119    catch and report them as they happen so that you can test error recovery
 120    strategies."
 121   (once-only (input)
 122     (with-gensyms (char-scanner value winp body consumedp where nerror nwarn)
 123       `(let ((,char-scanner nil) (,scanner nil))
 124          (with-parser-context (token-scanner-context :scanner ,scanner)
 125            (multiple-value-bind (,value ,nerror ,nwarn)
 126                (flet ((,body ()
 127                         (setf ,char-scanner (make-string-scanner ,input)
 128                               ,scanner (make-instance
 129                                         'sod-token-scanner
 130                                         :char-scanner ,char-scanner))
 131                         (with-default-error-location (,scanner)
 132                           (multiple-value-bind (,value ,winp ,consumedp)
 133                               (parse ,parser)
 134                             (declare (ignore ,consumedp))
 135                             (cond (,winp ,value)
 136                                   (t (syntax-error ,scanner ,value)
 137                                      nil))))))
 138                  (if ,backtrace (,body)
 139                      (count-and-report-errors ()
 140                        (,body))))
 141              (let ((,where (scanner-capture-place ,char-scanner)))
 142                (values ,value
 143                        (list ,nerror ,nwarn)
 144                        (and ,scanner (list (token-type ,scanner)
 145                                            (token-value ,scanner)
 146                                            (subseq ,input ,where)))))))))))
 147
 148 ;;;--------------------------------------------------------------------------
 149 ;;; Calisthenics.
 150
 151 (export 'exercise)
 152 (defun exercise ()
 153   "Exercise the pieces of the metaobject protocol.
 154
 155    In some Lisps, the compiler is run the first time methods are called, to
 156    do fancy just-in-time optimization things.  This is great, only the
 157    program doesn't actually run for very long and a lot of that work is
 158    wasted because we're going to have to do it again next time the program
 159    starts.  Only, if we exercise the various methods, or at least a large
 160    fraction of them, before we dump an image, then everything will be fast.
 161
 162    That's the theory anyway.  Call this function before you dump an image and
 163    see what happens."
 164
 165   (dolist (reason '(:h :c))
 166     (with-output-to-string (bitbucket)
 167       (output-module *builtin-module* reason bitbucket)))
 168
 169   (clear-the-decks))
 170
 171 ;;;--------------------------------------------------------------------------
 172 ;;; Make sure things work after loading the system.
 173
 174 (clear-the-decks)
 175
 176 ;;;----- That's all, folks --------------------------------------------------