X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/54c017728489af16b13e13541e7cc53c985ca436..c6b4ed992d81518f240509e6ab212d8fe705485a:/src/final.lisp diff --git a/src/final.lisp b/src/final.lisp index 5df72f1..93fafe8 100644 --- a/src/final.lisp +++ b/src/final.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -26,22 +26,124 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- +;;; Miscellaneous details. + +(export '*sod-version*) +(defparameter *sod-version* sod-sysdef:*version* + "The version of the SOD translator system, as a string.") + +;;;-------------------------------------------------------------------------- ;;; Debugging utilities. (export '*debugout-pathname*) (defvar *debugout-pathname* #p"debugout.c") (export 'test-module) -(defun test-module (path reason) - "Reset the translator's state, read a module from PATH and output it with - REASON, returning the result as a string." - (clear-the-decks) - (setf *module-map* (make-hash-table :test #'equal)) - (with-open-file (out *debugout-pathname* - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (output-module (read-module path) reason out))) +(defun test-module (path &key reason clear backtrace) + "Read a module from PATH, to exercise the machinery. + + If CLEAR is non-nil, then reset the translator's state before proceeding. + + If REASON is non-nil, then output the module to `*debugout-pathname*' with + that REASON. + + Return a two-element list (NERROR NWARNING) of the number of errors and + warnings encountered while processing the module." + (when clear (clear-the-decks)) + (multiple-value-bind (module nerror nwarning) + (if backtrace (read-module path) + (count-and-report-errors () (read-module path))) + (when (and module reason) + (with-open-file (out *debugout-pathname* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (output-module module reason out))) + (list nerror nwarning))) + +(defmacro with-test-scanner ((scanner string) &body body) + "Common machinery for `test-parse-MUMBLE' below. + + This is too specialized to make more widely available." + (with-gensyms (in charscan) + (once-only (string) + `(with-input-from-string (,in ,string) + (let* ((*module-type-map* (make-hash-table)) + (,charscan (make-instance 'charbuf-scanner + :stream ,in + :filename "")) + (,scanner (make-instance 'sod-token-scanner + :char-scanner ,charscan + :filename ""))) + (with-parser-context (token-scanner-context :scanner ,scanner) + ,@body)))))) + +(export 'test-parse-c-type) +(defun test-parse-c-type (string) + "Parse STRING as a C type, with optional kernel, and show the results." + (with-test-scanner (scanner string) + (multiple-value-bind (value winp consumedp) + (parse (seq ((decls (parse-c-type scanner)) + (type (parse-declarator scanner decls :abstractp t)) + :eof) + type)) + (declare (ignore consumedp)) + (if winp + (values t (car value) (cdr value) + (princ-to-string (car value))) + (values nil value))))) + +(export 'test-parse-pset) +(defun test-parse-pset (string) + "Parse STRING as a property set, and show the results." + (with-test-scanner (scanner string) + (multiple-value-bind (value winp consumedp) + (parse-property-set scanner) + (declare (ignore consumedp)) + (values winp value)))) + +(export 'test-parser) +(defmacro test-parser ((scanner &key backtrace) parser input) + "Convenient macro for testing parsers at the REPL. + + This is a macro so that the parser can use the fancy syntax. The name + SCANNER is bound to a `sod-token-scanner' reading tokens from the INPUT + string. Then the PARSER is invoked and three values are returned: the + result of the parse, or `nil' if the main parse failed; a list containing + the number of errors and warnings (respectively) reported during the + parse; and a list consisting of the lookahead token type and value, and a + string containing the untokenized remaining input. + + If BACKTRACE is nil (the default) then leave errors to the calling + environment to sort out (e.g., by entering the Lisp debugger); otherwise, + catch and report them as they happen so that you can test error recovery + strategies." + (once-only (input) + (with-gensyms (char-scanner value winp body consumedp where nerror nwarn) + `(let ((,char-scanner nil) (,scanner nil)) + (with-parser-context (token-scanner-context :scanner ,scanner) + (multiple-value-bind (,value ,nerror ,nwarn) + (flet ((,body () + (setf ,char-scanner (make-string-scanner ,input) + ,scanner (make-instance + 'sod-token-scanner + :char-scanner ,char-scanner)) + (with-default-error-location (,scanner) + (multiple-value-bind (,value ,winp ,consumedp) + (parse ,parser) + (declare (ignore ,consumedp)) + (cond (,winp ,value) + (t (syntax-error ,scanner ,value) + nil)))))) + (if ,backtrace (,body) + (count-and-report-errors () + (,body)))) + (let ((,where (scanner-capture-place ,char-scanner))) + (values ,value + (list ,nerror ,nwarn) + (and ,scanner (list (token-type ,scanner) + (token-value ,scanner) + (subseq ,input ,where))))))))))) ;;;-------------------------------------------------------------------------- ;;; Calisthenics. @@ -60,11 +162,15 @@ That's the theory anyway. Call this function before you dump an image and see what happens." - (clear-the-decks) (dolist (reason '(:h :c)) (with-output-to-string (bitbucket) (output-module *builtin-module* reason bitbucket))) (clear-the-decks)) +;;;-------------------------------------------------------------------------- +;;; Make sure things work after loading the system. + +(clear-the-decks) + ;;;----- That's all, folks --------------------------------------------------